1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2019, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Contracts
; use Contracts
;
37 with Csets
; use Csets
;
38 with Debug
; use Debug
;
39 with Einfo
; use Einfo
;
40 with Elists
; use Elists
;
41 with Errout
; use Errout
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Ghost
; use Ghost
;
46 with Gnatvsn
; use Gnatvsn
;
48 with Lib
.Writ
; use Lib
.Writ
;
49 with Lib
.Xref
; use Lib
.Xref
;
50 with Namet
.Sp
; use Namet
.Sp
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
53 with Output
; use Output
;
54 with Par_SCO
; use Par_SCO
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Ch3
; use Sem_Ch3
;
61 with Sem_Ch6
; use Sem_Ch6
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Ch12
; use Sem_Ch12
;
64 with Sem_Ch13
; use Sem_Ch13
;
65 with Sem_Disp
; use Sem_Disp
;
66 with Sem_Dist
; use Sem_Dist
;
67 with Sem_Elab
; use Sem_Elab
;
68 with Sem_Elim
; use Sem_Elim
;
69 with Sem_Eval
; use Sem_Eval
;
70 with Sem_Intr
; use Sem_Intr
;
71 with Sem_Mech
; use Sem_Mech
;
72 with Sem_Res
; use Sem_Res
;
73 with Sem_Type
; use Sem_Type
;
74 with Sem_Util
; use Sem_Util
;
75 with Sem_Warn
; use Sem_Warn
;
76 with Stand
; use Stand
;
77 with Sinfo
; use Sinfo
;
78 with Sinfo
.CN
; use Sinfo
.CN
;
79 with Sinput
; use Sinput
;
80 with Stringt
; use Stringt
;
81 with Stylesw
; use Stylesw
;
83 with Targparm
; use Targparm
;
84 with Tbuild
; use Tbuild
;
86 with Uintp
; use Uintp
;
87 with Uname
; use Uname
;
88 with Urealp
; use Urealp
;
89 with Validsw
; use Validsw
;
90 with Warnsw
; use Warnsw
;
92 with System
.Case_Util
;
94 package body Sem_Prag
is
96 ----------------------------------------------
97 -- Common Handling of Import-Export Pragmas --
98 ----------------------------------------------
100 -- In the following section, a number of Import_xxx and Export_xxx pragmas
101 -- are defined by GNAT. These are compatible with the DEC pragmas of the
102 -- same name, and all have the following common form and processing:
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
110 -- [Internal =>] LOCAL_NAME
111 -- [, [External =>] EXTERNAL_SYMBOL]
112 -- [, other optional parameters ]);
114 -- EXTERNAL_SYMBOL ::=
116 -- | static_string_EXPRESSION
118 -- The internal LOCAL_NAME designates the entity that is imported or
119 -- exported, and must refer to an entity in the current declarative
120 -- part (as required by the rules for LOCAL_NAME).
122 -- The external linker name is designated by the External parameter if
123 -- given, or the Internal parameter if not (if there is no External
124 -- parameter, the External parameter is a copy of the Internal name).
126 -- If the External parameter is given as a string, then this string is
127 -- treated as an external name (exactly as though it had been given as an
128 -- External_Name parameter for a normal Import pragma).
130 -- If the External parameter is given as an identifier (or there is no
131 -- External parameter, so that the Internal identifier is used), then
132 -- the external name is the characters of the identifier, translated
133 -- to all lower case letters.
135 -- Note: the external name specified or implied by any of these special
136 -- Import_xxx or Export_xxx pragmas override an external or link name
137 -- specified in a previous Import or Export pragma.
139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
140 -- named notation, following the standard rules for subprogram calls, i.e.
141 -- parameters can be given in any order if named notation is used, and
142 -- positional and named notation can be mixed, subject to the rule that all
143 -- positional parameters must appear first.
145 -- Note: All these pragmas are implemented exactly following the DEC design
146 -- and implementation and are intended to be fully compatible with the use
147 -- of these pragmas in the DEC Ada compiler.
149 --------------------------------------------
150 -- Checking for Duplicated External Names --
151 --------------------------------------------
153 -- It is suspicious if two separate Export pragmas use the same external
154 -- name. The following table is used to diagnose this situation so that
155 -- an appropriate warning can be issued.
157 -- The Node_Id stored is for the N_String_Literal node created to hold
158 -- the value of the external name. The Sloc of this node is used to
159 -- cross-reference the location of the duplication.
161 package Externals
is new Table
.Table
(
162 Table_Component_Type
=> Node_Id
,
163 Table_Index_Type
=> Int
,
164 Table_Low_Bound
=> 0,
165 Table_Initial
=> 100,
166 Table_Increment
=> 100,
167 Table_Name
=> "Name_Externals");
169 -------------------------------------
170 -- Local Subprograms and Variables --
171 -------------------------------------
173 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
174 -- This routine is used for possible casing adjustment of an explicit
175 -- external name supplied as a string literal (the node N), according to
176 -- the casing requirement of Opt.External_Name_Casing. If this is set to
177 -- As_Is, then the string literal is returned unchanged, but if it is set
178 -- to Uppercase or Lowercase, then a new string literal with appropriate
179 -- casing is constructed.
181 procedure Analyze_Part_Of
185 Encap_Id
: out Entity_Id
;
186 Legal
: out Boolean);
187 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
188 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
189 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
190 -- package instantiation. Encap denotes the encapsulating state or single
191 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
192 -- the indicator is legal.
194 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
195 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
196 -- Query whether a particular item appears in a mixed list of nodes and
197 -- entities. It is assumed that all nodes in the list have entities.
199 procedure Check_Postcondition_Use_In_Inlined_Subprogram
201 Spec_Id
: Entity_Id
);
202 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
203 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
204 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
205 -- and assertions are enabled.
207 procedure Check_State_And_Constituent_Use
211 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
212 -- Global and Initializes. Determine whether a state from list States and a
213 -- corresponding constituent from list Constits (if any) appear in the same
214 -- context denoted by Context. If this is the case, emit an error.
216 procedure Contract_Freeze_Error
217 (Contract_Id
: Entity_Id
;
218 Freeze_Id
: Entity_Id
);
219 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
220 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
221 -- of a body which caused contract freezing and Contract_Id denotes the
222 -- entity of the affected contstruct.
224 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
225 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
226 -- Prag that duplicates previous pragma Prev.
228 function Find_Encapsulating_State
230 Constit_Id
: Entity_Id
) return Entity_Id
;
231 -- Given the entity of a constituent Constit_Id, find the corresponding
232 -- encapsulating state which appears in States. The routine returns Empty
233 -- if no such state is found.
235 function Find_Related_Context
237 Do_Checks
: Boolean := False) return Node_Id
;
238 -- Subsidiary to the analysis of pragmas
241 -- Constant_After_Elaboration
245 -- Find the first source declaration or statement found while traversing
246 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
247 -- set, the routine reports duplicate pragmas. The routine returns Empty
248 -- when reaching the start of the node chain.
250 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
251 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
252 -- original one, following the renaming chain) is returned. Otherwise the
253 -- entity is returned unchanged. Should be in Einfo???
255 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
256 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
257 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
258 -- value of type SPARK_Mode_Type.
260 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
261 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
262 -- Determine whether dependency clause Clause is surrounded by extra
263 -- parentheses. If this is the case, issue an error message.
265 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
266 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
267 -- pragma Depends. Determine whether the type of dependency item Item is
268 -- tagged, unconstrained array, unconstrained record or a record with at
269 -- least one unconstrained component.
271 procedure Record_Possible_Body_Reference
272 (State_Id
: Entity_Id
;
274 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
275 -- Global. Given an abstract state denoted by State_Id and a reference Ref
276 -- to it, determine whether the reference appears in a package body that
277 -- will eventually refine the state. If this is the case, record the
278 -- reference for future checks (see Analyze_Refined_State_In_Decls).
280 procedure Resolve_State
(N
: Node_Id
);
281 -- Handle the overloading of state names by functions. When N denotes a
282 -- function, this routine finds the corresponding state and sets the entity
283 -- of N to that of the state.
285 procedure Rewrite_Assertion_Kind
287 From_Policy
: Boolean := False);
288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
289 -- then it is rewritten as an identifier with the corresponding special
290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
291 -- and Check_Policy. If the names are Precondition or Postcondition, this
292 -- combination is deprecated in favor of Assertion_Policy and Ada2012
293 -- Aspect names. The parameter From_Policy indicates that the pragma
294 -- is the old non-standard Check_Policy and not a rewritten pragma.
296 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
297 -- Place semantic information on the argument of an Elaborate/Elaborate_All
298 -- pragma. Entity name for unit and its parents is taken from item in
299 -- previous with_clause that mentions the unit.
301 Dummy
: Integer := 0;
302 pragma Volatile
(Dummy
);
303 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
306 pragma No_Inline
(ip
);
307 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
308 -- is just to help debugging the front end. If a pragma Inspection_Point
309 -- is added to a source program, then breaking on ip will get you to that
310 -- point in the program.
313 pragma No_Inline
(rv
);
314 -- This is a dummy function called by the processing for pragma Reviewable.
315 -- It is there for assisting front end debugging. By placing a Reviewable
316 -- pragma in the source program, a breakpoint on rv catches this place in
317 -- the source, allowing convenient stepping to the point of interest.
319 -------------------------------
320 -- Adjust_External_Name_Case --
321 -------------------------------
323 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
327 -- Adjust case of literal if required
329 if Opt
.External_Name_Exp_Casing
= As_Is
then
333 -- Copy existing string
339 for J
in 1 .. String_Length
(Strval
(N
)) loop
340 CC
:= Get_String_Char
(Strval
(N
), J
);
342 if Opt
.External_Name_Exp_Casing
= Uppercase
343 and then CC
>= Get_Char_Code
('a')
344 and then CC
<= Get_Char_Code
('z')
346 Store_String_Char
(CC
- 32);
348 elsif Opt
.External_Name_Exp_Casing
= Lowercase
349 and then CC
>= Get_Char_Code
('A')
350 and then CC
<= Get_Char_Code
('Z')
352 Store_String_Char
(CC
+ 32);
355 Store_String_Char
(CC
);
360 Make_String_Literal
(Sloc
(N
),
361 Strval
=> End_String
);
363 end Adjust_External_Name_Case
;
365 -----------------------------------------
366 -- Analyze_Contract_Cases_In_Decl_Part --
367 -----------------------------------------
369 -- WARNING: This routine manages Ghost regions. Return statements must be
370 -- replaced by gotos which jump to the end of the routine and restore the
373 procedure Analyze_Contract_Cases_In_Decl_Part
375 Freeze_Id
: Entity_Id
:= Empty
)
377 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
378 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
380 Others_Seen
: Boolean := False;
381 -- This flag is set when an "others" choice is encountered. It is used
382 -- to detect multiple illegal occurrences of "others".
384 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
385 -- Verify the legality of a single contract case
387 ---------------------------
388 -- Analyze_Contract_Case --
389 ---------------------------
391 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
392 Case_Guard
: Node_Id
;
395 Extra_Guard
: Node_Id
;
398 if Nkind
(CCase
) = N_Component_Association
then
399 Case_Guard
:= First
(Choices
(CCase
));
400 Conseq
:= Expression
(CCase
);
402 -- Each contract case must have exactly one case guard
404 Extra_Guard
:= Next
(Case_Guard
);
406 if Present
(Extra_Guard
) then
408 ("contract case must have exactly one case guard",
412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
414 if Nkind
(Case_Guard
) = N_Others_Choice
then
417 ("only one others choice allowed in contract cases",
423 elsif Others_Seen
then
425 ("others must be the last choice in contract cases", N
);
428 -- Preanalyze the case guard and consequence
430 if Nkind
(Case_Guard
) /= N_Others_Choice
then
431 Errors
:= Serious_Errors_Detected
;
432 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
434 -- Emit a clarification message when the case guard contains
435 -- at least one undefined reference, possibly due to contract
438 if Errors
/= Serious_Errors_Detected
439 and then Present
(Freeze_Id
)
440 and then Has_Undefined_Reference
(Case_Guard
)
442 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
446 Errors
:= Serious_Errors_Detected
;
447 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
449 -- Emit a clarification message when the consequence contains
450 -- at least one undefined reference, possibly due to contract
453 if Errors
/= Serious_Errors_Detected
454 and then Present
(Freeze_Id
)
455 and then Has_Undefined_Reference
(Conseq
)
457 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
460 -- The contract case is malformed
463 Error_Msg_N
("wrong syntax in contract case", CCase
);
465 end Analyze_Contract_Case
;
469 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
471 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
472 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
473 -- Save the Ghost-related attributes to restore on exit
476 Restore_Scope
: Boolean := False;
478 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
481 -- Do not analyze the pragma multiple times
483 if Is_Analyzed_Pragma
(N
) then
487 -- Set the Ghost mode in effect from the pragma. Due to the delayed
488 -- analysis of the pragma, the Ghost mode at point of declaration and
489 -- point of analysis may not necessarily be the same. Use the mode in
490 -- effect at the point of declaration.
494 -- Single and multiple contract cases must appear in aggregate form. If
495 -- this is not the case, then either the parser of the analysis of the
496 -- pragma failed to produce an aggregate.
498 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
500 if Present
(Component_Associations
(CCases
)) then
502 -- Ensure that the formal parameters are visible when analyzing all
503 -- clauses. This falls out of the general rule of aspects pertaining
504 -- to subprogram declarations.
506 if not In_Open_Scopes
(Spec_Id
) then
507 Restore_Scope
:= True;
508 Push_Scope
(Spec_Id
);
510 if Is_Generic_Subprogram
(Spec_Id
) then
511 Install_Generic_Formals
(Spec_Id
);
513 Install_Formals
(Spec_Id
);
517 CCase
:= First
(Component_Associations
(CCases
));
518 while Present
(CCase
) loop
519 Analyze_Contract_Case
(CCase
);
523 if Restore_Scope
then
527 -- Currently it is not possible to inline pre/postconditions on a
528 -- subprogram subject to pragma Inline_Always.
530 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
532 -- Otherwise the pragma is illegal
535 Error_Msg_N
("wrong syntax for constract cases", N
);
538 Set_Is_Analyzed_Pragma
(N
);
540 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
541 end Analyze_Contract_Cases_In_Decl_Part
;
543 ----------------------------------
544 -- Analyze_Depends_In_Decl_Part --
545 ----------------------------------
547 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
548 Loc
: constant Source_Ptr
:= Sloc
(N
);
549 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
550 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
552 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
553 -- A list containing the entities of all the inputs processed so far.
554 -- The list is populated with unique entities because the same input
555 -- may appear in multiple input lists.
557 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
558 -- A list containing the entities of all the outputs processed so far.
559 -- The list is populated with unique entities because output items are
560 -- unique in a dependence relation.
562 Constits_Seen
: Elist_Id
:= No_Elist
;
563 -- A list containing the entities of all constituents processed so far.
564 -- It aids in detecting illegal usage of a state and a corresponding
565 -- constituent in pragma [Refinde_]Depends.
567 Global_Seen
: Boolean := False;
568 -- A flag set when pragma Global has been processed
570 Null_Output_Seen
: Boolean := False;
571 -- A flag used to track the legality of a null output
573 Result_Seen
: Boolean := False;
574 -- A flag set when Spec_Id'Result is processed
576 States_Seen
: Elist_Id
:= No_Elist
;
577 -- A list containing the entities of all states processed so far. It
578 -- helps in detecting illegal usage of a state and a corresponding
579 -- constituent in pragma [Refined_]Depends.
581 Subp_Inputs
: Elist_Id
:= No_Elist
;
582 Subp_Outputs
: Elist_Id
:= No_Elist
;
583 -- Two lists containing the full set of inputs and output of the related
584 -- subprograms. Note that these lists contain both nodes and entities.
586 Task_Input_Seen
: Boolean := False;
587 Task_Output_Seen
: Boolean := False;
588 -- Flags used to track the implicit dependence of a task unit on itself
590 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
591 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
592 -- to the name buffer. The individual kinds are as follows:
593 -- E_Abstract_State - "state"
594 -- E_Constant - "constant"
595 -- E_Generic_In_Out_Parameter - "generic parameter"
596 -- E_Generic_In_Parameter - "generic parameter"
597 -- E_In_Parameter - "parameter"
598 -- E_In_Out_Parameter - "parameter"
599 -- E_Loop_Parameter - "loop parameter"
600 -- E_Out_Parameter - "parameter"
601 -- E_Protected_Type - "current instance of protected type"
602 -- E_Task_Type - "current instance of task type"
603 -- E_Variable - "global"
605 procedure Analyze_Dependency_Clause
608 -- Verify the legality of a single dependency clause. Flag Is_Last
609 -- denotes whether Clause is the last clause in the relation.
611 procedure Check_Function_Return
;
612 -- Verify that Funtion'Result appears as one of the outputs
613 -- (SPARK RM 6.1.5(10)).
620 -- Ensure that an item fulfills its designated input and/or output role
621 -- as specified by pragma Global (if any) or the enclosing context. If
622 -- this is not the case, emit an error. Item and Item_Id denote the
623 -- attributes of an item. Flag Is_Input should be set when item comes
624 -- from an input list. Flag Self_Ref should be set when the item is an
625 -- output and the dependency clause has operator "+".
627 procedure Check_Usage
628 (Subp_Items
: Elist_Id
;
629 Used_Items
: Elist_Id
;
631 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
632 -- error if this is not the case.
634 procedure Normalize_Clause
(Clause
: Node_Id
);
635 -- Remove a self-dependency "+" from the input list of a clause
637 -----------------------------
638 -- Add_Item_To_Name_Buffer --
639 -----------------------------
641 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
643 if Ekind
(Item_Id
) = E_Abstract_State
then
644 Add_Str_To_Name_Buffer
("state");
646 elsif Ekind
(Item_Id
) = E_Constant
then
647 Add_Str_To_Name_Buffer
("constant");
649 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
650 E_Generic_In_Parameter
)
652 Add_Str_To_Name_Buffer
("generic parameter");
654 elsif Is_Formal
(Item_Id
) then
655 Add_Str_To_Name_Buffer
("parameter");
657 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
658 Add_Str_To_Name_Buffer
("loop parameter");
660 elsif Ekind
(Item_Id
) = E_Protected_Type
661 or else Is_Single_Protected_Object
(Item_Id
)
663 Add_Str_To_Name_Buffer
("current instance of protected type");
665 elsif Ekind
(Item_Id
) = E_Task_Type
666 or else Is_Single_Task_Object
(Item_Id
)
668 Add_Str_To_Name_Buffer
("current instance of task type");
670 elsif Ekind
(Item_Id
) = E_Variable
then
671 Add_Str_To_Name_Buffer
("global");
673 -- The routine should not be called with non-SPARK items
678 end Add_Item_To_Name_Buffer
;
680 -------------------------------
681 -- Analyze_Dependency_Clause --
682 -------------------------------
684 procedure Analyze_Dependency_Clause
688 procedure Analyze_Input_List
(Inputs
: Node_Id
);
689 -- Verify the legality of a single input list
691 procedure Analyze_Input_Output
696 Seen
: in out Elist_Id
;
697 Null_Seen
: in out Boolean;
698 Non_Null_Seen
: in out Boolean);
699 -- Verify the legality of a single input or output item. Flag
700 -- Is_Input should be set whenever Item is an input, False when it
701 -- denotes an output. Flag Self_Ref should be set when the item is an
702 -- output and the dependency clause has a "+". Flag Top_Level should
703 -- be set whenever Item appears immediately within an input or output
704 -- list. Seen is a collection of all abstract states, objects and
705 -- formals processed so far. Flag Null_Seen denotes whether a null
706 -- input or output has been encountered. Flag Non_Null_Seen denotes
707 -- whether a non-null input or output has been encountered.
709 ------------------------
710 -- Analyze_Input_List --
711 ------------------------
713 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
714 Inputs_Seen
: Elist_Id
:= No_Elist
;
715 -- A list containing the entities of all inputs that appear in the
716 -- current input list.
718 Non_Null_Input_Seen
: Boolean := False;
719 Null_Input_Seen
: Boolean := False;
720 -- Flags used to check the legality of an input list
725 -- Multiple inputs appear as an aggregate
727 if Nkind
(Inputs
) = N_Aggregate
then
728 if Present
(Component_Associations
(Inputs
)) then
730 ("nested dependency relations not allowed", Inputs
);
732 elsif Present
(Expressions
(Inputs
)) then
733 Input
:= First
(Expressions
(Inputs
));
734 while Present
(Input
) loop
741 Null_Seen
=> Null_Input_Seen
,
742 Non_Null_Seen
=> Non_Null_Input_Seen
);
747 -- Syntax error, always report
750 Error_Msg_N
("malformed input dependency list", Inputs
);
753 -- Process a solitary input
762 Null_Seen
=> Null_Input_Seen
,
763 Non_Null_Seen
=> Non_Null_Input_Seen
);
766 -- Detect an illegal dependency clause of the form
770 if Null_Output_Seen
and then Null_Input_Seen
then
772 ("null dependency clause cannot have a null input list",
775 end Analyze_Input_List
;
777 --------------------------
778 -- Analyze_Input_Output --
779 --------------------------
781 procedure Analyze_Input_Output
786 Seen
: in out Elist_Id
;
787 Null_Seen
: in out Boolean;
788 Non_Null_Seen
: in out Boolean)
790 procedure Current_Task_Instance_Seen
;
791 -- Set the appropriate global flag when the current instance of a
792 -- task unit is encountered.
794 --------------------------------
795 -- Current_Task_Instance_Seen --
796 --------------------------------
798 procedure Current_Task_Instance_Seen
is
801 Task_Input_Seen
:= True;
803 Task_Output_Seen
:= True;
805 end Current_Task_Instance_Seen
;
809 Is_Output
: constant Boolean := not Is_Input
;
813 -- Start of processing for Analyze_Input_Output
816 -- Multiple input or output items appear as an aggregate
818 if Nkind
(Item
) = N_Aggregate
then
819 if not Top_Level
then
820 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
822 elsif Present
(Component_Associations
(Item
)) then
824 ("nested dependency relations not allowed", Item
);
826 -- Recursively analyze the grouped items
828 elsif Present
(Expressions
(Item
)) then
829 Grouped
:= First
(Expressions
(Item
));
830 while Present
(Grouped
) loop
833 Is_Input
=> Is_Input
,
834 Self_Ref
=> Self_Ref
,
837 Null_Seen
=> Null_Seen
,
838 Non_Null_Seen
=> Non_Null_Seen
);
843 -- Syntax error, always report
846 Error_Msg_N
("malformed dependency list", Item
);
849 -- Process attribute 'Result in the context of a dependency clause
851 elsif Is_Attribute_Result
(Item
) then
852 Non_Null_Seen
:= True;
856 -- Attribute 'Result is allowed to appear on the output side of
857 -- a dependency clause (SPARK RM 6.1.5(6)).
860 SPARK_Msg_N
("function result cannot act as input", Item
);
864 ("cannot mix null and non-null dependency items", Item
);
870 -- Detect multiple uses of null in a single dependency list or
871 -- throughout the whole relation. Verify the placement of a null
872 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
874 elsif Nkind
(Item
) = N_Null
then
877 ("multiple null dependency relations not allowed", Item
);
879 elsif Non_Null_Seen
then
881 ("cannot mix null and non-null dependency items", Item
);
889 ("null output list must be the last clause in a "
890 & "dependency relation", Item
);
892 -- Catch a useless dependence of the form:
897 ("useless dependence, null depends on itself", Item
);
905 Non_Null_Seen
:= True;
908 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
912 Resolve_State
(Item
);
914 -- Find the entity of the item. If this is a renaming, climb
915 -- the renaming chain to reach the root object. Renamings of
916 -- non-entire objects do not yield an entity (Empty).
918 Item_Id
:= Entity_Of
(Item
);
920 if Present
(Item_Id
) then
924 if Ekind_In
(Item_Id
, E_Constant
, E_Loop_Parameter
)
927 -- Current instances of concurrent types
929 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
934 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
935 E_Generic_In_Parameter
,
943 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
945 -- A [generic] function is not allowed to have Output
946 -- items in its dependency relations. Note that "null"
947 -- and attribute 'Result are still valid items.
949 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
950 and then not Is_Input
953 ("output item is not applicable to function", Item
);
956 -- The item denotes a concurrent type. Note that single
957 -- protected/task types are not considered here because
958 -- they behave as objects in the context of pragma
959 -- [Refined_]Depends.
961 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
963 -- This use is legal as long as the concurrent type is
964 -- the current instance of an enclosing type.
966 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
968 -- The dependence of a task unit on itself is
969 -- implicit and may or may not be explicitly
970 -- specified (SPARK RM 6.1.4).
972 if Ekind
(Item_Id
) = E_Task_Type
then
973 Current_Task_Instance_Seen
;
976 -- Otherwise this is not the current instance
980 ("invalid use of subtype mark in dependency "
984 -- The dependency of a task unit on itself is implicit
985 -- and may or may not be explicitly specified
988 elsif Is_Single_Task_Object
(Item_Id
)
989 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
991 Current_Task_Instance_Seen
;
994 -- Ensure that the item fulfills its role as input and/or
995 -- output as specified by pragma Global or the enclosing
998 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1000 -- Detect multiple uses of the same state, variable or
1001 -- formal parameter. If this is not the case, add the
1002 -- item to the list of processed relations.
1004 if Contains
(Seen
, Item_Id
) then
1006 ("duplicate use of item &", Item
, Item_Id
);
1008 Append_New_Elmt
(Item_Id
, Seen
);
1011 -- Detect illegal use of an input related to a null
1012 -- output. Such input items cannot appear in other
1013 -- input lists (SPARK RM 6.1.5(13)).
1016 and then Null_Output_Seen
1017 and then Contains
(All_Inputs_Seen
, Item_Id
)
1020 ("input of a null output list cannot appear in "
1021 & "multiple input lists", Item
);
1024 -- Add an input or a self-referential output to the list
1025 -- of all processed inputs.
1027 if Is_Input
or else Self_Ref
then
1028 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1031 -- State related checks (SPARK RM 6.1.5(3))
1033 if Ekind
(Item_Id
) = E_Abstract_State
then
1035 -- Package and subprogram bodies are instantiated
1036 -- individually in a separate compiler pass. Due to
1037 -- this mode of instantiation, the refinement of a
1038 -- state may no longer be visible when a subprogram
1039 -- body contract is instantiated. Since the generic
1040 -- template is legal, do not perform this check in
1041 -- the instance to circumvent this oddity.
1043 if Is_Generic_Instance
(Spec_Id
) then
1046 -- An abstract state with visible refinement cannot
1047 -- appear in pragma [Refined_]Depends as its place
1048 -- must be taken by some of its constituents
1049 -- (SPARK RM 6.1.4(7)).
1051 elsif Has_Visible_Refinement
(Item_Id
) then
1053 ("cannot mention state & in dependence relation",
1055 SPARK_Msg_N
("\use its constituents instead", Item
);
1058 -- If the reference to the abstract state appears in
1059 -- an enclosing package body that will eventually
1060 -- refine the state, record the reference for future
1064 Record_Possible_Body_Reference
1065 (State_Id
=> Item_Id
,
1070 -- When the item renames an entire object, replace the
1071 -- item with a reference to the object.
1073 if Entity
(Item
) /= Item_Id
then
1075 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1079 -- Add the entity of the current item to the list of
1082 if Ekind
(Item_Id
) = E_Abstract_State
then
1083 Append_New_Elmt
(Item_Id
, States_Seen
);
1085 -- The variable may eventually become a constituent of a
1086 -- single protected/task type. Record the reference now
1087 -- and verify its legality when analyzing the contract of
1088 -- the variable (SPARK RM 9.3).
1090 elsif Ekind
(Item_Id
) = E_Variable
then
1091 Record_Possible_Part_Of_Reference
1096 if Ekind_In
(Item_Id
, E_Abstract_State
,
1099 and then Present
(Encapsulating_State
(Item_Id
))
1101 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1104 -- All other input/output items are illegal
1105 -- (SPARK RM 6.1.5(1)).
1109 ("item must denote parameter, variable, state or "
1110 & "current instance of concurrent type", Item
);
1113 -- All other input/output items are illegal
1114 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1118 ("item must denote parameter, variable, state or current "
1119 & "instance of concurrent type", Item
);
1122 end Analyze_Input_Output
;
1130 Non_Null_Output_Seen
: Boolean := False;
1131 -- Flag used to check the legality of an output list
1133 -- Start of processing for Analyze_Dependency_Clause
1136 Inputs
:= Expression
(Clause
);
1139 -- An input list with a self-dependency appears as operator "+" where
1140 -- the actuals inputs are the right operand.
1142 if Nkind
(Inputs
) = N_Op_Plus
then
1143 Inputs
:= Right_Opnd
(Inputs
);
1147 -- Process the output_list of a dependency_clause
1149 Output
:= First
(Choices
(Clause
));
1150 while Present
(Output
) loop
1151 Analyze_Input_Output
1154 Self_Ref
=> Self_Ref
,
1156 Seen
=> All_Outputs_Seen
,
1157 Null_Seen
=> Null_Output_Seen
,
1158 Non_Null_Seen
=> Non_Null_Output_Seen
);
1163 -- Process the input_list of a dependency_clause
1165 Analyze_Input_List
(Inputs
);
1166 end Analyze_Dependency_Clause
;
1168 ---------------------------
1169 -- Check_Function_Return --
1170 ---------------------------
1172 procedure Check_Function_Return
is
1174 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1175 and then not Result_Seen
1178 ("result of & must appear in exactly one output list",
1181 end Check_Function_Return
;
1187 procedure Check_Role
1189 Item_Id
: Entity_Id
;
1194 (Item_Is_Input
: out Boolean;
1195 Item_Is_Output
: out Boolean);
1196 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1197 -- Item_Is_Output are set depending on the role.
1199 procedure Role_Error
1200 (Item_Is_Input
: Boolean;
1201 Item_Is_Output
: Boolean);
1202 -- Emit an error message concerning the incorrect use of Item in
1203 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1204 -- denote whether the item is an input and/or an output.
1211 (Item_Is_Input
: out Boolean;
1212 Item_Is_Output
: out Boolean)
1215 case Ekind
(Item_Id
) is
1219 when E_Abstract_State
=>
1221 -- When pragma Global is present it determines the mode of
1222 -- the abstract state.
1225 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1226 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1228 -- Otherwise the state has a default IN OUT mode, because it
1229 -- behaves as a variable.
1232 Item_Is_Input
:= True;
1233 Item_Is_Output
:= True;
1236 -- Constants and IN parameters
1239 | E_Generic_In_Parameter
1243 -- When pragma Global is present it determines the mode
1244 -- of constant objects as inputs (and such objects cannot
1245 -- appear as outputs in the Global contract).
1248 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1250 Item_Is_Input
:= True;
1253 Item_Is_Output
:= False;
1255 -- Variables and IN OUT parameters
1257 when E_Generic_In_Out_Parameter
1258 | E_In_Out_Parameter
1261 -- When pragma Global is present it determines the mode of
1266 -- A variable has mode IN when its type is unconstrained
1267 -- or tagged because array bounds, discriminants or tags
1271 Appears_In
(Subp_Inputs
, Item_Id
)
1272 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1274 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1276 -- Otherwise the variable has a default IN OUT mode
1279 Item_Is_Input
:= True;
1280 Item_Is_Output
:= True;
1283 when E_Out_Parameter
=>
1285 -- An OUT parameter of the related subprogram; it cannot
1286 -- appear in Global.
1288 if Scope
(Item_Id
) = Spec_Id
then
1290 -- The parameter has mode IN if its type is unconstrained
1291 -- or tagged because array bounds, discriminants or tags
1295 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1297 Item_Is_Output
:= True;
1299 -- An OUT parameter of an enclosing subprogram; it can
1300 -- appear in Global and behaves as a read-write variable.
1303 -- When pragma Global is present it determines the mode
1308 -- A variable has mode IN when its type is
1309 -- unconstrained or tagged because array
1310 -- bounds, discriminants or tags can be read.
1313 Appears_In
(Subp_Inputs
, Item_Id
)
1314 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1316 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1318 -- Otherwise the variable has a default IN OUT mode
1321 Item_Is_Input
:= True;
1322 Item_Is_Output
:= True;
1328 when E_Protected_Type
=>
1331 -- A variable has mode IN when its type is unconstrained
1332 -- or tagged because array bounds, discriminants or tags
1336 Appears_In
(Subp_Inputs
, Item_Id
)
1337 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1339 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1342 -- A protected type acts as a formal parameter of mode IN
1343 -- when it applies to a protected function.
1345 if Ekind
(Spec_Id
) = E_Function
then
1346 Item_Is_Input
:= True;
1347 Item_Is_Output
:= False;
1349 -- Otherwise the protected type acts as a formal of mode
1353 Item_Is_Input
:= True;
1354 Item_Is_Output
:= True;
1362 -- When pragma Global is present it determines the mode of
1367 Appears_In
(Subp_Inputs
, Item_Id
)
1368 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1370 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1372 -- Otherwise task types act as IN OUT parameters
1375 Item_Is_Input
:= True;
1376 Item_Is_Output
:= True;
1380 raise Program_Error
;
1388 procedure Role_Error
1389 (Item_Is_Input
: Boolean;
1390 Item_Is_Output
: Boolean)
1392 Error_Msg
: Name_Id
;
1397 -- When the item is not part of the input and the output set of
1398 -- the related subprogram, then it appears as extra in pragma
1399 -- [Refined_]Depends.
1401 if not Item_Is_Input
and then not Item_Is_Output
then
1402 Add_Item_To_Name_Buffer
(Item_Id
);
1403 Add_Str_To_Name_Buffer
1404 (" & cannot appear in dependence relation");
1406 Error_Msg
:= Name_Find
;
1407 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1409 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1411 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1412 & "set of subprogram %"), Item
, Item_Id
);
1414 -- The mode of the item and its role in pragma [Refined_]Depends
1415 -- are in conflict. Construct a detailed message explaining the
1416 -- illegality (SPARK RM 6.1.5(5-6)).
1419 if Item_Is_Input
then
1420 Add_Str_To_Name_Buffer
("read-only");
1422 Add_Str_To_Name_Buffer
("write-only");
1425 Add_Char_To_Name_Buffer
(' ');
1426 Add_Item_To_Name_Buffer
(Item_Id
);
1427 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1429 if Item_Is_Input
then
1430 Add_Str_To_Name_Buffer
("output");
1432 Add_Str_To_Name_Buffer
("input");
1435 Add_Str_To_Name_Buffer
(" in dependence relation");
1436 Error_Msg
:= Name_Find
;
1437 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1443 Item_Is_Input
: Boolean;
1444 Item_Is_Output
: Boolean;
1446 -- Start of processing for Check_Role
1449 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1454 if not Item_Is_Input
then
1455 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1458 -- Self-referential item
1461 if not Item_Is_Input
or else not Item_Is_Output
then
1462 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1467 elsif not Item_Is_Output
then
1468 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1476 procedure Check_Usage
1477 (Subp_Items
: Elist_Id
;
1478 Used_Items
: Elist_Id
;
1481 procedure Usage_Error
(Item_Id
: Entity_Id
);
1482 -- Emit an error concerning the illegal usage of an item
1488 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1489 Error_Msg
: Name_Id
;
1496 -- Unconstrained and tagged items are not part of the explicit
1497 -- input set of the related subprogram, they do not have to be
1498 -- present in a dependence relation and should not be flagged
1499 -- (SPARK RM 6.1.5(5)).
1501 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1504 Add_Item_To_Name_Buffer
(Item_Id
);
1505 Add_Str_To_Name_Buffer
1506 (" & is missing from input dependence list");
1508 Error_Msg
:= Name_Find
;
1509 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1511 ("\add `null ='> &` dependency to ignore this input",
1515 -- Output case (SPARK RM 6.1.5(10))
1520 Add_Item_To_Name_Buffer
(Item_Id
);
1521 Add_Str_To_Name_Buffer
1522 (" & is missing from output dependence list");
1524 Error_Msg
:= Name_Find
;
1525 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1533 Item_Id
: Entity_Id
;
1535 -- Start of processing for Check_Usage
1538 if No
(Subp_Items
) then
1542 -- Each input or output of the subprogram must appear in a dependency
1545 Elmt
:= First_Elmt
(Subp_Items
);
1546 while Present
(Elmt
) loop
1547 Item
:= Node
(Elmt
);
1549 if Nkind
(Item
) = N_Defining_Identifier
then
1552 Item_Id
:= Entity_Of
(Item
);
1555 -- The item does not appear in a dependency
1557 if Present
(Item_Id
)
1558 and then not Contains
(Used_Items
, Item_Id
)
1560 if Is_Formal
(Item_Id
) then
1561 Usage_Error
(Item_Id
);
1563 -- The current instance of a protected type behaves as a formal
1564 -- parameter (SPARK RM 6.1.4).
1566 elsif Ekind
(Item_Id
) = E_Protected_Type
1567 or else Is_Single_Protected_Object
(Item_Id
)
1569 Usage_Error
(Item_Id
);
1571 -- The current instance of a task type behaves as a formal
1572 -- parameter (SPARK RM 6.1.4).
1574 elsif Ekind
(Item_Id
) = E_Task_Type
1575 or else Is_Single_Task_Object
(Item_Id
)
1577 -- The dependence of a task unit on itself is implicit and
1578 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1579 -- Emit an error if only one input/output is present.
1581 if Task_Input_Seen
/= Task_Output_Seen
then
1582 Usage_Error
(Item_Id
);
1585 -- States and global objects are not used properly only when
1586 -- the subprogram is subject to pragma Global.
1588 elsif Global_Seen
then
1589 Usage_Error
(Item_Id
);
1597 ----------------------
1598 -- Normalize_Clause --
1599 ----------------------
1601 procedure Normalize_Clause
(Clause
: Node_Id
) is
1602 procedure Create_Or_Modify_Clause
1608 Multiple
: Boolean);
1609 -- Create a brand new clause to represent the self-reference or
1610 -- modify the input and/or output lists of an existing clause. Output
1611 -- denotes a self-referencial output. Outputs is the output list of a
1612 -- clause. Inputs is the input list of a clause. After denotes the
1613 -- clause after which the new clause is to be inserted. Flag In_Place
1614 -- should be set when normalizing the last output of an output list.
1615 -- Flag Multiple should be set when Output comes from a list with
1618 -----------------------------
1619 -- Create_Or_Modify_Clause --
1620 -----------------------------
1622 procedure Create_Or_Modify_Clause
1630 procedure Propagate_Output
1633 -- Handle the various cases of output propagation to the input
1634 -- list. Output denotes a self-referencial output item. Inputs
1635 -- is the input list of a clause.
1637 ----------------------
1638 -- Propagate_Output --
1639 ----------------------
1641 procedure Propagate_Output
1645 function In_Input_List
1647 Inputs
: List_Id
) return Boolean;
1648 -- Determine whether a particulat item appears in the input
1649 -- list of a clause.
1655 function In_Input_List
1657 Inputs
: List_Id
) return Boolean
1662 Elmt
:= First
(Inputs
);
1663 while Present
(Elmt
) loop
1664 if Entity_Of
(Elmt
) = Item
then
1676 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1679 -- Start of processing for Propagate_Output
1682 -- The clause is of the form:
1684 -- (Output =>+ null)
1686 -- Remove null input and replace it with a copy of the output:
1688 -- (Output => Output)
1690 if Nkind
(Inputs
) = N_Null
then
1691 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1693 -- The clause is of the form:
1695 -- (Output =>+ (Input1, ..., InputN))
1697 -- Determine whether the output is not already mentioned in the
1698 -- input list and if not, add it to the list of inputs:
1700 -- (Output => (Output, Input1, ..., InputN))
1702 elsif Nkind
(Inputs
) = N_Aggregate
then
1703 Grouped
:= Expressions
(Inputs
);
1705 if not In_Input_List
1709 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1712 -- The clause is of the form:
1714 -- (Output =>+ Input)
1716 -- If the input does not mention the output, group the two
1719 -- (Output => (Output, Input))
1721 elsif Entity_Of
(Inputs
) /= Output_Id
then
1723 Make_Aggregate
(Loc
,
1724 Expressions
=> New_List
(
1725 New_Copy_Tree
(Output
),
1726 New_Copy_Tree
(Inputs
))));
1728 end Propagate_Output
;
1732 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1733 New_Clause
: Node_Id
;
1735 -- Start of processing for Create_Or_Modify_Clause
1738 -- A null output depending on itself does not require any
1741 if Nkind
(Output
) = N_Null
then
1744 -- A function result cannot depend on itself because it cannot
1745 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1747 elsif Is_Attribute_Result
(Output
) then
1748 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1752 -- When performing the transformation in place, simply add the
1753 -- output to the list of inputs (if not already there). This
1754 -- case arises when dealing with the last output of an output
1755 -- list. Perform the normalization in place to avoid generating
1756 -- a malformed tree.
1759 Propagate_Output
(Output
, Inputs
);
1761 -- A list with multiple outputs is slowly trimmed until only
1762 -- one element remains. When this happens, replace aggregate
1763 -- with the element itself.
1767 Rewrite
(Outputs
, Output
);
1773 -- Unchain the output from its output list as it will appear in
1774 -- a new clause. Note that we cannot simply rewrite the output
1775 -- as null because this will violate the semantics of pragma
1780 -- Generate a new clause of the form:
1781 -- (Output => Inputs)
1784 Make_Component_Association
(Loc
,
1785 Choices
=> New_List
(Output
),
1786 Expression
=> New_Copy_Tree
(Inputs
));
1788 -- The new clause contains replicated content that has already
1789 -- been analyzed. There is not need to reanalyze or renormalize
1792 Set_Analyzed
(New_Clause
);
1795 (Output
=> First
(Choices
(New_Clause
)),
1796 Inputs
=> Expression
(New_Clause
));
1798 Insert_After
(After
, New_Clause
);
1800 end Create_Or_Modify_Clause
;
1804 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1806 Last_Output
: Node_Id
;
1807 Next_Output
: Node_Id
;
1810 -- Start of processing for Normalize_Clause
1813 -- A self-dependency appears as operator "+". Remove the "+" from the
1814 -- tree by moving the real inputs to their proper place.
1816 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1817 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1818 Inputs
:= Expression
(Clause
);
1820 -- Multiple outputs appear as an aggregate
1822 if Nkind
(Outputs
) = N_Aggregate
then
1823 Last_Output
:= Last
(Expressions
(Outputs
));
1825 Output
:= First
(Expressions
(Outputs
));
1826 while Present
(Output
) loop
1828 -- Normalization may remove an output from its list,
1829 -- preserve the subsequent output now.
1831 Next_Output
:= Next
(Output
);
1833 Create_Or_Modify_Clause
1838 In_Place
=> Output
= Last_Output
,
1841 Output
:= Next_Output
;
1847 Create_Or_Modify_Clause
1856 end Normalize_Clause
;
1860 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1861 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1865 Last_Clause
: Node_Id
;
1866 Restore_Scope
: Boolean := False;
1868 -- Start of processing for Analyze_Depends_In_Decl_Part
1871 -- Do not analyze the pragma multiple times
1873 if Is_Analyzed_Pragma
(N
) then
1877 -- Empty dependency list
1879 if Nkind
(Deps
) = N_Null
then
1881 -- Gather all states, objects and formal parameters that the
1882 -- subprogram may depend on. These items are obtained from the
1883 -- parameter profile or pragma [Refined_]Global (if available).
1885 Collect_Subprogram_Inputs_Outputs
1886 (Subp_Id
=> Subp_Id
,
1887 Subp_Inputs
=> Subp_Inputs
,
1888 Subp_Outputs
=> Subp_Outputs
,
1889 Global_Seen
=> Global_Seen
);
1891 -- Verify that every input or output of the subprogram appear in a
1894 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1895 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1896 Check_Function_Return
;
1898 -- Dependency clauses appear as component associations of an aggregate
1900 elsif Nkind
(Deps
) = N_Aggregate
then
1902 -- Do not attempt to perform analysis of a syntactically illegal
1903 -- clause as this will lead to misleading errors.
1905 if Has_Extra_Parentheses
(Deps
) then
1909 if Present
(Component_Associations
(Deps
)) then
1910 Last_Clause
:= Last
(Component_Associations
(Deps
));
1912 -- Gather all states, objects and formal parameters that the
1913 -- subprogram may depend on. These items are obtained from the
1914 -- parameter profile or pragma [Refined_]Global (if available).
1916 Collect_Subprogram_Inputs_Outputs
1917 (Subp_Id
=> Subp_Id
,
1918 Subp_Inputs
=> Subp_Inputs
,
1919 Subp_Outputs
=> Subp_Outputs
,
1920 Global_Seen
=> Global_Seen
);
1922 -- When pragma [Refined_]Depends appears on a single concurrent
1923 -- type, it is relocated to the anonymous object.
1925 if Is_Single_Concurrent_Object
(Spec_Id
) then
1928 -- Ensure that the formal parameters are visible when analyzing
1929 -- all clauses. This falls out of the general rule of aspects
1930 -- pertaining to subprogram declarations.
1932 elsif not In_Open_Scopes
(Spec_Id
) then
1933 Restore_Scope
:= True;
1934 Push_Scope
(Spec_Id
);
1936 if Ekind
(Spec_Id
) = E_Task_Type
then
1937 if Has_Discriminants
(Spec_Id
) then
1938 Install_Discriminants
(Spec_Id
);
1941 elsif Is_Generic_Subprogram
(Spec_Id
) then
1942 Install_Generic_Formals
(Spec_Id
);
1945 Install_Formals
(Spec_Id
);
1949 Clause
:= First
(Component_Associations
(Deps
));
1950 while Present
(Clause
) loop
1951 Errors
:= Serious_Errors_Detected
;
1953 -- The normalization mechanism may create extra clauses that
1954 -- contain replicated input and output names. There is no need
1955 -- to reanalyze them.
1957 if not Analyzed
(Clause
) then
1958 Set_Analyzed
(Clause
);
1960 Analyze_Dependency_Clause
1962 Is_Last
=> Clause
= Last_Clause
);
1965 -- Do not normalize a clause if errors were detected (count
1966 -- of Serious_Errors has increased) because the inputs and/or
1967 -- outputs may denote illegal items. Normalization is disabled
1968 -- in ASIS mode as it alters the tree by introducing new nodes
1969 -- similar to expansion.
1971 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1972 Normalize_Clause
(Clause
);
1978 if Restore_Scope
then
1982 -- Verify that every input or output of the subprogram appear in a
1985 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1986 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1987 Check_Function_Return
;
1989 -- The dependency list is malformed. This is a syntax error, always
1993 Error_Msg_N
("malformed dependency relation", Deps
);
1997 -- The top level dependency relation is malformed. This is a syntax
1998 -- error, always report.
2001 Error_Msg_N
("malformed dependency relation", Deps
);
2005 -- Ensure that a state and a corresponding constituent do not appear
2006 -- together in pragma [Refined_]Depends.
2008 Check_State_And_Constituent_Use
2009 (States
=> States_Seen
,
2010 Constits
=> Constits_Seen
,
2014 Set_Is_Analyzed_Pragma
(N
);
2015 end Analyze_Depends_In_Decl_Part
;
2017 --------------------------------------------
2018 -- Analyze_External_Property_In_Decl_Part --
2019 --------------------------------------------
2021 procedure Analyze_External_Property_In_Decl_Part
2023 Expr_Val
: out Boolean)
2025 Arg1
: constant Node_Id
:=
2026 First
(Pragma_Argument_Associations
(N
));
2027 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2028 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2034 -- Do not analyze the pragma multiple times
2036 if Is_Analyzed_Pragma
(N
) then
2040 Error_Msg_Name_1
:= Pragma_Name
(N
);
2042 -- An external property pragma must apply to an effectively volatile
2043 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2044 -- The check is performed at the end of the declarative region due to a
2045 -- possible out-of-order arrangement of pragmas:
2048 -- pragma Async_Readers (Obj);
2049 -- pragma Volatile (Obj);
2051 if not Is_Effectively_Volatile
(Obj_Id
) then
2053 ("external property % must apply to a volatile object", N
);
2056 -- Ensure that the Boolean expression (if present) is static. A missing
2057 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2061 if Present
(Arg1
) then
2062 Expr
:= Get_Pragma_Arg
(Arg1
);
2064 if Is_OK_Static_Expression
(Expr
) then
2065 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2069 Set_Is_Analyzed_Pragma
(N
);
2070 end Analyze_External_Property_In_Decl_Part
;
2072 ---------------------------------
2073 -- Analyze_Global_In_Decl_Part --
2074 ---------------------------------
2076 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2077 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2078 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2079 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2081 Constits_Seen
: Elist_Id
:= No_Elist
;
2082 -- A list containing the entities of all constituents processed so far.
2083 -- It aids in detecting illegal usage of a state and a corresponding
2084 -- constituent in pragma [Refinde_]Global.
2086 Seen
: Elist_Id
:= No_Elist
;
2087 -- A list containing the entities of all the items processed so far. It
2088 -- plays a role in detecting distinct entities.
2090 States_Seen
: Elist_Id
:= No_Elist
;
2091 -- A list containing the entities of all states processed so far. It
2092 -- helps in detecting illegal usage of a state and a corresponding
2093 -- constituent in pragma [Refined_]Global.
2095 In_Out_Seen
: Boolean := False;
2096 Input_Seen
: Boolean := False;
2097 Output_Seen
: Boolean := False;
2098 Proof_Seen
: Boolean := False;
2099 -- Flags used to verify the consistency of modes
2101 procedure Analyze_Global_List
2103 Global_Mode
: Name_Id
:= Name_Input
);
2104 -- Verify the legality of a single global list declaration. Global_Mode
2105 -- denotes the current mode in effect.
2107 -------------------------
2108 -- Analyze_Global_List --
2109 -------------------------
2111 procedure Analyze_Global_List
2113 Global_Mode
: Name_Id
:= Name_Input
)
2115 procedure Analyze_Global_Item
2117 Global_Mode
: Name_Id
);
2118 -- Verify the legality of a single global item declaration denoted by
2119 -- Item. Global_Mode denotes the current mode in effect.
2121 procedure Check_Duplicate_Mode
2123 Status
: in out Boolean);
2124 -- Flag Status denotes whether a particular mode has been seen while
2125 -- processing a global list. This routine verifies that Mode is not a
2126 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2128 procedure Check_Mode_Restriction_In_Enclosing_Context
2130 Item_Id
: Entity_Id
);
2131 -- Verify that an item of mode In_Out or Output does not appear as
2132 -- an input in the Global aspect of an enclosing subprogram or task
2133 -- unit. If this is the case, emit an error. Item and Item_Id are
2134 -- respectively the item and its entity.
2136 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2137 -- Mode denotes either In_Out or Output. Depending on the kind of the
2138 -- related subprogram, emit an error if those two modes apply to a
2139 -- function (SPARK RM 6.1.4(10)).
2141 -------------------------
2142 -- Analyze_Global_Item --
2143 -------------------------
2145 procedure Analyze_Global_Item
2147 Global_Mode
: Name_Id
)
2149 Item_Id
: Entity_Id
;
2152 -- Detect one of the following cases
2154 -- with Global => (null, Name)
2155 -- with Global => (Name_1, null, Name_2)
2156 -- with Global => (Name, null)
2158 if Nkind
(Item
) = N_Null
then
2159 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2164 Resolve_State
(Item
);
2166 -- Find the entity of the item. If this is a renaming, climb the
2167 -- renaming chain to reach the root object. Renamings of non-
2168 -- entire objects do not yield an entity (Empty).
2170 Item_Id
:= Entity_Of
(Item
);
2172 if Present
(Item_Id
) then
2174 -- A global item may denote a formal parameter of an enclosing
2175 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2176 -- provide a better error diagnostic.
2178 if Is_Formal
(Item_Id
) then
2179 if Scope
(Item_Id
) = Spec_Id
then
2181 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2182 & "parameter of subprogram &"), Item
, Spec_Id
);
2186 -- A global item may denote a concurrent type as long as it is
2187 -- the current instance of an enclosing protected or task type
2188 -- (SPARK RM 6.1.4).
2190 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2191 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2193 -- Pragma [Refined_]Global associated with a protected
2194 -- subprogram cannot mention the current instance of a
2195 -- protected type because the instance behaves as a
2196 -- formal parameter.
2198 if Ekind
(Item_Id
) = E_Protected_Type
then
2199 if Scope
(Spec_Id
) = Item_Id
then
2200 Error_Msg_Name_1
:= Chars
(Item_Id
);
2202 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2203 & "cannot reference current instance of "
2204 & "protected type %"), Item
, Spec_Id
);
2208 -- Pragma [Refined_]Global associated with a task type
2209 -- cannot mention the current instance of a task type
2210 -- because the instance behaves as a formal parameter.
2212 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2213 if Spec_Id
= Item_Id
then
2214 Error_Msg_Name_1
:= Chars
(Item_Id
);
2216 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2217 & "cannot reference current instance of task "
2218 & "type %"), Item
, Spec_Id
);
2223 -- Otherwise the global item denotes a subtype mark that is
2224 -- not a current instance.
2228 ("invalid use of subtype mark in global list", Item
);
2232 -- A global item may denote the anonymous object created for a
2233 -- single protected/task type as long as the current instance
2234 -- is the same single type (SPARK RM 6.1.4).
2236 elsif Is_Single_Concurrent_Object
(Item_Id
)
2237 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2239 -- Pragma [Refined_]Global associated with a protected
2240 -- subprogram cannot mention the current instance of a
2241 -- protected type because the instance behaves as a formal
2244 if Is_Single_Protected_Object
(Item_Id
) then
2245 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2246 Error_Msg_Name_1
:= Chars
(Item_Id
);
2248 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2249 & "cannot reference current instance of protected "
2250 & "type %"), Item
, Spec_Id
);
2254 -- Pragma [Refined_]Global associated with a task type
2255 -- cannot mention the current instance of a task type
2256 -- because the instance behaves as a formal parameter.
2258 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2259 if Spec_Id
= Item_Id
then
2260 Error_Msg_Name_1
:= Chars
(Item_Id
);
2262 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2263 & "cannot reference current instance of task "
2264 & "type %"), Item
, Spec_Id
);
2269 -- A formal object may act as a global item inside a generic
2271 elsif Is_Formal_Object
(Item_Id
) then
2274 -- The only legal references are those to abstract states,
2275 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2277 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2283 ("global item must denote object, state or current "
2284 & "instance of concurrent type", Item
);
2286 if Ekind
(Item_Id
) in Named_Kind
then
2288 ("\named number & is not an object", Item
, Item
);
2294 -- State related checks
2296 if Ekind
(Item_Id
) = E_Abstract_State
then
2298 -- Package and subprogram bodies are instantiated
2299 -- individually in a separate compiler pass. Due to this
2300 -- mode of instantiation, the refinement of a state may
2301 -- no longer be visible when a subprogram body contract
2302 -- is instantiated. Since the generic template is legal,
2303 -- do not perform this check in the instance to circumvent
2306 if Is_Generic_Instance
(Spec_Id
) then
2309 -- An abstract state with visible refinement cannot appear
2310 -- in pragma [Refined_]Global as its place must be taken by
2311 -- some of its constituents (SPARK RM 6.1.4(7)).
2313 elsif Has_Visible_Refinement
(Item_Id
) then
2315 ("cannot mention state & in global refinement",
2317 SPARK_Msg_N
("\use its constituents instead", Item
);
2320 -- An external state cannot appear as a global item of a
2321 -- nonvolatile function (SPARK RM 7.1.3(8)).
2323 elsif Is_External_State
(Item_Id
)
2324 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2325 and then not Is_Volatile_Function
(Spec_Id
)
2328 ("external state & cannot act as global item of "
2329 & "nonvolatile function", Item
, Item_Id
);
2332 -- If the reference to the abstract state appears in an
2333 -- enclosing package body that will eventually refine the
2334 -- state, record the reference for future checks.
2337 Record_Possible_Body_Reference
2338 (State_Id
=> Item_Id
,
2342 -- Constant related checks
2344 elsif Ekind
(Item_Id
) = E_Constant
then
2346 -- A constant is a read-only item, therefore it cannot act
2349 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2351 ("constant & cannot act as output", Item
, Item_Id
);
2355 -- Loop parameter related checks
2357 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2359 -- A loop parameter is a read-only item, therefore it cannot
2360 -- act as an output.
2362 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2364 ("loop parameter & cannot act as output",
2369 -- Variable related checks. These are only relevant when
2370 -- SPARK_Mode is on as they are not standard Ada legality
2373 elsif SPARK_Mode
= On
2374 and then Ekind
(Item_Id
) = E_Variable
2375 and then Is_Effectively_Volatile
(Item_Id
)
2377 -- An effectively volatile object cannot appear as a global
2378 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2380 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2381 and then not Is_Volatile_Function
(Spec_Id
)
2384 ("volatile object & cannot act as global item of a "
2385 & "function", Item
, Item_Id
);
2388 -- An effectively volatile object with external property
2389 -- Effective_Reads set to True must have mode Output or
2390 -- In_Out (SPARK RM 7.1.3(10)).
2392 elsif Effective_Reads_Enabled
(Item_Id
)
2393 and then Global_Mode
= Name_Input
2396 ("volatile object & with property Effective_Reads must "
2397 & "have mode In_Out or Output", Item
, Item_Id
);
2402 -- When the item renames an entire object, replace the item
2403 -- with a reference to the object.
2405 if Entity
(Item
) /= Item_Id
then
2406 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2410 -- Some form of illegal construct masquerading as a name
2411 -- (SPARK RM 6.1.4(4)).
2415 ("global item must denote object, state or current instance "
2416 & "of concurrent type", Item
);
2420 -- Verify that an output does not appear as an input in an
2421 -- enclosing subprogram.
2423 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2424 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2427 -- The same entity might be referenced through various way.
2428 -- Check the entity of the item rather than the item itself
2429 -- (SPARK RM 6.1.4(10)).
2431 if Contains
(Seen
, Item_Id
) then
2432 SPARK_Msg_N
("duplicate global item", Item
);
2434 -- Add the entity of the current item to the list of processed
2438 Append_New_Elmt
(Item_Id
, Seen
);
2440 if Ekind
(Item_Id
) = E_Abstract_State
then
2441 Append_New_Elmt
(Item_Id
, States_Seen
);
2443 -- The variable may eventually become a constituent of a single
2444 -- protected/task type. Record the reference now and verify its
2445 -- legality when analyzing the contract of the variable
2448 elsif Ekind
(Item_Id
) = E_Variable
then
2449 Record_Possible_Part_Of_Reference
2454 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2455 and then Present
(Encapsulating_State
(Item_Id
))
2457 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2460 end Analyze_Global_Item
;
2462 --------------------------
2463 -- Check_Duplicate_Mode --
2464 --------------------------
2466 procedure Check_Duplicate_Mode
2468 Status
: in out Boolean)
2472 SPARK_Msg_N
("duplicate global mode", Mode
);
2476 end Check_Duplicate_Mode
;
2478 -------------------------------------------------
2479 -- Check_Mode_Restriction_In_Enclosing_Context --
2480 -------------------------------------------------
2482 procedure Check_Mode_Restriction_In_Enclosing_Context
2484 Item_Id
: Entity_Id
)
2486 Context
: Entity_Id
;
2488 Inputs
: Elist_Id
:= No_Elist
;
2489 Outputs
: Elist_Id
:= No_Elist
;
2492 -- Traverse the scope stack looking for enclosing subprograms or
2493 -- tasks subject to pragma [Refined_]Global.
2495 Context
:= Scope
(Subp_Id
);
2496 while Present
(Context
) and then Context
/= Standard_Standard
loop
2498 -- For a single task type, retrieve the corresponding object to
2499 -- which pragma [Refined_]Global is attached.
2501 if Ekind
(Context
) = E_Task_Type
2502 and then Is_Single_Concurrent_Type
(Context
)
2504 Context
:= Anonymous_Object
(Context
);
2507 if (Is_Subprogram
(Context
)
2508 or else Ekind
(Context
) = E_Task_Type
2509 or else Is_Single_Task_Object
(Context
))
2511 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2513 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2515 Collect_Subprogram_Inputs_Outputs
2516 (Subp_Id
=> Context
,
2517 Subp_Inputs
=> Inputs
,
2518 Subp_Outputs
=> Outputs
,
2519 Global_Seen
=> Dummy
);
2521 -- The item is classified as In_Out or Output but appears as
2522 -- an Input in an enclosing subprogram or task unit (SPARK
2525 if Appears_In
(Inputs
, Item_Id
)
2526 and then not Appears_In
(Outputs
, Item_Id
)
2529 ("global item & cannot have mode In_Out or Output",
2532 if Is_Subprogram
(Context
) then
2534 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2535 & "of subprogram &"), Item
, Context
);
2538 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2539 & "of task &"), Item
, Context
);
2542 -- Stop the traversal once an error has been detected
2548 Context
:= Scope
(Context
);
2550 end Check_Mode_Restriction_In_Enclosing_Context
;
2552 ----------------------------------------
2553 -- Check_Mode_Restriction_In_Function --
2554 ----------------------------------------
2556 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2558 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2560 ("global mode & is not applicable to functions", Mode
);
2562 end Check_Mode_Restriction_In_Function
;
2570 -- Start of processing for Analyze_Global_List
2573 if Nkind
(List
) = N_Null
then
2574 Set_Analyzed
(List
);
2576 -- Single global item declaration
2578 elsif Nkind_In
(List
, N_Expanded_Name
,
2580 N_Selected_Component
)
2582 Analyze_Global_Item
(List
, Global_Mode
);
2584 -- Simple global list or moded global list declaration
2586 elsif Nkind
(List
) = N_Aggregate
then
2587 Set_Analyzed
(List
);
2589 -- The declaration of a simple global list appear as a collection
2592 if Present
(Expressions
(List
)) then
2593 if Present
(Component_Associations
(List
)) then
2595 ("cannot mix moded and non-moded global lists", List
);
2598 Item
:= First
(Expressions
(List
));
2599 while Present
(Item
) loop
2600 Analyze_Global_Item
(Item
, Global_Mode
);
2604 -- The declaration of a moded global list appears as a collection
2605 -- of component associations where individual choices denote
2608 elsif Present
(Component_Associations
(List
)) then
2609 if Present
(Expressions
(List
)) then
2611 ("cannot mix moded and non-moded global lists", List
);
2614 Assoc
:= First
(Component_Associations
(List
));
2615 while Present
(Assoc
) loop
2616 Mode
:= First
(Choices
(Assoc
));
2618 if Nkind
(Mode
) = N_Identifier
then
2619 if Chars
(Mode
) = Name_In_Out
then
2620 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2621 Check_Mode_Restriction_In_Function
(Mode
);
2623 elsif Chars
(Mode
) = Name_Input
then
2624 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2626 elsif Chars
(Mode
) = Name_Output
then
2627 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2628 Check_Mode_Restriction_In_Function
(Mode
);
2630 elsif Chars
(Mode
) = Name_Proof_In
then
2631 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2634 SPARK_Msg_N
("invalid mode selector", Mode
);
2638 SPARK_Msg_N
("invalid mode selector", Mode
);
2641 -- Items in a moded list appear as a collection of
2642 -- expressions. Reuse the existing machinery to analyze
2646 (List
=> Expression
(Assoc
),
2647 Global_Mode
=> Chars
(Mode
));
2655 raise Program_Error
;
2658 -- Any other attempt to declare a global item is illegal. This is a
2659 -- syntax error, always report.
2662 Error_Msg_N
("malformed global list", List
);
2664 end Analyze_Global_List
;
2668 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2670 Restore_Scope
: Boolean := False;
2672 -- Start of processing for Analyze_Global_In_Decl_Part
2675 -- Do not analyze the pragma multiple times
2677 if Is_Analyzed_Pragma
(N
) then
2681 -- There is nothing to be done for a null global list
2683 if Nkind
(Items
) = N_Null
then
2684 Set_Analyzed
(Items
);
2686 -- Analyze the various forms of global lists and items. Note that some
2687 -- of these may be malformed in which case the analysis emits error
2691 -- When pragma [Refined_]Global appears on a single concurrent type,
2692 -- it is relocated to the anonymous object.
2694 if Is_Single_Concurrent_Object
(Spec_Id
) then
2697 -- Ensure that the formal parameters are visible when processing an
2698 -- item. This falls out of the general rule of aspects pertaining to
2699 -- subprogram declarations.
2701 elsif not In_Open_Scopes
(Spec_Id
) then
2702 Restore_Scope
:= True;
2703 Push_Scope
(Spec_Id
);
2705 if Ekind
(Spec_Id
) = E_Task_Type
then
2706 if Has_Discriminants
(Spec_Id
) then
2707 Install_Discriminants
(Spec_Id
);
2710 elsif Is_Generic_Subprogram
(Spec_Id
) then
2711 Install_Generic_Formals
(Spec_Id
);
2714 Install_Formals
(Spec_Id
);
2718 Analyze_Global_List
(Items
);
2720 if Restore_Scope
then
2725 -- Ensure that a state and a corresponding constituent do not appear
2726 -- together in pragma [Refined_]Global.
2728 Check_State_And_Constituent_Use
2729 (States
=> States_Seen
,
2730 Constits
=> Constits_Seen
,
2733 Set_Is_Analyzed_Pragma
(N
);
2734 end Analyze_Global_In_Decl_Part
;
2736 --------------------------------------------
2737 -- Analyze_Initial_Condition_In_Decl_Part --
2738 --------------------------------------------
2740 -- WARNING: This routine manages Ghost regions. Return statements must be
2741 -- replaced by gotos which jump to the end of the routine and restore the
2744 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2745 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2746 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2747 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2749 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2750 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2751 -- Save the Ghost-related attributes to restore on exit
2754 -- Do not analyze the pragma multiple times
2756 if Is_Analyzed_Pragma
(N
) then
2760 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2761 -- analysis of the pragma, the Ghost mode at point of declaration and
2762 -- point of analysis may not necessarily be the same. Use the mode in
2763 -- effect at the point of declaration.
2767 -- The expression is preanalyzed because it has not been moved to its
2768 -- final place yet. A direct analysis may generate side effects and this
2769 -- is not desired at this point.
2771 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2772 Set_Is_Analyzed_Pragma
(N
);
2774 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2775 end Analyze_Initial_Condition_In_Decl_Part
;
2777 --------------------------------------
2778 -- Analyze_Initializes_In_Decl_Part --
2779 --------------------------------------
2781 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2782 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2783 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2785 Constits_Seen
: Elist_Id
:= No_Elist
;
2786 -- A list containing the entities of all constituents processed so far.
2787 -- It aids in detecting illegal usage of a state and a corresponding
2788 -- constituent in pragma Initializes.
2790 Items_Seen
: Elist_Id
:= No_Elist
;
2791 -- A list of all initialization items processed so far. This list is
2792 -- used to detect duplicate items.
2794 States_And_Objs
: Elist_Id
:= No_Elist
;
2795 -- A list of all abstract states and objects declared in the visible
2796 -- declarations of the related package. This list is used to detect the
2797 -- legality of initialization items.
2799 States_Seen
: Elist_Id
:= No_Elist
;
2800 -- A list containing the entities of all states processed so far. It
2801 -- helps in detecting illegal usage of a state and a corresponding
2802 -- constituent in pragma Initializes.
2804 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2805 -- Verify the legality of a single initialization item
2807 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2808 -- Verify the legality of a single initialization item followed by a
2809 -- list of input items.
2811 procedure Collect_States_And_Objects
;
2812 -- Inspect the visible declarations of the related package and gather
2813 -- the entities of all abstract states and objects in States_And_Objs.
2815 ---------------------------------
2816 -- Analyze_Initialization_Item --
2817 ---------------------------------
2819 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2820 Item_Id
: Entity_Id
;
2824 Resolve_State
(Item
);
2826 if Is_Entity_Name
(Item
) then
2827 Item_Id
:= Entity_Of
(Item
);
2829 if Present
(Item_Id
)
2830 and then Ekind_In
(Item_Id
, E_Abstract_State
,
2834 -- When the initialization item is undefined, it appears as
2835 -- Any_Id. Do not continue with the analysis of the item.
2837 if Item_Id
= Any_Id
then
2840 -- The state or variable must be declared in the visible
2841 -- declarations of the package (SPARK RM 7.1.5(7)).
2843 elsif not Contains
(States_And_Objs
, Item_Id
) then
2844 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2846 ("initialization item & must appear in the visible "
2847 & "declarations of package %", Item
, Item_Id
);
2849 -- Detect a duplicate use of the same initialization item
2850 -- (SPARK RM 7.1.5(5)).
2852 elsif Contains
(Items_Seen
, Item_Id
) then
2853 SPARK_Msg_N
("duplicate initialization item", Item
);
2855 -- The item is legal, add it to the list of processed states
2859 Append_New_Elmt
(Item_Id
, Items_Seen
);
2861 if Ekind
(Item_Id
) = E_Abstract_State
then
2862 Append_New_Elmt
(Item_Id
, States_Seen
);
2865 if Present
(Encapsulating_State
(Item_Id
)) then
2866 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2870 -- The item references something that is not a state or object
2871 -- (SPARK RM 7.1.5(3)).
2875 ("initialization item must denote object or state", Item
);
2878 -- Some form of illegal construct masquerading as a name
2879 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2883 ("initialization item must denote object or state", Item
);
2885 end Analyze_Initialization_Item
;
2887 ---------------------------------------------
2888 -- Analyze_Initialization_Item_With_Inputs --
2889 ---------------------------------------------
2891 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2892 Inputs_Seen
: Elist_Id
:= No_Elist
;
2893 -- A list of all inputs processed so far. This list is used to detect
2894 -- duplicate uses of an input.
2896 Non_Null_Seen
: Boolean := False;
2897 Null_Seen
: Boolean := False;
2898 -- Flags used to check the legality of an input list
2900 procedure Analyze_Input_Item
(Input
: Node_Id
);
2901 -- Verify the legality of a single input item
2903 ------------------------
2904 -- Analyze_Input_Item --
2905 ------------------------
2907 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2908 Input_Id
: Entity_Id
;
2913 if Nkind
(Input
) = N_Null
then
2916 ("multiple null initializations not allowed", Item
);
2918 elsif Non_Null_Seen
then
2920 ("cannot mix null and non-null initialization item", Item
);
2928 Non_Null_Seen
:= True;
2932 ("cannot mix null and non-null initialization item", Item
);
2936 Resolve_State
(Input
);
2938 if Is_Entity_Name
(Input
) then
2939 Input_Id
:= Entity_Of
(Input
);
2941 if Present
(Input_Id
)
2942 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2944 E_Generic_In_Out_Parameter
,
2945 E_Generic_In_Parameter
,
2953 -- The input cannot denote states or objects declared
2954 -- within the related package (SPARK RM 7.1.5(4)).
2956 if Within_Scope
(Input_Id
, Current_Scope
) then
2958 -- Do not consider generic formal parameters or their
2959 -- respective mappings to generic formals. Even though
2960 -- the formals appear within the scope of the package,
2961 -- it is allowed for an initialization item to depend
2962 -- on an input item.
2964 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2965 E_Generic_In_Parameter
)
2969 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2970 and then Present
(Corresponding_Generic_Association
2971 (Declaration_Node
(Input_Id
)))
2976 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2978 ("input item & cannot denote a visible object or "
2979 & "state of package %", Input
, Input_Id
);
2984 -- Detect a duplicate use of the same input item
2985 -- (SPARK RM 7.1.5(5)).
2987 if Contains
(Inputs_Seen
, Input_Id
) then
2988 SPARK_Msg_N
("duplicate input item", Input
);
2992 -- At this point it is known that the input is legal. Add
2993 -- it to the list of processed inputs.
2995 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2997 if Ekind
(Input_Id
) = E_Abstract_State
then
2998 Append_New_Elmt
(Input_Id
, States_Seen
);
3001 if Ekind_In
(Input_Id
, E_Abstract_State
,
3004 and then Present
(Encapsulating_State
(Input_Id
))
3006 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3009 -- The input references something that is not a state or an
3010 -- object (SPARK RM 7.1.5(3)).
3014 ("input item must denote object or state", Input
);
3017 -- Some form of illegal construct masquerading as a name
3018 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3022 ("input item must denote object or state", Input
);
3025 end Analyze_Input_Item
;
3029 Inputs
: constant Node_Id
:= Expression
(Item
);
3033 Name_Seen
: Boolean := False;
3034 -- A flag used to detect multiple item names
3036 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3039 -- Inspect the name of an item with inputs
3041 Elmt
:= First
(Choices
(Item
));
3042 while Present
(Elmt
) loop
3044 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3047 Analyze_Initialization_Item
(Elmt
);
3053 -- Multiple input items appear as an aggregate
3055 if Nkind
(Inputs
) = N_Aggregate
then
3056 if Present
(Expressions
(Inputs
)) then
3057 Input
:= First
(Expressions
(Inputs
));
3058 while Present
(Input
) loop
3059 Analyze_Input_Item
(Input
);
3064 if Present
(Component_Associations
(Inputs
)) then
3066 ("inputs must appear in named association form", Inputs
);
3069 -- Single input item
3072 Analyze_Input_Item
(Inputs
);
3074 end Analyze_Initialization_Item_With_Inputs
;
3076 --------------------------------
3077 -- Collect_States_And_Objects --
3078 --------------------------------
3080 procedure Collect_States_And_Objects
is
3081 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3085 -- Collect the abstract states defined in the package (if any)
3087 if Present
(Abstract_States
(Pack_Id
)) then
3088 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3091 -- Collect all objects that appear in the visible declarations of the
3094 if Present
(Visible_Declarations
(Pack_Spec
)) then
3095 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3096 while Present
(Decl
) loop
3097 if Comes_From_Source
(Decl
)
3098 and then Nkind_In
(Decl
, N_Object_Declaration
,
3099 N_Object_Renaming_Declaration
)
3101 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3103 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3105 (Anonymous_Object
(Defining_Entity
(Decl
)),
3112 end Collect_States_And_Objects
;
3116 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3119 -- Start of processing for Analyze_Initializes_In_Decl_Part
3122 -- Do not analyze the pragma multiple times
3124 if Is_Analyzed_Pragma
(N
) then
3128 -- Nothing to do when the initialization list is empty
3130 if Nkind
(Inits
) = N_Null
then
3134 -- Single and multiple initialization clauses appear as an aggregate. If
3135 -- this is not the case, then either the parser or the analysis of the
3136 -- pragma failed to produce an aggregate.
3138 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3140 -- Initialize the various lists used during analysis
3142 Collect_States_And_Objects
;
3144 if Present
(Expressions
(Inits
)) then
3145 Init
:= First
(Expressions
(Inits
));
3146 while Present
(Init
) loop
3147 Analyze_Initialization_Item
(Init
);
3152 if Present
(Component_Associations
(Inits
)) then
3153 Init
:= First
(Component_Associations
(Inits
));
3154 while Present
(Init
) loop
3155 Analyze_Initialization_Item_With_Inputs
(Init
);
3160 -- Ensure that a state and a corresponding constituent do not appear
3161 -- together in pragma Initializes.
3163 Check_State_And_Constituent_Use
3164 (States
=> States_Seen
,
3165 Constits
=> Constits_Seen
,
3168 Set_Is_Analyzed_Pragma
(N
);
3169 end Analyze_Initializes_In_Decl_Part
;
3171 ---------------------
3172 -- Analyze_Part_Of --
3173 ---------------------
3175 procedure Analyze_Part_Of
3177 Item_Id
: Entity_Id
;
3179 Encap_Id
: out Entity_Id
;
3180 Legal
: out Boolean)
3182 procedure Check_Part_Of_Abstract_State
;
3183 pragma Inline
(Check_Part_Of_Abstract_State
);
3184 -- Verify the legality of indicator Part_Of when the encapsulator is an
3187 procedure Check_Part_Of_Concurrent_Type
;
3188 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3189 -- Verify the legality of indicator Part_Of when the encapsulator is a
3190 -- single concurrent type.
3192 ----------------------------------
3193 -- Check_Part_Of_Abstract_State --
3194 ----------------------------------
3196 procedure Check_Part_Of_Abstract_State
is
3197 Pack_Id
: Entity_Id
;
3198 Placement
: State_Space_Kind
;
3199 Parent_Unit
: Entity_Id
;
3202 -- Determine where the object, package instantiation or state lives
3203 -- with respect to the enclosing packages or package bodies.
3205 Find_Placement_In_State_Space
3206 (Item_Id
=> Item_Id
,
3207 Placement
=> Placement
,
3208 Pack_Id
=> Pack_Id
);
3210 -- The item appears in a non-package construct with a declarative
3211 -- part (subprogram, block, etc). As such, the item is not allowed
3212 -- to be a part of an encapsulating state because the item is not
3215 if Placement
= Not_In_Package
then
3217 ("indicator Part_Of cannot appear in this context "
3218 & "(SPARK RM 7.2.6(5))", Indic
);
3220 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3222 ("\& is not part of the hidden state of package %",
3226 -- The item appears in the visible state space of some package. In
3227 -- general this scenario does not warrant Part_Of except when the
3228 -- package is a nongeneric private child unit and the encapsulating
3229 -- state is declared in a parent unit or a public descendant of that
3232 elsif Placement
= Visible_State_Space
then
3233 if Is_Child_Unit
(Pack_Id
)
3234 and then not Is_Generic_Unit
(Pack_Id
)
3235 and then Is_Private_Descendant
(Pack_Id
)
3237 -- A variable or state abstraction which is part of the visible
3238 -- state of a nongeneric private child unit or its public
3239 -- descendants must have its Part_Of indicator specified. The
3240 -- Part_Of indicator must denote a state declared by either the
3241 -- parent unit of the private unit or by a public descendant of
3242 -- that parent unit.
3244 -- Find the nearest private ancestor (which can be the current
3247 Parent_Unit
:= Pack_Id
;
3248 while Present
(Parent_Unit
) loop
3251 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3252 Parent_Unit
:= Scope
(Parent_Unit
);
3255 Parent_Unit
:= Scope
(Parent_Unit
);
3257 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3259 ("indicator Part_Of must denote abstract state of & or of "
3260 & "its public descendant (SPARK RM 7.2.6(3))",
3261 Indic
, Parent_Unit
);
3264 elsif Scope
(Encap_Id
) = Parent_Unit
3266 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3267 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3273 ("indicator Part_Of must denote abstract state of & or of "
3274 & "its public descendant (SPARK RM 7.2.6(3))",
3275 Indic
, Parent_Unit
);
3279 -- Indicator Part_Of is not needed when the related package is
3280 -- not a nongeneric private child unit or a public descendant
3285 ("indicator Part_Of cannot appear in this context "
3286 & "(SPARK RM 7.2.6(5))", Indic
);
3288 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3290 ("\& is declared in the visible part of package %",
3295 -- When the item appears in the private state space of a package, the
3296 -- encapsulating state must be declared in the same package.
3298 elsif Placement
= Private_State_Space
then
3299 if Scope
(Encap_Id
) /= Pack_Id
then
3301 ("indicator Part_Of must denote an abstract state of "
3302 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3304 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3306 ("\& is declared in the private part of package %",
3311 -- Items declared in the body state space of a package do not need
3312 -- Part_Of indicators as the refinement has already been seen.
3316 ("indicator Part_Of cannot appear in this context "
3317 & "(SPARK RM 7.2.6(5))", Indic
);
3319 if Scope
(Encap_Id
) = Pack_Id
then
3320 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3322 ("\& is declared in the body of package %", Indic
, Item_Id
);
3328 -- At this point it is known that the Part_Of indicator is legal
3331 end Check_Part_Of_Abstract_State
;
3333 -----------------------------------
3334 -- Check_Part_Of_Concurrent_Type --
3335 -----------------------------------
3337 procedure Check_Part_Of_Concurrent_Type
is
3338 function In_Proper_Order
3340 Second
: Node_Id
) return Boolean;
3341 pragma Inline
(In_Proper_Order
);
3342 -- Determine whether node First precedes node Second
3344 procedure Placement_Error
;
3345 pragma Inline
(Placement_Error
);
3346 -- Emit an error concerning the illegal placement of the item with
3347 -- respect to the single concurrent type.
3349 ---------------------
3350 -- In_Proper_Order --
3351 ---------------------
3353 function In_Proper_Order
3355 Second
: Node_Id
) return Boolean
3360 if List_Containing
(First
) = List_Containing
(Second
) then
3362 while Present
(N
) loop
3372 end In_Proper_Order
;
3374 ---------------------
3375 -- Placement_Error --
3376 ---------------------
3378 procedure Placement_Error
is
3381 ("indicator Part_Of must denote a previously declared single "
3382 & "protected type or single task type", Encap
);
3383 end Placement_Error
;
3387 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
3388 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
3389 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
3391 Item_Context
: Node_Id
;
3392 Item_Decl
: Node_Id
;
3393 Prv_Decls
: List_Id
;
3394 Vis_Decls
: List_Id
;
3396 -- Start of processing for Check_Part_Of_Concurrent_Type
3399 -- Only abstract states and variables can act as constituents of an
3400 -- encapsulating single concurrent type.
3402 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3405 -- The constituent is a constant
3407 elsif Ekind
(Item_Id
) = E_Constant
then
3408 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3410 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
3411 & "single protected type %"), Indic
, Item_Id
);
3414 -- The constituent is a package instantiation
3417 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3419 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
3420 & "constituent of single protected type %"), Indic
, Item_Id
);
3424 -- When the item denotes an abstract state of a nested package, use
3425 -- the declaration of the package to detect proper placement.
3430 -- with Abstract_State => (State with Part_Of => T)
3432 if Ekind
(Item_Id
) = E_Abstract_State
then
3433 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3435 Item_Decl
:= Declaration_Node
(Item_Id
);
3438 Item_Context
:= Parent
(Item_Decl
);
3440 -- The item and the single concurrent type must appear in the same
3441 -- declarative region, with the item following the declaration of
3442 -- the single concurrent type (SPARK RM 9(3)).
3444 if Item_Context
= Encap_Context
then
3445 if Nkind_In
(Item_Context
, N_Package_Specification
,
3446 N_Protected_Definition
,
3449 Prv_Decls
:= Private_Declarations
(Item_Context
);
3450 Vis_Decls
:= Visible_Declarations
(Item_Context
);
3452 -- The placement is OK when the single concurrent type appears
3453 -- within the visible declarations and the item in the private
3459 -- Constit : ... with Part_Of => PO;
3462 if List_Containing
(Encap_Decl
) = Vis_Decls
3463 and then List_Containing
(Item_Decl
) = Prv_Decls
3467 -- The placement is illegal when the item appears within the
3468 -- visible declarations and the single concurrent type is in
3469 -- the private declarations.
3472 -- Constit : ... with Part_Of => PO;
3477 elsif List_Containing
(Item_Decl
) = Vis_Decls
3478 and then List_Containing
(Encap_Decl
) = Prv_Decls
3483 -- Otherwise both the item and the single concurrent type are
3484 -- in the same list. Ensure that the declaration of the single
3485 -- concurrent type precedes that of the item.
3487 elsif not In_Proper_Order
3488 (First
=> Encap_Decl
,
3489 Second
=> Item_Decl
)
3495 -- Otherwise both the item and the single concurrent type are
3496 -- in the same list. Ensure that the declaration of the single
3497 -- concurrent type precedes that of the item.
3499 elsif not In_Proper_Order
3500 (First
=> Encap_Decl
,
3501 Second
=> Item_Decl
)
3507 -- Otherwise the item and the single concurrent type reside within
3508 -- unrelated regions.
3511 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3513 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
3514 & "immediately within the same region as single protected "
3515 & "type %"), Indic
, Item_Id
);
3519 -- At this point it is known that the Part_Of indicator is legal
3522 end Check_Part_Of_Concurrent_Type
;
3524 -- Start of processing for Analyze_Part_Of
3527 -- Assume that the indicator is illegal
3532 if Nkind_In
(Encap
, N_Expanded_Name
,
3534 N_Selected_Component
)
3537 Resolve_State
(Encap
);
3539 Encap_Id
:= Entity
(Encap
);
3541 -- The encapsulator is an abstract state
3543 if Ekind
(Encap_Id
) = E_Abstract_State
then
3546 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3548 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3551 -- Otherwise the encapsulator is not a legal choice
3555 ("indicator Part_Of must denote abstract state, single "
3556 & "protected type or single task type", Encap
);
3560 -- This is a syntax error, always report
3564 ("indicator Part_Of must denote abstract state, single protected "
3565 & "type or single task type", Encap
);
3569 -- Catch a case where indicator Part_Of denotes the abstract view of a
3570 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3572 if From_Limited_With
(Encap_Id
)
3573 and then Present
(Non_Limited_View
(Encap_Id
))
3574 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3576 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3577 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3581 -- The encapsulator is an abstract state
3583 if Ekind
(Encap_Id
) = E_Abstract_State
then
3584 Check_Part_Of_Abstract_State
;
3586 -- The encapsulator is a single concurrent type
3589 Check_Part_Of_Concurrent_Type
;
3591 end Analyze_Part_Of
;
3593 ----------------------------------
3594 -- Analyze_Part_Of_In_Decl_Part --
3595 ----------------------------------
3597 procedure Analyze_Part_Of_In_Decl_Part
3599 Freeze_Id
: Entity_Id
:= Empty
)
3601 Encap
: constant Node_Id
:=
3602 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3603 Errors
: constant Nat
:= Serious_Errors_Detected
;
3604 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3605 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3606 Constits
: Elist_Id
;
3607 Encap_Id
: Entity_Id
;
3611 -- Detect any discrepancies between the placement of the variable with
3612 -- respect to general state space and the encapsulating state or single
3619 Encap_Id
=> Encap_Id
,
3622 -- The Part_Of indicator turns the variable into a constituent of the
3623 -- encapsulating state or single concurrent type.
3626 pragma Assert
(Present
(Encap_Id
));
3627 Constits
:= Part_Of_Constituents
(Encap_Id
);
3629 if No
(Constits
) then
3630 Constits
:= New_Elmt_List
;
3631 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3634 Append_Elmt
(Var_Id
, Constits
);
3635 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3637 -- A Part_Of constituent partially refines an abstract state. This
3638 -- property does not apply to protected or task units.
3640 if Ekind
(Encap_Id
) = E_Abstract_State
then
3641 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3645 -- Emit a clarification message when the encapsulator is undefined,
3646 -- possibly due to contract freezing.
3648 if Errors
/= Serious_Errors_Detected
3649 and then Present
(Freeze_Id
)
3650 and then Has_Undefined_Reference
(Encap
)
3652 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3654 end Analyze_Part_Of_In_Decl_Part
;
3656 --------------------
3657 -- Analyze_Pragma --
3658 --------------------
3660 procedure Analyze_Pragma
(N
: Node_Id
) is
3661 Loc
: constant Source_Ptr
:= Sloc
(N
);
3663 Pname
: Name_Id
:= Pragma_Name
(N
);
3664 -- Name of the source pragma, or name of the corresponding aspect for
3665 -- pragmas which originate in a source aspect. In the latter case, the
3666 -- name may be different from the pragma name.
3668 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3670 Pragma_Exit
: exception;
3671 -- This exception is used to exit pragma processing completely. It
3672 -- is used when an error is detected, and no further processing is
3673 -- required. It is also used if an earlier error has left the tree in
3674 -- a state where the pragma should not be processed.
3677 -- Number of pragma argument associations
3683 -- First four pragma arguments (pragma argument association nodes, or
3684 -- Empty if the corresponding argument does not exist).
3686 type Name_List
is array (Natural range <>) of Name_Id
;
3687 type Args_List
is array (Natural range <>) of Node_Id
;
3688 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3690 -----------------------
3691 -- Local Subprograms --
3692 -----------------------
3694 function Acc_First
(N
: Node_Id
) return Node_Id
;
3695 -- Helper function to iterate over arguments given to OpenAcc pragmas
3697 function Acc_Next
(N
: Node_Id
) return Node_Id
;
3698 -- Helper function to iterate over arguments given to OpenAcc pragmas
3700 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3701 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3702 -- get the given string argument, and place it in Name_Buffer, adding
3703 -- leading and trailing asterisks if they are not already present. The
3704 -- caller has already checked that Arg is a static string expression.
3706 procedure Ada_2005_Pragma
;
3707 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3708 -- Ada 95 mode, these are implementation defined pragmas, so should be
3709 -- caught by the No_Implementation_Pragmas restriction.
3711 procedure Ada_2012_Pragma
;
3712 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3713 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3714 -- should be caught by the No_Implementation_Pragmas restriction.
3716 procedure Analyze_Depends_Global
3717 (Spec_Id
: out Entity_Id
;
3718 Subp_Decl
: out Node_Id
;
3719 Legal
: out Boolean);
3720 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3721 -- legality of the placement and related context of the pragma. Spec_Id
3722 -- is the entity of the related subprogram. Subp_Decl is the declaration
3723 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3725 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3726 -- Inspect the remainder of the list containing pragma N and look for
3727 -- a pragma that matches Id. If found, analyze the pragma.
3729 procedure Analyze_Pre_Post_Condition
;
3730 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3732 procedure Analyze_Refined_Depends_Global_Post
3733 (Spec_Id
: out Entity_Id
;
3734 Body_Id
: out Entity_Id
;
3735 Legal
: out Boolean);
3736 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3737 -- Refined_Global and Refined_Post. Verify the legality of the placement
3738 -- and related context of the pragma. Spec_Id is the entity of the
3739 -- related subprogram. Body_Id is the entity of the subprogram body.
3740 -- Flag Legal is set when the pragma is legal.
3742 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3743 -- Perform full analysis of pragma Unmodified and the write aspect of
3744 -- pragma Unused. Flag Is_Unused should be set when verifying the
3745 -- semantics of pragma Unused.
3747 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3748 -- Perform full analysis of pragma Unreferenced and the read aspect of
3749 -- pragma Unused. Flag Is_Unused should be set when verifying the
3750 -- semantics of pragma Unused.
3752 procedure Check_Ada_83_Warning
;
3753 -- Issues a warning message for the current pragma if operating in Ada
3754 -- 83 mode (used for language pragmas that are not a standard part of
3755 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3758 procedure Check_Arg_Count
(Required
: Nat
);
3759 -- Check argument count for pragma is equal to given parameter. If not,
3760 -- then issue an error message and raise Pragma_Exit.
3762 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3763 -- Arg which can either be a pragma argument association, in which case
3764 -- the check is applied to the expression of the association or an
3765 -- expression directly.
3767 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3768 -- Check that an argument has the right form for an EXTERNAL_NAME
3769 -- parameter of an extended import/export pragma. The rule is that the
3770 -- name must be an identifier or string literal (in Ada 83 mode) or a
3771 -- static string expression (in Ada 95 mode).
3773 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3774 -- Check the specified argument Arg to make sure that it is an
3775 -- identifier. If not give error and raise Pragma_Exit.
3777 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3778 -- Check the specified argument Arg to make sure that it is an integer
3779 -- literal. If not give error and raise Pragma_Exit.
3781 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3782 -- Check the specified argument Arg to make sure that it has the proper
3783 -- syntactic form for a local name and meets the semantic requirements
3784 -- for a local name. The local name is analyzed as part of the
3785 -- processing for this call. In addition, the local name is required
3786 -- to represent an entity at the library level.
3788 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3789 -- Check the specified argument Arg to make sure that it has the proper
3790 -- syntactic form for a local name and meets the semantic requirements
3791 -- for a local name. The local name is analyzed as part of the
3792 -- processing for this call.
3794 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3795 -- Check the specified argument Arg to make sure that it is a valid
3796 -- locking policy name. If not give error and raise Pragma_Exit.
3798 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3799 -- Check the specified argument Arg to make sure that it is a valid
3800 -- elaboration policy name. If not give error and raise Pragma_Exit.
3802 procedure Check_Arg_Is_One_Of
3805 procedure Check_Arg_Is_One_Of
3807 N1
, N2
, N3
: Name_Id
);
3808 procedure Check_Arg_Is_One_Of
3810 N1
, N2
, N3
, N4
: Name_Id
);
3811 procedure Check_Arg_Is_One_Of
3813 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3814 -- Check the specified argument Arg to make sure that it is an
3815 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3816 -- present). If not then give error and raise Pragma_Exit.
3818 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3819 -- Check the specified argument Arg to make sure that it is a valid
3820 -- queuing policy name. If not give error and raise Pragma_Exit.
3822 procedure Check_Arg_Is_OK_Static_Expression
3824 Typ
: Entity_Id
:= Empty
);
3825 -- Check the specified argument Arg to make sure that it is a static
3826 -- expression of the given type (i.e. it will be analyzed and resolved
3827 -- using this type, which can be any valid argument to Resolve, e.g.
3828 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3829 -- Typ is left Empty, then any static expression is allowed. Includes
3830 -- checking that the argument does not raise Constraint_Error.
3832 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3833 -- Check the specified argument Arg to make sure that it is a valid task
3834 -- dispatching policy name. If not give error and raise Pragma_Exit.
3836 procedure Check_Arg_Order
(Names
: Name_List
);
3837 -- Checks for an instance of two arguments with identifiers for the
3838 -- current pragma which are not in the sequence indicated by Names,
3839 -- and if so, generates a fatal message about bad order of arguments.
3841 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3842 -- Check there are at least N arguments present
3844 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3845 -- Check there are no more than N arguments present
3847 procedure Check_Component
3850 In_Variant_Part
: Boolean := False);
3851 -- Examine an Unchecked_Union component for correct use of per-object
3852 -- constrained subtypes, and for restrictions on finalizable components.
3853 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3854 -- should be set when Comp comes from a record variant.
3856 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3857 -- Check if a rep item of the same name as the current pragma is already
3858 -- chained as a rep pragma to the given entity. If so give a message
3859 -- about the duplicate, and then raise Pragma_Exit so does not return.
3860 -- Note that if E is a type, then this routine avoids flagging a pragma
3861 -- which applies to a parent type from which E is derived.
3863 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3864 -- Nam is an N_String_Literal node containing the external name set by
3865 -- an Import or Export pragma (or extended Import or Export pragma).
3866 -- This procedure checks for possible duplications if this is the export
3867 -- case, and if found, issues an appropriate error message.
3869 procedure Check_Expr_Is_OK_Static_Expression
3871 Typ
: Entity_Id
:= Empty
);
3872 -- Check the specified expression Expr to make sure that it is a static
3873 -- expression of the given type (i.e. it will be analyzed and resolved
3874 -- using this type, which can be any valid argument to Resolve, e.g.
3875 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3876 -- Typ is left Empty, then any static expression is allowed. Includes
3877 -- checking that the expression does not raise Constraint_Error.
3879 procedure Check_First_Subtype
(Arg
: Node_Id
);
3880 -- Checks that Arg, whose expression is an entity name, references a
3883 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3884 -- Checks that the given argument has an identifier, and if so, requires
3885 -- it to match the given identifier name. If there is no identifier, or
3886 -- a non-matching identifier, then an error message is given and
3887 -- Pragma_Exit is raised.
3889 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3890 -- Checks that the given argument has an identifier, and if so, requires
3891 -- it to match one of the given identifier names. If there is no
3892 -- identifier, or a non-matching identifier, then an error message is
3893 -- given and Pragma_Exit is raised.
3895 procedure Check_In_Main_Program
;
3896 -- Common checks for pragmas that appear within a main program
3897 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3899 procedure Check_Interrupt_Or_Attach_Handler
;
3900 -- Common processing for first argument of pragma Interrupt_Handler or
3901 -- pragma Attach_Handler.
3903 procedure Check_Loop_Pragma_Placement
;
3904 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3905 -- appear immediately within a construct restricted to loops, and that
3906 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3908 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3909 -- Check that pragma appears in a declarative part, or in a package
3910 -- specification, i.e. that it does not occur in a statement sequence
3913 procedure Check_No_Identifier
(Arg
: Node_Id
);
3914 -- Checks that the given argument does not have an identifier. If
3915 -- an identifier is present, then an error message is issued, and
3916 -- Pragma_Exit is raised.
3918 procedure Check_No_Identifiers
;
3919 -- Checks that none of the arguments to the pragma has an identifier.
3920 -- If any argument has an identifier, then an error message is issued,
3921 -- and Pragma_Exit is raised.
3923 procedure Check_No_Link_Name
;
3924 -- Checks that no link name is specified
3926 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3927 -- Checks if the given argument has an identifier, and if so, requires
3928 -- it to match the given identifier name. If there is a non-matching
3929 -- identifier, then an error message is given and Pragma_Exit is raised.
3931 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3932 -- Checks if the given argument has an identifier, and if so, requires
3933 -- it to match the given identifier name. If there is a non-matching
3934 -- identifier, then an error message is given and Pragma_Exit is raised.
3935 -- In this version of the procedure, the identifier name is given as
3936 -- a string with lower case letters.
3938 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3939 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3940 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3941 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3942 -- is an OK static boolean expression. Emit an error if this is not the
3945 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3946 -- Constr is a constraint from an N_Subtype_Indication node from a
3947 -- component constraint in an Unchecked_Union type. This routine checks
3948 -- that the constraint is static as required by the restrictions for
3951 procedure Check_Valid_Configuration_Pragma
;
3952 -- Legality checks for placement of a configuration pragma
3954 procedure Check_Valid_Library_Unit_Pragma
;
3955 -- Legality checks for library unit pragmas. A special case arises for
3956 -- pragmas in generic instances that come from copies of the original
3957 -- library unit pragmas in the generic templates. In the case of other
3958 -- than library level instantiations these can appear in contexts which
3959 -- would normally be invalid (they only apply to the original template
3960 -- and to library level instantiations), and they are simply ignored,
3961 -- which is implemented by rewriting them as null statements.
3963 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3964 -- Check an Unchecked_Union variant for lack of nested variants and
3965 -- presence of at least one component. UU_Typ is the related Unchecked_
3968 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3969 -- Subsidiary routine to the processing of pragmas Abstract_State,
3970 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3971 -- Refined_Global and Refined_State. Transform argument Arg into
3972 -- an aggregate if not one already. N_Null is never transformed.
3973 -- Arg may denote an aspect specification or a pragma argument
3976 procedure Error_Pragma
(Msg
: String);
3977 pragma No_Return
(Error_Pragma
);
3978 -- Outputs error message for current pragma. The message contains a %
3979 -- that will be replaced with the pragma name, and the flag is placed
3980 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3981 -- calls Fix_Error (see spec of that procedure for details).
3983 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3984 pragma No_Return
(Error_Pragma_Arg
);
3985 -- Outputs error message for current pragma. The message may contain
3986 -- a % that will be replaced with the pragma name. The parameter Arg
3987 -- may either be a pragma argument association, in which case the flag
3988 -- is placed on the expression of this association, or an expression,
3989 -- in which case the flag is placed directly on the expression. The
3990 -- message is placed using Error_Msg_N, so the message may also contain
3991 -- an & insertion character which will reference the given Arg value.
3992 -- After placing the message, Pragma_Exit is raised. Note: this routine
3993 -- calls Fix_Error (see spec of that procedure for details).
3995 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3996 pragma No_Return
(Error_Pragma_Arg
);
3997 -- Similar to above form of Error_Pragma_Arg except that two messages
3998 -- are provided, the second is a continuation comment starting with \.
4000 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
4001 pragma No_Return
(Error_Pragma_Arg_Ident
);
4002 -- Outputs error message for current pragma. The message may contain a %
4003 -- that will be replaced with the pragma name. The parameter Arg must be
4004 -- a pragma argument association with a non-empty identifier (i.e. its
4005 -- Chars field must be set), and the error message is placed on the
4006 -- identifier. The message is placed using Error_Msg_N so the message
4007 -- may also contain an & insertion character which will reference
4008 -- the identifier. After placing the message, Pragma_Exit is raised.
4009 -- Note: this routine calls Fix_Error (see spec of that procedure for
4012 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4013 pragma No_Return
(Error_Pragma_Ref
);
4014 -- Outputs error message for current pragma. The message may contain
4015 -- a % that will be replaced with the pragma name. The parameter Ref
4016 -- must be an entity whose name can be referenced by & and sloc by #.
4017 -- After placing the message, Pragma_Exit is raised. Note: this routine
4018 -- calls Fix_Error (see spec of that procedure for details).
4020 function Find_Lib_Unit_Name
return Entity_Id
;
4021 -- Used for a library unit pragma to find the entity to which the
4022 -- library unit pragma applies, returns the entity found.
4024 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4025 -- If the pragma is a compilation unit pragma, the id must denote the
4026 -- compilation unit in the same compilation, and the pragma must appear
4027 -- in the list of preceding or trailing pragmas. If it is a program
4028 -- unit pragma that is not a compilation unit pragma, then the
4029 -- identifier must be visible.
4031 function Find_Unique_Parameterless_Procedure
4033 Arg
: Node_Id
) return Entity_Id
;
4034 -- Used for a procedure pragma to find the unique parameterless
4035 -- procedure identified by Name, returns it if it exists, otherwise
4036 -- errors out and uses Arg as the pragma argument for the message.
4038 function Fix_Error
(Msg
: String) return String;
4039 -- This is called prior to issuing an error message. Msg is the normal
4040 -- error message issued in the pragma case. This routine checks for the
4041 -- case of a pragma coming from an aspect in the source, and returns a
4042 -- message suitable for the aspect case as follows:
4044 -- Each substring "pragma" is replaced by "aspect"
4046 -- If "argument of" is at the start of the error message text, it is
4047 -- replaced by "entity for".
4049 -- If "argument" is at the start of the error message text, it is
4050 -- replaced by "entity".
4052 -- So for example, "argument of pragma X must be discrete type"
4053 -- returns "entity for aspect X must be a discrete type".
4055 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4056 -- be different from the pragma name). If the current pragma results
4057 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4058 -- original pragma name.
4060 procedure Gather_Associations
4062 Args
: out Args_List
);
4063 -- This procedure is used to gather the arguments for a pragma that
4064 -- permits arbitrary ordering of parameters using the normal rules
4065 -- for named and positional parameters. The Names argument is a list
4066 -- of Name_Id values that corresponds to the allowed pragma argument
4067 -- association identifiers in order. The result returned in Args is
4068 -- a list of corresponding expressions that are the pragma arguments.
4069 -- Note that this is a list of expressions, not of pragma argument
4070 -- associations (Gather_Associations has completely checked all the
4071 -- optional identifiers when it returns). An entry in Args is Empty
4072 -- on return if the corresponding argument is not present.
4074 procedure GNAT_Pragma
;
4075 -- Called for all GNAT defined pragmas to check the relevant restriction
4076 -- (No_Implementation_Pragmas).
4078 function Is_Before_First_Decl
4079 (Pragma_Node
: Node_Id
;
4080 Decls
: List_Id
) return Boolean;
4081 -- Return True if Pragma_Node is before the first declarative item in
4082 -- Decls where Decls is the list of declarative items.
4084 function Is_Configuration_Pragma
return Boolean;
4085 -- Determines if the placement of the current pragma is appropriate
4086 -- for a configuration pragma.
4088 function Is_In_Context_Clause
return Boolean;
4089 -- Returns True if pragma appears within the context clause of a unit,
4090 -- and False for any other placement (does not generate any messages).
4092 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4093 -- Analyzes the argument, and determines if it is a static string
4094 -- expression, returns True if so, False if non-static or not String.
4095 -- A special case is that a string literal returns True in Ada 83 mode
4096 -- (which has no such thing as static string expressions). Note that
4097 -- the call analyzes its argument, so this cannot be used for the case
4098 -- where an identifier might not be declared.
4100 procedure Pragma_Misplaced
;
4101 pragma No_Return
(Pragma_Misplaced
);
4102 -- Issue fatal error message for misplaced pragma
4104 procedure Process_Atomic_Independent_Shared_Volatile
;
4105 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4106 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4107 -- and treated as being identical in effect to pragma Atomic.
4109 procedure Process_Compile_Time_Warning_Or_Error
;
4110 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4112 procedure Process_Convention
4113 (C
: out Convention_Id
;
4114 Ent
: out Entity_Id
);
4115 -- Common processing for Convention, Interface, Import and Export.
4116 -- Checks first two arguments of pragma, and sets the appropriate
4117 -- convention value in the specified entity or entities. On return
4118 -- C is the convention, Ent is the referenced entity.
4120 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4121 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4122 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4124 procedure Process_Extended_Import_Export_Object_Pragma
4125 (Arg_Internal
: Node_Id
;
4126 Arg_External
: Node_Id
;
4127 Arg_Size
: Node_Id
);
4128 -- Common processing for the pragmas Import/Export_Object. The three
4129 -- arguments correspond to the three named parameters of the pragmas. An
4130 -- argument is empty if the corresponding parameter is not present in
4133 procedure Process_Extended_Import_Export_Internal_Arg
4134 (Arg_Internal
: Node_Id
:= Empty
);
4135 -- Common processing for all extended Import and Export pragmas. The
4136 -- argument is the pragma parameter for the Internal argument. If
4137 -- Arg_Internal is empty or inappropriate, an error message is posted.
4138 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4139 -- set to identify the referenced entity.
4141 procedure Process_Extended_Import_Export_Subprogram_Pragma
4142 (Arg_Internal
: Node_Id
;
4143 Arg_External
: Node_Id
;
4144 Arg_Parameter_Types
: Node_Id
;
4145 Arg_Result_Type
: Node_Id
:= Empty
;
4146 Arg_Mechanism
: Node_Id
;
4147 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4148 -- Common processing for all extended Import and Export pragmas applying
4149 -- to subprograms. The caller omits any arguments that do not apply to
4150 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4151 -- only in the Import_Function and Export_Function cases). The argument
4152 -- names correspond to the allowed pragma association identifiers.
4154 procedure Process_Generic_List
;
4155 -- Common processing for Share_Generic and Inline_Generic
4157 procedure Process_Import_Or_Interface
;
4158 -- Common processing for Import or Interface
4160 procedure Process_Import_Predefined_Type
;
4161 -- Processing for completing a type with pragma Import. This is used
4162 -- to declare types that match predefined C types, especially for cases
4163 -- without corresponding Ada predefined type.
4165 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4166 -- Inline status of a subprogram, indicated as follows:
4167 -- Suppressed: inlining is suppressed for the subprogram
4168 -- Disabled: no inlining is requested for the subprogram
4169 -- Enabled: inlining is requested/required for the subprogram
4171 procedure Process_Inline
(Status
: Inline_Status
);
4172 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4173 -- indicates the inline status specified by the pragma.
4175 procedure Process_Interface_Name
4176 (Subprogram_Def
: Entity_Id
;
4180 -- Given the last two arguments of pragma Import, pragma Export, or
4181 -- pragma Interface_Name, performs validity checks and sets the
4182 -- Interface_Name field of the given subprogram entity to the
4183 -- appropriate external or link name, depending on the arguments given.
4184 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4185 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4186 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4187 -- nor Link_Arg is present, the interface name is set to the default
4188 -- from the subprogram name. In addition, the pragma itself is passed
4189 -- to analyze any expressions in the case the pragma came from an aspect
4192 procedure Process_Interrupt_Or_Attach_Handler
;
4193 -- Common processing for Interrupt and Attach_Handler pragmas
4195 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4196 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4197 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4198 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4199 -- is not set in the Restrictions case.
4201 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4202 -- Common processing for Suppress and Unsuppress. The boolean parameter
4203 -- Suppress_Case is True for the Suppress case, and False for the
4206 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4207 -- Subsidiary to the analysis of pragmas Independent[_Components].
4208 -- Record such a pragma N applied to entity E for future checks.
4210 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4211 -- This procedure sets the Is_Exported flag for the given entity,
4212 -- checking that the entity was not previously imported. Arg is
4213 -- the argument that specified the entity. A check is also made
4214 -- for exporting inappropriate entities.
4216 procedure Set_Extended_Import_Export_External_Name
4217 (Internal_Ent
: Entity_Id
;
4218 Arg_External
: Node_Id
);
4219 -- Common processing for all extended import export pragmas. The first
4220 -- argument, Internal_Ent, is the internal entity, which has already
4221 -- been checked for validity by the caller. Arg_External is from the
4222 -- Import or Export pragma, and may be null if no External parameter
4223 -- was present. If Arg_External is present and is a non-null string
4224 -- (a null string is treated as the default), then the Interface_Name
4225 -- field of Internal_Ent is set appropriately.
4227 procedure Set_Imported
(E
: Entity_Id
);
4228 -- This procedure sets the Is_Imported flag for the given entity,
4229 -- checking that it is not previously exported or imported.
4231 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4232 -- Mech is a parameter passing mechanism (see Import_Function syntax
4233 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4234 -- has the right form, and if not issues an error message. If the
4235 -- argument has the right form then the Mechanism field of Ent is
4236 -- set appropriately.
4238 procedure Set_Rational_Profile
;
4239 -- Activate the set of configuration pragmas and permissions that make
4240 -- up the Rational profile.
4242 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4243 -- Activate the set of configuration pragmas and restrictions that make
4244 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4245 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4246 -- which is used for error messages on any constructs violating the
4249 procedure Validate_Acc_Condition_Clause
(Clause
: Node_Id
);
4250 -- Make sure the argument of a given Acc_If clause is a Boolean
4252 procedure Validate_Acc_Data_Clause
(Clause
: Node_Id
);
4253 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4254 -- Copyout...) is an identifier or an aggregate of identifiers.
4256 procedure Validate_Acc_Int_Expr_Clause
(Clause
: Node_Id
);
4257 -- Make sure the argument of an OpenAcc clause is an Integer expression
4259 procedure Validate_Acc_Int_Expr_List_Clause
(Clause
: Node_Id
);
4260 -- Make sure the argument of an OpenAcc clause is an Integer expression
4261 -- or a list of Integer expressions.
4263 procedure Validate_Acc_Loop_Collapse
(Clause
: Node_Id
);
4264 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4265 -- contains at least N-1 nested loops.
4267 procedure Validate_Acc_Loop_Gang
(Clause
: Node_Id
);
4268 -- Make sure the argument of the Gang clause of a Loop directive is
4269 -- either an integer expression or a (Static => integer expressions)
4272 procedure Validate_Acc_Loop_Vector
(Clause
: Node_Id
);
4273 -- When this procedure is called in a construct offloaded by an
4274 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4275 -- not exist on said pragma. In all cases, make sure the argument
4276 -- is an Integer expression.
4278 procedure Validate_Acc_Loop_Worker
(Clause
: Node_Id
);
4279 -- When this procedure is called in a construct offloaded by an
4280 -- Acc_Parallel pragma, makes sure that no argument has been given.
4281 -- When this procedure is called in a construct offloaded by an
4282 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4283 -- makes sure that the Num_Workers clause does not appear on the
4284 -- Acc_Kernels pragma and that the argument is an integer.
4286 procedure Validate_Acc_Name_Reduction
(Clause
: Node_Id
);
4287 -- Make sure the reduction clause is an aggregate made of a string
4288 -- representing a supported reduction operation (i.e. "+", "*", "and",
4289 -- "or", "min" or "max") and either an identifier or aggregate of
4292 procedure Validate_Acc_Size_Expressions
(Clause
: Node_Id
);
4293 -- Makes sure that Clause is either an integer expression or an
4294 -- association with a Static as name and a list of integer expressions
4295 -- or "*" strings on the right hand side.
4301 function Acc_First
(N
: Node_Id
) return Node_Id
is
4303 if Nkind
(N
) = N_Aggregate
then
4304 if Present
(Expressions
(N
)) then
4305 return First
(Expressions
(N
));
4307 elsif Present
(Component_Associations
(N
)) then
4308 return Expression
(First
(Component_Associations
(N
)));
4319 function Acc_Next
(N
: Node_Id
) return Node_Id
is
4321 if Nkind
(Parent
(N
)) = N_Component_Association
then
4322 return Expression
(Next
(Parent
(N
)));
4324 elsif Nkind
(Parent
(N
)) = N_Aggregate
then
4332 ----------------------------------
4333 -- Acquire_Warning_Match_String --
4334 ----------------------------------
4336 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4338 String_To_Name_Buffer
4339 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4341 -- Add asterisk at start if not already there
4343 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4344 Name_Buffer
(2 .. Name_Len
+ 1) :=
4345 Name_Buffer
(1 .. Name_Len
);
4346 Name_Buffer
(1) := '*';
4347 Name_Len
:= Name_Len
+ 1;
4350 -- Add asterisk at end if not already there
4352 if Name_Buffer
(Name_Len
) /= '*' then
4353 Name_Len
:= Name_Len
+ 1;
4354 Name_Buffer
(Name_Len
) := '*';
4356 end Acquire_Warning_Match_String
;
4358 ---------------------
4359 -- Ada_2005_Pragma --
4360 ---------------------
4362 procedure Ada_2005_Pragma
is
4364 if Ada_Version
<= Ada_95
then
4365 Check_Restriction
(No_Implementation_Pragmas
, N
);
4367 end Ada_2005_Pragma
;
4369 ---------------------
4370 -- Ada_2012_Pragma --
4371 ---------------------
4373 procedure Ada_2012_Pragma
is
4375 if Ada_Version
<= Ada_2005
then
4376 Check_Restriction
(No_Implementation_Pragmas
, N
);
4378 end Ada_2012_Pragma
;
4380 ----------------------------
4381 -- Analyze_Depends_Global --
4382 ----------------------------
4384 procedure Analyze_Depends_Global
4385 (Spec_Id
: out Entity_Id
;
4386 Subp_Decl
: out Node_Id
;
4387 Legal
: out Boolean)
4390 -- Assume that the pragma is illegal
4397 Check_Arg_Count
(1);
4399 -- Ensure the proper placement of the pragma. Depends/Global must be
4400 -- associated with a subprogram declaration or a body that acts as a
4403 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4407 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4410 -- Generic subprogram
4412 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4415 -- Object declaration of a single concurrent type
4417 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4418 and then Is_Single_Concurrent_Object
4419 (Unique_Defining_Entity
(Subp_Decl
))
4425 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4428 -- Subprogram body acts as spec
4430 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4431 and then No
(Corresponding_Spec
(Subp_Decl
))
4435 -- Subprogram body stub acts as spec
4437 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4438 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4442 -- Subprogram declaration
4444 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4449 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4457 -- If we get here, then the pragma is legal
4460 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4462 -- When the related context is an entry, the entry must belong to a
4463 -- protected unit (SPARK RM 6.1.4(6)).
4465 if Is_Entry_Declaration
(Spec_Id
)
4466 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4471 -- When the related context is an anonymous object created for a
4472 -- simple concurrent type, the type must be a task
4473 -- (SPARK RM 6.1.4(6)).
4475 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4476 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4482 -- A pragma that applies to a Ghost entity becomes Ghost for the
4483 -- purposes of legality checks and removal of ignored Ghost code.
4485 Mark_Ghost_Pragma
(N
, Spec_Id
);
4486 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4487 end Analyze_Depends_Global
;
4489 ------------------------
4490 -- Analyze_If_Present --
4491 ------------------------
4493 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4497 pragma Assert
(Is_List_Member
(N
));
4499 -- Inspect the declarations or statements following pragma N looking
4500 -- for another pragma whose Id matches the caller's request. If it is
4501 -- available, analyze it.
4504 while Present
(Stmt
) loop
4505 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4506 Analyze_Pragma
(Stmt
);
4509 -- The first source declaration or statement immediately following
4510 -- N ends the region where a pragma may appear.
4512 elsif Comes_From_Source
(Stmt
) then
4518 end Analyze_If_Present
;
4520 --------------------------------
4521 -- Analyze_Pre_Post_Condition --
4522 --------------------------------
4524 procedure Analyze_Pre_Post_Condition
is
4525 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4526 Subp_Decl
: Node_Id
;
4527 Subp_Id
: Entity_Id
;
4529 Duplicates_OK
: Boolean := False;
4530 -- Flag set when a pre/postcondition allows multiple pragmas of the
4533 In_Body_OK
: Boolean := False;
4534 -- Flag set when a pre/postcondition is allowed to appear on a body
4535 -- even though the subprogram may have a spec.
4537 Is_Pre_Post
: Boolean := False;
4538 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4541 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4542 -- Implement rules in AI12-0131: an overriding operation can have
4543 -- a class-wide precondition only if one of its ancestors has an
4544 -- explicit class-wide precondition.
4546 -----------------------------
4547 -- Inherits_Class_Wide_Pre --
4548 -----------------------------
4550 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4551 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4554 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4557 -- Check ancestors on the overriding operation to examine the
4558 -- preconditions that may apply to them.
4560 while Present
(Prev
) loop
4561 Cont
:= Contract
(Prev
);
4562 if Present
(Cont
) then
4563 Prag
:= Pre_Post_Conditions
(Cont
);
4564 while Present
(Prag
) loop
4565 if Pragma_Name
(Prag
) = Name_Precondition
4566 and then Class_Present
(Prag
)
4571 Prag
:= Next_Pragma
(Prag
);
4575 -- For a type derived from a generic formal type, the operation
4576 -- inheriting the condition is a renaming, not an overriding of
4577 -- the operation of the formal. Ditto for an inherited
4578 -- operation which has no explicit contracts.
4580 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4581 or else not Comes_From_Source
(Prev
)
4583 Prev
:= Alias
(Prev
);
4585 Prev
:= Overridden_Operation
(Prev
);
4589 -- If the controlling type of the subprogram has progenitors, an
4590 -- interface operation implemented by the current operation may
4591 -- have a class-wide precondition.
4593 if Has_Interfaces
(Typ
) then
4598 Prim_Elmt
: Elmt_Id
;
4599 Prim_List
: Elist_Id
;
4602 Collect_Interfaces
(Typ
, Ints
);
4603 Elmt
:= First_Elmt
(Ints
);
4605 -- Iterate over the primitive operations of each interface
4607 while Present
(Elmt
) loop
4608 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4609 Prim_Elmt
:= First_Elmt
(Prim_List
);
4610 while Present
(Prim_Elmt
) loop
4611 Prim
:= Node
(Prim_Elmt
);
4612 if Chars
(Prim
) = Chars
(E
)
4613 and then Present
(Contract
(Prim
))
4614 and then Class_Present
4615 (Pre_Post_Conditions
(Contract
(Prim
)))
4620 Next_Elmt
(Prim_Elmt
);
4629 end Inherits_Class_Wide_Pre
;
4631 -- Start of processing for Analyze_Pre_Post_Condition
4634 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4635 -- offer uniformity among the various kinds of pre/postconditions by
4636 -- rewriting the pragma identifier. This allows the retrieval of the
4637 -- original pragma name by routine Original_Aspect_Pragma_Name.
4639 if Comes_From_Source
(N
) then
4640 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4641 Is_Pre_Post
:= True;
4642 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4643 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4645 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4646 Is_Pre_Post
:= True;
4647 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4648 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4652 -- Determine the semantics with respect to duplicates and placement
4653 -- in a body. Pragmas Precondition and Postcondition were introduced
4654 -- before aspects and are not subject to the same aspect-like rules.
4656 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4657 Duplicates_OK
:= True;
4663 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4664 -- argument without an identifier.
4667 Check_Arg_Count
(1);
4668 Check_No_Identifiers
;
4670 -- Pragmas Precondition and Postcondition have complex argument
4674 Check_At_Least_N_Arguments
(1);
4675 Check_At_Most_N_Arguments
(2);
4676 Check_Optional_Identifier
(Arg1
, Name_Check
);
4678 if Present
(Arg2
) then
4679 Check_Optional_Identifier
(Arg2
, Name_Message
);
4680 Preanalyze_Spec_Expression
4681 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4685 -- For a pragma PPC in the extended main source unit, record enabled
4687 -- ??? nothing checks that the pragma is in the main source unit
4689 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4690 Set_SCO_Pragma_Enabled
(Loc
);
4693 -- Ensure the proper placement of the pragma
4696 Find_Related_Declaration_Or_Body
4697 (N
, Do_Checks
=> not Duplicates_OK
);
4699 -- When a pre/postcondition pragma applies to an abstract subprogram,
4700 -- its original form must be an aspect with 'Class.
4702 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4703 if not From_Aspect_Specification
(N
) then
4705 ("pragma % cannot be applied to abstract subprogram");
4707 elsif not Class_Present
(N
) then
4709 ("aspect % requires ''Class for abstract subprogram");
4712 -- Entry declaration
4714 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4717 -- Generic subprogram declaration
4719 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4724 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4725 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4729 -- Subprogram body stub
4731 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4732 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4736 -- Subprogram declaration
4738 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4740 -- AI05-0230: When a pre/postcondition pragma applies to a null
4741 -- procedure, its original form must be an aspect with 'Class.
4743 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4744 and then Null_Present
(Specification
(Subp_Decl
))
4745 and then From_Aspect_Specification
(N
)
4746 and then not Class_Present
(N
)
4748 Error_Pragma
("aspect % requires ''Class for null procedure");
4751 -- Implement the legality checks mandated by AI12-0131:
4752 -- Pre'Class shall not be specified for an overriding primitive
4753 -- subprogram of a tagged type T unless the Pre'Class aspect is
4754 -- specified for the corresponding primitive subprogram of some
4758 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4761 if Class_Present
(N
)
4762 and then Pragma_Name
(N
) = Name_Precondition
4763 and then Present
(Overridden_Operation
(E
))
4764 and then not Inherits_Class_Wide_Pre
(E
)
4767 ("illegal class-wide precondition on overriding operation",
4768 Corresponding_Aspect
(N
));
4772 -- A renaming declaration may inherit a generated pragma, its
4773 -- placement comes from expansion, not from source.
4775 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4776 and then not Comes_From_Source
(N
)
4780 -- Otherwise the placement is illegal
4787 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4789 -- A pragma that applies to a Ghost entity becomes Ghost for the
4790 -- purposes of legality checks and removal of ignored Ghost code.
4792 Mark_Ghost_Pragma
(N
, Subp_Id
);
4794 -- Chain the pragma on the contract for further processing by
4795 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4797 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4799 -- Fully analyze the pragma when it appears inside an entry or
4800 -- subprogram body because it cannot benefit from forward references.
4802 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4804 N_Subprogram_Body_Stub
)
4806 -- The legality checks of pragmas Precondition and Postcondition
4807 -- are affected by the SPARK mode in effect and the volatility of
4808 -- the context. Analyze all pragmas in a specific order.
4810 Analyze_If_Present
(Pragma_SPARK_Mode
);
4811 Analyze_If_Present
(Pragma_Volatile_Function
);
4812 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4814 end Analyze_Pre_Post_Condition
;
4816 -----------------------------------------
4817 -- Analyze_Refined_Depends_Global_Post --
4818 -----------------------------------------
4820 procedure Analyze_Refined_Depends_Global_Post
4821 (Spec_Id
: out Entity_Id
;
4822 Body_Id
: out Entity_Id
;
4823 Legal
: out Boolean)
4825 Body_Decl
: Node_Id
;
4826 Spec_Decl
: Node_Id
;
4829 -- Assume that the pragma is illegal
4836 Check_Arg_Count
(1);
4837 Check_No_Identifiers
;
4839 -- Verify the placement of the pragma and check for duplicates. The
4840 -- pragma must apply to a subprogram body [stub].
4842 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4844 if not Nkind_In
(Body_Decl
, N_Entry_Body
,
4846 N_Subprogram_Body_Stub
,
4854 Body_Id
:= Defining_Entity
(Body_Decl
);
4855 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4857 -- The pragma must apply to the second declaration of a subprogram.
4858 -- In other words, the body [stub] cannot acts as a spec.
4860 if No
(Spec_Id
) then
4861 Error_Pragma
("pragma % cannot apply to a stand alone body");
4864 -- Catch the case where the subprogram body is a subunit and acts as
4865 -- the third declaration of the subprogram.
4867 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4868 Error_Pragma
("pragma % cannot apply to a subunit");
4872 -- A refined pragma can only apply to the body [stub] of a subprogram
4873 -- declared in the visible part of a package. Retrieve the context of
4874 -- the subprogram declaration.
4876 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4878 -- When dealing with protected entries or protected subprograms, use
4879 -- the enclosing protected type as the proper context.
4881 if Ekind_In
(Spec_Id
, E_Entry
,
4885 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4887 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4890 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4892 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4893 & "subprogram declared in a package specification"));
4897 -- If we get here, then the pragma is legal
4901 -- A pragma that applies to a Ghost entity becomes Ghost for the
4902 -- purposes of legality checks and removal of ignored Ghost code.
4904 Mark_Ghost_Pragma
(N
, Spec_Id
);
4906 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4907 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4909 end Analyze_Refined_Depends_Global_Post
;
4911 ----------------------------------
4912 -- Analyze_Unmodified_Or_Unused --
4913 ----------------------------------
4915 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4920 Ghost_Error_Posted
: Boolean := False;
4921 -- Flag set when an error concerning the illegal mix of Ghost and
4922 -- non-Ghost variables is emitted.
4924 Ghost_Id
: Entity_Id
:= Empty
;
4925 -- The entity of the first Ghost variable encountered while
4926 -- processing the arguments of the pragma.
4930 Check_At_Least_N_Arguments
(1);
4932 -- Loop through arguments
4935 while Present
(Arg
) loop
4936 Check_No_Identifier
(Arg
);
4938 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4939 -- in fact generate reference, so that the entity will have a
4940 -- reference, which will inhibit any warnings about it not
4941 -- being referenced, and also properly show up in the ali file
4942 -- as a reference. But this reference is recorded before the
4943 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4944 -- generated for this reference.
4946 Check_Arg_Is_Local_Name
(Arg
);
4947 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4949 if Is_Entity_Name
(Arg_Expr
) then
4950 Arg_Id
:= Entity
(Arg_Expr
);
4952 -- Skip processing the argument if already flagged
4954 if Is_Assignable
(Arg_Id
)
4955 and then not Has_Pragma_Unmodified
(Arg_Id
)
4956 and then not Has_Pragma_Unused
(Arg_Id
)
4958 Set_Has_Pragma_Unmodified
(Arg_Id
);
4961 Set_Has_Pragma_Unused
(Arg_Id
);
4964 -- A pragma that applies to a Ghost entity becomes Ghost for
4965 -- the purposes of legality checks and removal of ignored
4968 Mark_Ghost_Pragma
(N
, Arg_Id
);
4970 -- Capture the entity of the first Ghost variable being
4971 -- processed for error detection purposes.
4973 if Is_Ghost_Entity
(Arg_Id
) then
4974 if No
(Ghost_Id
) then
4978 -- Otherwise the variable is non-Ghost. It is illegal to mix
4979 -- references to Ghost and non-Ghost entities
4982 elsif Present
(Ghost_Id
)
4983 and then not Ghost_Error_Posted
4985 Ghost_Error_Posted
:= True;
4987 Error_Msg_Name_1
:= Pname
;
4989 ("pragma % cannot mention ghost and non-ghost "
4992 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4993 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4995 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4996 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4999 -- Warn if already flagged as Unused or Unmodified
5001 elsif Has_Pragma_Unmodified
(Arg_Id
) then
5002 if Has_Pragma_Unused
(Arg_Id
) then
5004 ("??pragma Unused already given for &!", Arg_Expr
,
5008 ("??pragma Unmodified already given for &!", Arg_Expr
,
5012 -- Otherwise the pragma referenced an illegal entity
5016 ("pragma% can only be applied to a variable", Arg_Expr
);
5022 end Analyze_Unmodified_Or_Unused
;
5024 ------------------------------------
5025 -- Analyze_Unreferenced_Or_Unused --
5026 ------------------------------------
5028 procedure Analyze_Unreferenced_Or_Unused
5029 (Is_Unused
: Boolean := False)
5036 Ghost_Error_Posted
: Boolean := False;
5037 -- Flag set when an error concerning the illegal mix of Ghost and
5038 -- non-Ghost names is emitted.
5040 Ghost_Id
: Entity_Id
:= Empty
;
5041 -- The entity of the first Ghost name encountered while processing
5042 -- the arguments of the pragma.
5046 Check_At_Least_N_Arguments
(1);
5048 -- Check case of appearing within context clause
5050 if not Is_Unused
and then Is_In_Context_Clause
then
5052 -- The arguments must all be units mentioned in a with clause in
5053 -- the same context clause. Note that Par.Prag already checked
5054 -- that the arguments are either identifiers or selected
5058 while Present
(Arg
) loop
5059 Citem
:= First
(List_Containing
(N
));
5060 while Citem
/= N
loop
5061 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5063 if Nkind
(Citem
) = N_With_Clause
5064 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5066 Set_Has_Pragma_Unreferenced
5069 (Library_Unit
(Citem
))));
5070 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5079 ("argument of pragma% is not withed unit", Arg
);
5085 -- Case of not in list of context items
5089 while Present
(Arg
) loop
5090 Check_No_Identifier
(Arg
);
5092 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5093 -- in fact generate reference, so that the entity will have a
5094 -- reference, which will inhibit any warnings about it not
5095 -- being referenced, and also properly show up in the ali file
5096 -- as a reference. But this reference is recorded before the
5097 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5098 -- generated for this reference.
5100 Check_Arg_Is_Local_Name
(Arg
);
5101 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5103 if Is_Entity_Name
(Arg_Expr
) then
5104 Arg_Id
:= Entity
(Arg_Expr
);
5106 -- Warn if already flagged as Unused or Unreferenced and
5107 -- skip processing the argument.
5109 if Has_Pragma_Unreferenced
(Arg_Id
) then
5110 if Has_Pragma_Unused
(Arg_Id
) then
5112 ("??pragma Unused already given for &!", Arg_Expr
,
5116 ("??pragma Unreferenced already given for &!",
5120 -- Apply Unreferenced to the entity
5123 -- If the entity is overloaded, the pragma applies to the
5124 -- most recent overloading, as documented. In this case,
5125 -- name resolution does not generate a reference, so it
5126 -- must be done here explicitly.
5128 if Is_Overloaded
(Arg_Expr
) then
5129 Generate_Reference
(Arg_Id
, N
);
5132 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5135 Set_Has_Pragma_Unused
(Arg_Id
);
5138 -- A pragma that applies to a Ghost entity becomes Ghost
5139 -- for the purposes of legality checks and removal of
5140 -- ignored Ghost code.
5142 Mark_Ghost_Pragma
(N
, Arg_Id
);
5144 -- Capture the entity of the first Ghost name being
5145 -- processed for error detection purposes.
5147 if Is_Ghost_Entity
(Arg_Id
) then
5148 if No
(Ghost_Id
) then
5152 -- Otherwise the name is non-Ghost. It is illegal to mix
5153 -- references to Ghost and non-Ghost entities
5156 elsif Present
(Ghost_Id
)
5157 and then not Ghost_Error_Posted
5159 Ghost_Error_Posted
:= True;
5161 Error_Msg_Name_1
:= Pname
;
5163 ("pragma % cannot mention ghost and non-ghost "
5166 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5168 ("\& # declared as ghost", N
, Ghost_Id
);
5170 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5172 ("\& # declared as non-ghost", N
, Arg_Id
);
5180 end Analyze_Unreferenced_Or_Unused
;
5182 --------------------------
5183 -- Check_Ada_83_Warning --
5184 --------------------------
5186 procedure Check_Ada_83_Warning
is
5188 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5189 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5191 end Check_Ada_83_Warning
;
5193 ---------------------
5194 -- Check_Arg_Count --
5195 ---------------------
5197 procedure Check_Arg_Count
(Required
: Nat
) is
5199 if Arg_Count
/= Required
then
5200 Error_Pragma
("wrong number of arguments for pragma%");
5202 end Check_Arg_Count
;
5204 --------------------------------
5205 -- Check_Arg_Is_External_Name --
5206 --------------------------------
5208 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5209 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5212 if Nkind
(Argx
) = N_Identifier
then
5216 Analyze_And_Resolve
(Argx
, Standard_String
);
5218 if Is_OK_Static_Expression
(Argx
) then
5221 elsif Etype
(Argx
) = Any_Type
then
5224 -- An interesting special case, if we have a string literal and
5225 -- we are in Ada 83 mode, then we allow it even though it will
5226 -- not be flagged as static. This allows expected Ada 83 mode
5227 -- use of external names which are string literals, even though
5228 -- technically these are not static in Ada 83.
5230 elsif Ada_Version
= Ada_83
5231 and then Nkind
(Argx
) = N_String_Literal
5235 -- Here we have a real error (non-static expression)
5238 Error_Msg_Name_1
:= Pname
;
5239 Flag_Non_Static_Expr
5240 (Fix_Error
("argument for pragma% must be a identifier or "
5241 & "static string expression!"), Argx
);
5246 end Check_Arg_Is_External_Name
;
5248 -----------------------------
5249 -- Check_Arg_Is_Identifier --
5250 -----------------------------
5252 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5253 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5255 if Nkind
(Argx
) /= N_Identifier
then
5256 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5258 end Check_Arg_Is_Identifier
;
5260 ----------------------------------
5261 -- Check_Arg_Is_Integer_Literal --
5262 ----------------------------------
5264 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5265 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5267 if Nkind
(Argx
) /= N_Integer_Literal
then
5269 ("argument for pragma% must be integer literal", Argx
);
5271 end Check_Arg_Is_Integer_Literal
;
5273 -------------------------------------------
5274 -- Check_Arg_Is_Library_Level_Local_Name --
5275 -------------------------------------------
5279 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5280 -- | library_unit_NAME
5282 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5284 Check_Arg_Is_Local_Name
(Arg
);
5286 -- If it came from an aspect, we want to give the error just as if it
5287 -- came from source.
5289 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5290 and then (Comes_From_Source
(N
)
5291 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5294 ("argument for pragma% must be library level entity", Arg
);
5296 end Check_Arg_Is_Library_Level_Local_Name
;
5298 -----------------------------
5299 -- Check_Arg_Is_Local_Name --
5300 -----------------------------
5304 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5305 -- | library_unit_NAME
5307 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5308 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5311 -- If this pragma came from an aspect specification, we don't want to
5312 -- check for this error, because that would cause spurious errors, in
5313 -- case a type is frozen in a scope more nested than the type. The
5314 -- aspect itself of course can't be anywhere but on the declaration
5317 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5318 if From_Aspect_Specification
(Parent
(Arg
)) then
5322 -- Arg is the Expression of an N_Pragma_Argument_Association
5325 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5332 if Nkind
(Argx
) not in N_Direct_Name
5333 and then (Nkind
(Argx
) /= N_Attribute_Reference
5334 or else Present
(Expressions
(Argx
))
5335 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5336 and then (not Is_Entity_Name
(Argx
)
5337 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5339 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5342 -- No further check required if not an entity name
5344 if not Is_Entity_Name
(Argx
) then
5350 Ent
: constant Entity_Id
:= Entity
(Argx
);
5351 Scop
: constant Entity_Id
:= Scope
(Ent
);
5354 -- Case of a pragma applied to a compilation unit: pragma must
5355 -- occur immediately after the program unit in the compilation.
5357 if Is_Compilation_Unit
(Ent
) then
5359 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5362 -- Case of pragma placed immediately after spec
5364 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5367 -- Case of pragma placed immediately after body
5369 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5370 and then Present
(Corresponding_Body
(Decl
))
5374 (Parent
(Unit_Declaration_Node
5375 (Corresponding_Body
(Decl
))));
5377 -- All other cases are illegal
5384 -- Special restricted placement rule from 10.2.1(11.8/2)
5386 elsif Is_Generic_Formal
(Ent
)
5387 and then Prag_Id
= Pragma_Preelaborable_Initialization
5389 OK
:= List_Containing
(N
) =
5390 Generic_Formal_Declarations
5391 (Unit_Declaration_Node
(Scop
));
5393 -- If this is an aspect applied to a subprogram body, the
5394 -- pragma is inserted in its declarative part.
5396 elsif From_Aspect_Specification
(N
)
5397 and then Ent
= Current_Scope
5399 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5403 -- If the aspect is a predicate (possibly others ???) and the
5404 -- context is a record type, this is a discriminant expression
5405 -- within a type declaration, that freezes the predicated
5408 elsif From_Aspect_Specification
(N
)
5409 and then Prag_Id
= Pragma_Predicate
5410 and then Ekind
(Current_Scope
) = E_Record_Type
5411 and then Scop
= Scope
(Current_Scope
)
5415 -- Default case, just check that the pragma occurs in the scope
5416 -- of the entity denoted by the name.
5419 OK
:= Current_Scope
= Scop
;
5424 ("pragma% argument must be in same declarative part", Arg
);
5428 end Check_Arg_Is_Local_Name
;
5430 ---------------------------------
5431 -- Check_Arg_Is_Locking_Policy --
5432 ---------------------------------
5434 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5435 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5438 Check_Arg_Is_Identifier
(Argx
);
5440 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5441 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5443 end Check_Arg_Is_Locking_Policy
;
5445 -----------------------------------------------
5446 -- Check_Arg_Is_Partition_Elaboration_Policy --
5447 -----------------------------------------------
5449 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5450 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5453 Check_Arg_Is_Identifier
(Argx
);
5455 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5457 ("& is not a valid partition elaboration policy name", Argx
);
5459 end Check_Arg_Is_Partition_Elaboration_Policy
;
5461 -------------------------
5462 -- Check_Arg_Is_One_Of --
5463 -------------------------
5465 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5466 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5469 Check_Arg_Is_Identifier
(Argx
);
5471 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5472 Error_Msg_Name_2
:= N1
;
5473 Error_Msg_Name_3
:= N2
;
5474 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5476 end Check_Arg_Is_One_Of
;
5478 procedure Check_Arg_Is_One_Of
5480 N1
, N2
, N3
: Name_Id
)
5482 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5485 Check_Arg_Is_Identifier
(Argx
);
5487 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5488 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5490 end Check_Arg_Is_One_Of
;
5492 procedure Check_Arg_Is_One_Of
5494 N1
, N2
, N3
, N4
: Name_Id
)
5496 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5499 Check_Arg_Is_Identifier
(Argx
);
5501 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5502 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5504 end Check_Arg_Is_One_Of
;
5506 procedure Check_Arg_Is_One_Of
5508 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5510 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5513 Check_Arg_Is_Identifier
(Argx
);
5515 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5516 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5518 end Check_Arg_Is_One_Of
;
5520 ---------------------------------
5521 -- Check_Arg_Is_Queuing_Policy --
5522 ---------------------------------
5524 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5525 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5528 Check_Arg_Is_Identifier
(Argx
);
5530 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5531 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5533 end Check_Arg_Is_Queuing_Policy
;
5535 ---------------------------------------
5536 -- Check_Arg_Is_OK_Static_Expression --
5537 ---------------------------------------
5539 procedure Check_Arg_Is_OK_Static_Expression
5541 Typ
: Entity_Id
:= Empty
)
5544 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5545 end Check_Arg_Is_OK_Static_Expression
;
5547 ------------------------------------------
5548 -- Check_Arg_Is_Task_Dispatching_Policy --
5549 ------------------------------------------
5551 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5552 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5555 Check_Arg_Is_Identifier
(Argx
);
5557 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5559 ("& is not an allowed task dispatching policy name", Argx
);
5561 end Check_Arg_Is_Task_Dispatching_Policy
;
5563 ---------------------
5564 -- Check_Arg_Order --
5565 ---------------------
5567 procedure Check_Arg_Order
(Names
: Name_List
) is
5570 Highest_So_Far
: Natural := 0;
5571 -- Highest index in Names seen do far
5575 for J
in 1 .. Arg_Count
loop
5576 if Chars
(Arg
) /= No_Name
then
5577 for K
in Names
'Range loop
5578 if Chars
(Arg
) = Names
(K
) then
5579 if K
< Highest_So_Far
then
5580 Error_Msg_Name_1
:= Pname
;
5582 ("parameters out of order for pragma%", Arg
);
5583 Error_Msg_Name_1
:= Names
(K
);
5584 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5585 Error_Msg_N
("\% must appear before %", Arg
);
5589 Highest_So_Far
:= K
;
5597 end Check_Arg_Order
;
5599 --------------------------------
5600 -- Check_At_Least_N_Arguments --
5601 --------------------------------
5603 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5605 if Arg_Count
< N
then
5606 Error_Pragma
("too few arguments for pragma%");
5608 end Check_At_Least_N_Arguments
;
5610 -------------------------------
5611 -- Check_At_Most_N_Arguments --
5612 -------------------------------
5614 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5617 if Arg_Count
> N
then
5619 for J
in 1 .. N
loop
5621 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5624 end Check_At_Most_N_Arguments
;
5626 ---------------------
5627 -- Check_Component --
5628 ---------------------
5630 procedure Check_Component
5633 In_Variant_Part
: Boolean := False)
5635 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5636 Sindic
: constant Node_Id
:=
5637 Subtype_Indication
(Component_Definition
(Comp
));
5638 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5641 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5642 -- object constraint, then the component type shall be an Unchecked_
5645 if Nkind
(Sindic
) = N_Subtype_Indication
5646 and then Has_Per_Object_Constraint
(Comp_Id
)
5647 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5650 ("component subtype subject to per-object constraint "
5651 & "must be an Unchecked_Union", Comp
);
5653 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5654 -- the body of a generic unit, or within the body of any of its
5655 -- descendant library units, no part of the type of a component
5656 -- declared in a variant_part of the unchecked union type shall be of
5657 -- a formal private type or formal private extension declared within
5658 -- the formal part of the generic unit.
5660 elsif Ada_Version
>= Ada_2012
5661 and then In_Generic_Body
(UU_Typ
)
5662 and then In_Variant_Part
5663 and then Is_Private_Type
(Typ
)
5664 and then Is_Generic_Type
(Typ
)
5667 ("component of unchecked union cannot be of generic type", Comp
);
5669 elsif Needs_Finalization
(Typ
) then
5671 ("component of unchecked union cannot be controlled", Comp
);
5673 elsif Has_Task
(Typ
) then
5675 ("component of unchecked union cannot have tasks", Comp
);
5677 end Check_Component
;
5679 ----------------------------
5680 -- Check_Duplicate_Pragma --
5681 ----------------------------
5683 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5684 Id
: Entity_Id
:= E
;
5688 -- Nothing to do if this pragma comes from an aspect specification,
5689 -- since we could not be duplicating a pragma, and we dealt with the
5690 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5692 if From_Aspect_Specification
(N
) then
5696 -- Otherwise current pragma may duplicate previous pragma or a
5697 -- previously given aspect specification or attribute definition
5698 -- clause for the same pragma.
5700 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5704 -- If the entity is a type, then we have to make sure that the
5705 -- ostensible duplicate is not for a parent type from which this
5709 if Nkind
(P
) = N_Pragma
then
5711 Args
: constant List_Id
:=
5712 Pragma_Argument_Associations
(P
);
5715 and then Is_Entity_Name
(Expression
(First
(Args
)))
5716 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5717 and then Entity
(Expression
(First
(Args
))) /= E
5723 elsif Nkind
(P
) = N_Aspect_Specification
5724 and then Is_Type
(Entity
(P
))
5725 and then Entity
(P
) /= E
5731 -- Here we have a definite duplicate
5733 Error_Msg_Name_1
:= Pragma_Name
(N
);
5734 Error_Msg_Sloc
:= Sloc
(P
);
5736 -- For a single protected or a single task object, the error is
5737 -- issued on the original entity.
5739 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5740 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5743 if Nkind
(P
) = N_Aspect_Specification
5744 or else From_Aspect_Specification
(P
)
5746 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5748 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5753 end Check_Duplicate_Pragma
;
5755 ----------------------------------
5756 -- Check_Duplicated_Export_Name --
5757 ----------------------------------
5759 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5760 String_Val
: constant String_Id
:= Strval
(Nam
);
5763 -- We are only interested in the export case, and in the case of
5764 -- generics, it is the instance, not the template, that is the
5765 -- problem (the template will generate a warning in any case).
5767 if not Inside_A_Generic
5768 and then (Prag_Id
= Pragma_Export
5770 Prag_Id
= Pragma_Export_Procedure
5772 Prag_Id
= Pragma_Export_Valued_Procedure
5774 Prag_Id
= Pragma_Export_Function
)
5776 for J
in Externals
.First
.. Externals
.Last
loop
5777 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5778 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5779 Error_Msg_N
("external name duplicates name given#", Nam
);
5784 Externals
.Append
(Nam
);
5786 end Check_Duplicated_Export_Name
;
5788 ----------------------------------------
5789 -- Check_Expr_Is_OK_Static_Expression --
5790 ----------------------------------------
5792 procedure Check_Expr_Is_OK_Static_Expression
5794 Typ
: Entity_Id
:= Empty
)
5797 if Present
(Typ
) then
5798 Analyze_And_Resolve
(Expr
, Typ
);
5800 Analyze_And_Resolve
(Expr
);
5803 -- An expression cannot be considered static if its resolution failed
5804 -- or if it's erroneous. Stop the analysis of the related pragma.
5806 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5809 elsif Is_OK_Static_Expression
(Expr
) then
5812 -- An interesting special case, if we have a string literal and we
5813 -- are in Ada 83 mode, then we allow it even though it will not be
5814 -- flagged as static. This allows the use of Ada 95 pragmas like
5815 -- Import in Ada 83 mode. They will of course be flagged with
5816 -- warnings as usual, but will not cause errors.
5818 elsif Ada_Version
= Ada_83
5819 and then Nkind
(Expr
) = N_String_Literal
5823 -- Finally, we have a real error
5826 Error_Msg_Name_1
:= Pname
;
5827 Flag_Non_Static_Expr
5828 (Fix_Error
("argument for pragma% must be a static expression!"),
5832 end Check_Expr_Is_OK_Static_Expression
;
5834 -------------------------
5835 -- Check_First_Subtype --
5836 -------------------------
5838 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5839 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5840 Ent
: constant Entity_Id
:= Entity
(Argx
);
5843 if Is_First_Subtype
(Ent
) then
5846 elsif Is_Type
(Ent
) then
5848 ("pragma% cannot apply to subtype", Argx
);
5850 elsif Is_Object
(Ent
) then
5852 ("pragma% cannot apply to object, requires a type", Argx
);
5856 ("pragma% cannot apply to&, requires a type", Argx
);
5858 end Check_First_Subtype
;
5860 ----------------------
5861 -- Check_Identifier --
5862 ----------------------
5864 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5867 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5869 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5870 Error_Msg_Name_1
:= Pname
;
5871 Error_Msg_Name_2
:= Id
;
5872 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5876 end Check_Identifier
;
5878 --------------------------------
5879 -- Check_Identifier_Is_One_Of --
5880 --------------------------------
5882 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5885 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5887 if Chars
(Arg
) = No_Name
then
5888 Error_Msg_Name_1
:= Pname
;
5889 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5892 elsif Chars
(Arg
) /= N1
5893 and then Chars
(Arg
) /= N2
5895 Error_Msg_Name_1
:= Pname
;
5896 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5900 end Check_Identifier_Is_One_Of
;
5902 ---------------------------
5903 -- Check_In_Main_Program --
5904 ---------------------------
5906 procedure Check_In_Main_Program
is
5907 P
: constant Node_Id
:= Parent
(N
);
5910 -- Must be in subprogram body
5912 if Nkind
(P
) /= N_Subprogram_Body
then
5913 Error_Pragma
("% pragma allowed only in subprogram");
5915 -- Otherwise warn if obviously not main program
5917 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5918 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5920 Error_Msg_Name_1
:= Pname
;
5922 ("??pragma% is only effective in main program", N
);
5924 end Check_In_Main_Program
;
5926 ---------------------------------------
5927 -- Check_Interrupt_Or_Attach_Handler --
5928 ---------------------------------------
5930 procedure Check_Interrupt_Or_Attach_Handler
is
5931 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5932 Handler_Proc
, Proc_Scope
: Entity_Id
;
5937 if Prag_Id
= Pragma_Interrupt_Handler
then
5938 Check_Restriction
(No_Dynamic_Attachment
, N
);
5941 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5942 Proc_Scope
:= Scope
(Handler_Proc
);
5944 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5946 ("argument of pragma% must be protected procedure", Arg1
);
5949 -- For pragma case (as opposed to access case), check placement.
5950 -- We don't need to do that for aspects, because we have the
5951 -- check that they aspect applies an appropriate procedure.
5953 if not From_Aspect_Specification
(N
)
5954 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5956 Error_Pragma
("pragma% must be in protected definition");
5959 if not Is_Library_Level_Entity
(Proc_Scope
) then
5961 ("argument for pragma% must be library level entity", Arg1
);
5964 -- AI05-0033: A pragma cannot appear within a generic body, because
5965 -- instance can be in a nested scope. The check that protected type
5966 -- is itself a library-level declaration is done elsewhere.
5968 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5969 -- handle code prior to AI-0033. Analysis tools typically are not
5970 -- interested in this pragma in any case, so no need to worry too
5971 -- much about its placement.
5973 if Inside_A_Generic
then
5974 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5975 and then In_Package_Body
(Scope
(Current_Scope
))
5976 and then not Relaxed_RM_Semantics
5978 Error_Pragma
("pragma% cannot be used inside a generic");
5981 end Check_Interrupt_Or_Attach_Handler
;
5983 ---------------------------------
5984 -- Check_Loop_Pragma_Placement --
5985 ---------------------------------
5987 procedure Check_Loop_Pragma_Placement
is
5988 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5989 -- Verify whether the current pragma is properly grouped with other
5990 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5991 -- related loop where the pragma appears.
5993 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5994 -- Determine whether an arbitrary statement Stmt denotes pragma
5995 -- Loop_Invariant or Loop_Variant.
5997 procedure Placement_Error
(Constr
: Node_Id
);
5998 pragma No_Return
(Placement_Error
);
5999 -- Node Constr denotes the last loop restricted construct before we
6000 -- encountered an illegal relation between enclosing constructs. Emit
6001 -- an error depending on what Constr was.
6003 --------------------------------
6004 -- Check_Loop_Pragma_Grouping --
6005 --------------------------------
6007 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6008 Stop_Search
: exception;
6009 -- This exception is used to terminate the recursive descent of
6010 -- routine Check_Grouping.
6012 procedure Check_Grouping
(L
: List_Id
);
6013 -- Find the first group of pragmas in list L and if successful,
6014 -- ensure that the current pragma is part of that group. The
6015 -- routine raises Stop_Search once such a check is performed to
6016 -- halt the recursive descent.
6018 procedure Grouping_Error
(Prag
: Node_Id
);
6019 pragma No_Return
(Grouping_Error
);
6020 -- Emit an error concerning the current pragma indicating that it
6021 -- should be placed after pragma Prag.
6023 --------------------
6024 -- Check_Grouping --
6025 --------------------
6027 procedure Check_Grouping
(L
: List_Id
) is
6030 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6033 -- Inspect the list of declarations or statements looking for
6034 -- the first grouping of pragmas:
6037 -- pragma Loop_Invariant ...;
6038 -- pragma Loop_Variant ...;
6040 -- pragma Loop_Variant ...; -- current pragma
6042 -- If the current pragma is not in the grouping, then it must
6043 -- either appear in a different declarative or statement list
6044 -- or the construct at (1) is separating the pragma from the
6048 while Present
(Stmt
) loop
6050 -- First pragma of the first topmost grouping has been found
6052 if Is_Loop_Pragma
(Stmt
) then
6054 -- The group and the current pragma are not in the same
6055 -- declarative or statement list.
6057 if List_Containing
(Stmt
) /= List_Containing
(N
) then
6058 Grouping_Error
(Stmt
);
6060 -- Try to reach the current pragma from the first pragma
6061 -- of the grouping while skipping other members:
6063 -- pragma Loop_Invariant ...; -- first pragma
6064 -- pragma Loop_Variant ...; -- member
6066 -- pragma Loop_Variant ...; -- current pragma
6069 while Present
(Stmt
) loop
6070 -- The current pragma is either the first pragma
6071 -- of the group or is a member of the group.
6072 -- Stop the search as the placement is legal.
6077 -- Skip group members, but keep track of the
6078 -- last pragma in the group.
6080 elsif Is_Loop_Pragma
(Stmt
) then
6083 -- Skip declarations and statements generated by
6084 -- the compiler during expansion. Note that some
6085 -- source statements (e.g. pragma Assert) may have
6086 -- been transformed so that they do not appear as
6087 -- coming from source anymore, so we instead look
6088 -- at their Original_Node.
6090 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6094 -- A non-pragma is separating the group from the
6095 -- current pragma, the placement is illegal.
6098 Grouping_Error
(Prag
);
6104 -- If the traversal did not reach the current pragma,
6105 -- then the list must be malformed.
6107 raise Program_Error
;
6110 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6111 -- inside a loop or a block housed inside a loop. Inspect
6112 -- the declarations and statements of the block as they may
6113 -- contain the first grouping. This case follows the one for
6114 -- loop pragmas, as block statements which originate in a
6115 -- loop pragma (and so Is_Loop_Pragma will return True on
6116 -- that block statement) should be treated in the previous
6119 elsif Nkind
(Stmt
) = N_Block_Statement
then
6120 HSS
:= Handled_Statement_Sequence
(Stmt
);
6122 Check_Grouping
(Declarations
(Stmt
));
6124 if Present
(HSS
) then
6125 Check_Grouping
(Statements
(HSS
));
6133 --------------------
6134 -- Grouping_Error --
6135 --------------------
6137 procedure Grouping_Error
(Prag
: Node_Id
) is
6139 Error_Msg_Sloc
:= Sloc
(Prag
);
6140 Error_Pragma
("pragma% must appear next to pragma#");
6143 -- Start of processing for Check_Loop_Pragma_Grouping
6146 -- Inspect the statements of the loop or nested blocks housed
6147 -- within to determine whether the current pragma is part of the
6148 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6150 Check_Grouping
(Statements
(Loop_Stmt
));
6153 when Stop_Search
=> null;
6154 end Check_Loop_Pragma_Grouping
;
6156 --------------------
6157 -- Is_Loop_Pragma --
6158 --------------------
6160 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6162 -- Inspect the original node as Loop_Invariant and Loop_Variant
6163 -- pragmas are rewritten to null when assertions are disabled.
6165 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
6167 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
6168 Name_Loop_Invariant
,
6175 ---------------------
6176 -- Placement_Error --
6177 ---------------------
6179 procedure Placement_Error
(Constr
: Node_Id
) is
6180 LA
: constant String := " with Loop_Entry";
6183 if Prag_Id
= Pragma_Assert
then
6184 Error_Msg_String
(1 .. LA
'Length) := LA
;
6185 Error_Msg_Strlen
:= LA
'Length;
6187 Error_Msg_Strlen
:= 0;
6190 if Nkind
(Constr
) = N_Pragma
then
6192 ("pragma %~ must appear immediately within the statements "
6196 ("block containing pragma %~ must appear immediately within "
6197 & "the statements of a loop", Constr
);
6199 end Placement_Error
;
6201 -- Local declarations
6206 -- Start of processing for Check_Loop_Pragma_Placement
6209 -- Check that pragma appears immediately within a loop statement,
6210 -- ignoring intervening block statements.
6214 while Present
(Stmt
) loop
6216 -- The pragma or previous block must appear immediately within the
6217 -- current block's declarative or statement part.
6219 if Nkind
(Stmt
) = N_Block_Statement
then
6220 if (No
(Declarations
(Stmt
))
6221 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6223 List_Containing
(Prev
) /=
6224 Statements
(Handled_Statement_Sequence
(Stmt
))
6226 Placement_Error
(Prev
);
6229 -- Keep inspecting the parents because we are now within a
6230 -- chain of nested blocks.
6234 Stmt
:= Parent
(Stmt
);
6237 -- The pragma or previous block must appear immediately within the
6238 -- statements of the loop.
6240 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6241 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6242 Placement_Error
(Prev
);
6245 -- Stop the traversal because we reached the innermost loop
6246 -- regardless of whether we encountered an error or not.
6250 -- Ignore a handled statement sequence. Note that this node may
6251 -- be related to a subprogram body in which case we will emit an
6252 -- error on the next iteration of the search.
6254 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6255 Stmt
:= Parent
(Stmt
);
6257 -- Any other statement breaks the chain from the pragma to the
6261 Placement_Error
(Prev
);
6266 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6267 -- grouped together with other such pragmas.
6269 if Is_Loop_Pragma
(N
) then
6271 -- The previous check should have located the related loop
6273 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6274 Check_Loop_Pragma_Grouping
(Stmt
);
6276 end Check_Loop_Pragma_Placement
;
6278 -------------------------------------------
6279 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6280 -------------------------------------------
6282 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6291 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6294 elsif Nkind_In
(P
, N_Package_Specification
,
6299 -- Note: the following tests seem a little peculiar, because
6300 -- they test for bodies, but if we were in the statement part
6301 -- of the body, we would already have hit the handled statement
6302 -- sequence, so the only way we get here is by being in the
6303 -- declarative part of the body.
6305 elsif Nkind_In
(P
, N_Subprogram_Body
,
6316 Error_Pragma
("pragma% is not in declarative part or package spec");
6317 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6319 -------------------------
6320 -- Check_No_Identifier --
6321 -------------------------
6323 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6325 if Nkind
(Arg
) = N_Pragma_Argument_Association
6326 and then Chars
(Arg
) /= No_Name
6328 Error_Pragma_Arg_Ident
6329 ("pragma% does not permit identifier& here", Arg
);
6331 end Check_No_Identifier
;
6333 --------------------------
6334 -- Check_No_Identifiers --
6335 --------------------------
6337 procedure Check_No_Identifiers
is
6341 for J
in 1 .. Arg_Count
loop
6342 Check_No_Identifier
(Arg_Node
);
6345 end Check_No_Identifiers
;
6347 ------------------------
6348 -- Check_No_Link_Name --
6349 ------------------------
6351 procedure Check_No_Link_Name
is
6353 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6357 if Present
(Arg4
) then
6359 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6361 end Check_No_Link_Name
;
6363 -------------------------------
6364 -- Check_Optional_Identifier --
6365 -------------------------------
6367 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6370 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6371 and then Chars
(Arg
) /= No_Name
6373 if Chars
(Arg
) /= Id
then
6374 Error_Msg_Name_1
:= Pname
;
6375 Error_Msg_Name_2
:= Id
;
6376 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6380 end Check_Optional_Identifier
;
6382 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6384 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6385 end Check_Optional_Identifier
;
6387 -------------------------------------
6388 -- Check_Static_Boolean_Expression --
6389 -------------------------------------
6391 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6393 if Present
(Expr
) then
6394 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6396 if not Is_OK_Static_Expression
(Expr
) then
6398 ("expression of pragma % must be static", Expr
);
6401 end Check_Static_Boolean_Expression
;
6403 -----------------------------
6404 -- Check_Static_Constraint --
6405 -----------------------------
6407 -- Note: for convenience in writing this procedure, in addition to
6408 -- the officially (i.e. by spec) allowed argument which is always a
6409 -- constraint, it also allows ranges and discriminant associations.
6410 -- Above is not clear ???
6412 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6414 procedure Require_Static
(E
: Node_Id
);
6415 -- Require given expression to be static expression
6417 --------------------
6418 -- Require_Static --
6419 --------------------
6421 procedure Require_Static
(E
: Node_Id
) is
6423 if not Is_OK_Static_Expression
(E
) then
6424 Flag_Non_Static_Expr
6425 ("non-static constraint not allowed in Unchecked_Union!", E
);
6430 -- Start of processing for Check_Static_Constraint
6433 case Nkind
(Constr
) is
6434 when N_Discriminant_Association
=>
6435 Require_Static
(Expression
(Constr
));
6438 Require_Static
(Low_Bound
(Constr
));
6439 Require_Static
(High_Bound
(Constr
));
6441 when N_Attribute_Reference
=>
6442 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6443 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6445 when N_Range_Constraint
=>
6446 Check_Static_Constraint
(Range_Expression
(Constr
));
6448 when N_Index_Or_Discriminant_Constraint
=>
6452 IDC
:= First
(Constraints
(Constr
));
6453 while Present
(IDC
) loop
6454 Check_Static_Constraint
(IDC
);
6462 end Check_Static_Constraint
;
6464 --------------------------------------
6465 -- Check_Valid_Configuration_Pragma --
6466 --------------------------------------
6468 -- A configuration pragma must appear in the context clause of a
6469 -- compilation unit, and only other pragmas may precede it. Note that
6470 -- the test also allows use in a configuration pragma file.
6472 procedure Check_Valid_Configuration_Pragma
is
6474 if not Is_Configuration_Pragma
then
6475 Error_Pragma
("incorrect placement for configuration pragma%");
6477 end Check_Valid_Configuration_Pragma
;
6479 -------------------------------------
6480 -- Check_Valid_Library_Unit_Pragma --
6481 -------------------------------------
6483 procedure Check_Valid_Library_Unit_Pragma
is
6485 Parent_Node
: Node_Id
;
6486 Unit_Name
: Entity_Id
;
6487 Unit_Kind
: Node_Kind
;
6488 Unit_Node
: Node_Id
;
6489 Sindex
: Source_File_Index
;
6492 if not Is_List_Member
(N
) then
6496 Plist
:= List_Containing
(N
);
6497 Parent_Node
:= Parent
(Plist
);
6499 if Parent_Node
= Empty
then
6502 -- Case of pragma appearing after a compilation unit. In this case
6503 -- it must have an argument with the corresponding name and must
6504 -- be part of the following pragmas of its parent.
6506 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6507 if Plist
/= Pragmas_After
(Parent_Node
) then
6510 elsif Arg_Count
= 0 then
6512 ("argument required if outside compilation unit");
6515 Check_No_Identifiers
;
6516 Check_Arg_Count
(1);
6517 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6518 Unit_Kind
:= Nkind
(Unit_Node
);
6520 Analyze
(Get_Pragma_Arg
(Arg1
));
6522 if Unit_Kind
= N_Generic_Subprogram_Declaration
6523 or else Unit_Kind
= N_Subprogram_Declaration
6525 Unit_Name
:= Defining_Entity
(Unit_Node
);
6527 elsif Unit_Kind
in N_Generic_Instantiation
then
6528 Unit_Name
:= Defining_Entity
(Unit_Node
);
6531 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6534 if Chars
(Unit_Name
) /=
6535 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6538 ("pragma% argument is not current unit name", Arg1
);
6541 if Ekind
(Unit_Name
) = E_Package
6542 and then Present
(Renamed_Entity
(Unit_Name
))
6544 Error_Pragma
("pragma% not allowed for renamed package");
6548 -- Pragma appears other than after a compilation unit
6551 -- Here we check for the generic instantiation case and also
6552 -- for the case of processing a generic formal package. We
6553 -- detect these cases by noting that the Sloc on the node
6554 -- does not belong to the current compilation unit.
6556 Sindex
:= Source_Index
(Current_Sem_Unit
);
6558 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6559 Rewrite
(N
, Make_Null_Statement
(Loc
));
6562 -- If before first declaration, the pragma applies to the
6563 -- enclosing unit, and the name if present must be this name.
6565 elsif Is_Before_First_Decl
(N
, Plist
) then
6566 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6567 Unit_Kind
:= Nkind
(Unit_Node
);
6569 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6572 elsif Unit_Kind
= N_Subprogram_Body
6573 and then not Acts_As_Spec
(Unit_Node
)
6577 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6580 elsif Nkind
(Parent_Node
) = N_Package_Specification
6581 and then Plist
= Private_Declarations
(Parent_Node
)
6585 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6586 or else Nkind
(Parent_Node
) =
6587 N_Generic_Subprogram_Declaration
)
6588 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6592 elsif Arg_Count
> 0 then
6593 Analyze
(Get_Pragma_Arg
(Arg1
));
6595 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6597 ("name in pragma% must be enclosing unit", Arg1
);
6600 -- It is legal to have no argument in this context
6606 -- Error if not before first declaration. This is because a
6607 -- library unit pragma argument must be the name of a library
6608 -- unit (RM 10.1.5(7)), but the only names permitted in this
6609 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6610 -- generic subprogram declarations or generic instantiations.
6614 ("pragma% misplaced, must be before first declaration");
6618 end Check_Valid_Library_Unit_Pragma
;
6624 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6625 Clist
: constant Node_Id
:= Component_List
(Variant
);
6629 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6630 while Present
(Comp
) loop
6631 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6632 Next_Non_Pragma
(Comp
);
6636 ---------------------------
6637 -- Ensure_Aggregate_Form --
6638 ---------------------------
6640 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6641 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6642 Expr
: constant Node_Id
:= Expression
(Arg
);
6643 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6644 Comps
: List_Id
:= No_List
;
6645 Exprs
: List_Id
:= No_List
;
6646 Nam
: Name_Id
:= No_Name
;
6647 Nam_Loc
: Source_Ptr
;
6650 -- The pragma argument is in positional form:
6652 -- pragma Depends (Nam => ...)
6656 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6657 -- argument association.
6659 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6661 Nam_Loc
:= Sloc
(Arg
);
6663 -- Remove the pragma argument name as this will be captured in the
6666 Set_Chars
(Arg
, No_Name
);
6669 -- The argument is already in aggregate form, but the presence of a
6670 -- name causes this to be interpreted as named association which in
6671 -- turn must be converted into an aggregate.
6673 -- pragma Global (In_Out => (A, B, C))
6677 -- pragma Global ((In_Out => (A, B, C)))
6679 -- aggregate aggregate
6681 if Nkind
(Expr
) = N_Aggregate
then
6682 if Nam
= No_Name
then
6686 -- Do not transform a null argument into an aggregate as N_Null has
6687 -- special meaning in formal verification pragmas.
6689 elsif Nkind
(Expr
) = N_Null
then
6693 -- Everything comes from source if the original comes from source
6695 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6697 -- Positional argument is transformed into an aggregate with an
6698 -- Expressions list.
6700 if Nam
= No_Name
then
6701 Exprs
:= New_List
(Relocate_Node
(Expr
));
6703 -- An associative argument is transformed into an aggregate with
6704 -- Component_Associations.
6708 Make_Component_Association
(Loc
,
6709 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6710 Expression
=> Relocate_Node
(Expr
)));
6713 Set_Expression
(Arg
,
6714 Make_Aggregate
(Loc
,
6715 Component_Associations
=> Comps
,
6716 Expressions
=> Exprs
));
6718 -- Restore Comes_From_Source default
6720 Set_Comes_From_Source_Default
(CFSD
);
6721 end Ensure_Aggregate_Form
;
6727 procedure Error_Pragma
(Msg
: String) is
6729 Error_Msg_Name_1
:= Pname
;
6730 Error_Msg_N
(Fix_Error
(Msg
), N
);
6734 ----------------------
6735 -- Error_Pragma_Arg --
6736 ----------------------
6738 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6740 Error_Msg_Name_1
:= Pname
;
6741 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6743 end Error_Pragma_Arg
;
6745 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6747 Error_Msg_Name_1
:= Pname
;
6748 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6749 Error_Pragma_Arg
(Msg2
, Arg
);
6750 end Error_Pragma_Arg
;
6752 ----------------------------
6753 -- Error_Pragma_Arg_Ident --
6754 ----------------------------
6756 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6758 Error_Msg_Name_1
:= Pname
;
6759 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6761 end Error_Pragma_Arg_Ident
;
6763 ----------------------
6764 -- Error_Pragma_Ref --
6765 ----------------------
6767 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6769 Error_Msg_Name_1
:= Pname
;
6770 Error_Msg_Sloc
:= Sloc
(Ref
);
6771 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6773 end Error_Pragma_Ref
;
6775 ------------------------
6776 -- Find_Lib_Unit_Name --
6777 ------------------------
6779 function Find_Lib_Unit_Name
return Entity_Id
is
6781 -- Return inner compilation unit entity, for case of nested
6782 -- categorization pragmas. This happens in generic unit.
6784 if Nkind
(Parent
(N
)) = N_Package_Specification
6785 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6787 return Defining_Entity
(Parent
(N
));
6789 return Current_Scope
;
6791 end Find_Lib_Unit_Name
;
6793 ----------------------------
6794 -- Find_Program_Unit_Name --
6795 ----------------------------
6797 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6798 Unit_Name
: Entity_Id
;
6799 Unit_Kind
: Node_Kind
;
6800 P
: constant Node_Id
:= Parent
(N
);
6803 if Nkind
(P
) = N_Compilation_Unit
then
6804 Unit_Kind
:= Nkind
(Unit
(P
));
6806 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6807 N_Package_Declaration
)
6808 or else Unit_Kind
in N_Generic_Declaration
6810 Unit_Name
:= Defining_Entity
(Unit
(P
));
6812 if Chars
(Id
) = Chars
(Unit_Name
) then
6813 Set_Entity
(Id
, Unit_Name
);
6814 Set_Etype
(Id
, Etype
(Unit_Name
));
6816 Set_Etype
(Id
, Any_Type
);
6818 ("cannot find program unit referenced by pragma%");
6822 Set_Etype
(Id
, Any_Type
);
6823 Error_Pragma
("pragma% inapplicable to this unit");
6829 end Find_Program_Unit_Name
;
6831 -----------------------------------------
6832 -- Find_Unique_Parameterless_Procedure --
6833 -----------------------------------------
6835 function Find_Unique_Parameterless_Procedure
6837 Arg
: Node_Id
) return Entity_Id
6839 Proc
: Entity_Id
:= Empty
;
6842 -- The body of this procedure needs some comments ???
6844 if not Is_Entity_Name
(Name
) then
6846 ("argument of pragma% must be entity name", Arg
);
6848 elsif not Is_Overloaded
(Name
) then
6849 Proc
:= Entity
(Name
);
6851 if Ekind
(Proc
) /= E_Procedure
6852 or else Present
(First_Formal
(Proc
))
6855 ("argument of pragma% must be parameterless procedure", Arg
);
6860 Found
: Boolean := False;
6862 Index
: Interp_Index
;
6865 Get_First_Interp
(Name
, Index
, It
);
6866 while Present
(It
.Nam
) loop
6869 if Ekind
(Proc
) = E_Procedure
6870 and then No
(First_Formal
(Proc
))
6874 Set_Entity
(Name
, Proc
);
6875 Set_Is_Overloaded
(Name
, False);
6878 ("ambiguous handler name for pragma% ", Arg
);
6882 Get_Next_Interp
(Index
, It
);
6887 ("argument of pragma% must be parameterless procedure",
6890 Proc
:= Entity
(Name
);
6896 end Find_Unique_Parameterless_Procedure
;
6902 function Fix_Error
(Msg
: String) return String is
6903 Res
: String (Msg
'Range) := Msg
;
6904 Res_Last
: Natural := Msg
'Last;
6908 -- If we have a rewriting of another pragma, go to that pragma
6910 if Is_Rewrite_Substitution
(N
)
6911 and then Nkind
(Original_Node
(N
)) = N_Pragma
6913 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6916 -- Case where pragma comes from an aspect specification
6918 if From_Aspect_Specification
(N
) then
6920 -- Change appearence of "pragma" in message to "aspect"
6923 while J
<= Res_Last
- 5 loop
6924 if Res
(J
.. J
+ 5) = "pragma" then
6925 Res
(J
.. J
+ 5) := "aspect";
6933 -- Change "argument of" at start of message to "entity for"
6936 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6938 Res
(Res
'First .. Res
'First + 9) := "entity for";
6939 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6940 Res
(Res
'First + 11 .. Res_Last
);
6941 Res_Last
:= Res_Last
- 1;
6944 -- Change "argument" at start of message to "entity"
6947 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6949 Res
(Res
'First .. Res
'First + 5) := "entity";
6950 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6951 Res
(Res
'First + 8 .. Res_Last
);
6952 Res_Last
:= Res_Last
- 2;
6955 -- Get name from corresponding aspect
6957 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6960 -- Return possibly modified message
6962 return Res
(Res
'First .. Res_Last
);
6965 -------------------------
6966 -- Gather_Associations --
6967 -------------------------
6969 procedure Gather_Associations
6971 Args
: out Args_List
)
6976 -- Initialize all parameters to Empty
6978 for J
in Args
'Range loop
6982 -- That's all we have to do if there are no argument associations
6984 if No
(Pragma_Argument_Associations
(N
)) then
6988 -- Otherwise first deal with any positional parameters present
6990 Arg
:= First
(Pragma_Argument_Associations
(N
));
6991 for Index
in Args
'Range loop
6992 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6993 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6997 -- Positional parameters all processed, if any left, then we
6998 -- have too many positional parameters.
7000 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
7002 ("too many positional associations for pragma%", Arg
);
7005 -- Process named parameters if any are present
7007 while Present
(Arg
) loop
7008 if Chars
(Arg
) = No_Name
then
7010 ("positional association cannot follow named association",
7014 for Index
in Names
'Range loop
7015 if Names
(Index
) = Chars
(Arg
) then
7016 if Present
(Args
(Index
)) then
7018 ("duplicate argument association for pragma%", Arg
);
7020 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7025 if Index
= Names
'Last then
7026 Error_Msg_Name_1
:= Pname
;
7027 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7029 -- Check for possible misspelling
7031 for Index1
in Names
'Range loop
7032 if Is_Bad_Spelling_Of
7033 (Chars
(Arg
), Names
(Index1
))
7035 Error_Msg_Name_1
:= Names
(Index1
);
7036 Error_Msg_N
-- CODEFIX
7037 ("\possible misspelling of%", Arg
);
7049 end Gather_Associations
;
7055 procedure GNAT_Pragma
is
7057 -- We need to check the No_Implementation_Pragmas restriction for
7058 -- the case of a pragma from source. Note that the case of aspects
7059 -- generating corresponding pragmas marks these pragmas as not being
7060 -- from source, so this test also catches that case.
7062 if Comes_From_Source
(N
) then
7063 Check_Restriction
(No_Implementation_Pragmas
, N
);
7067 --------------------------
7068 -- Is_Before_First_Decl --
7069 --------------------------
7071 function Is_Before_First_Decl
7072 (Pragma_Node
: Node_Id
;
7073 Decls
: List_Id
) return Boolean
7075 Item
: Node_Id
:= First
(Decls
);
7078 -- Only other pragmas can come before this pragma
7081 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
7084 elsif Item
= Pragma_Node
then
7090 end Is_Before_First_Decl
;
7092 -----------------------------
7093 -- Is_Configuration_Pragma --
7094 -----------------------------
7096 -- A configuration pragma must appear in the context clause of a
7097 -- compilation unit, and only other pragmas may precede it. Note that
7098 -- the test below also permits use in a configuration pragma file.
7100 function Is_Configuration_Pragma
return Boolean is
7101 Lis
: constant List_Id
:= List_Containing
(N
);
7102 Par
: constant Node_Id
:= Parent
(N
);
7106 -- If no parent, then we are in the configuration pragma file,
7107 -- so the placement is definitely appropriate.
7112 -- Otherwise we must be in the context clause of a compilation unit
7113 -- and the only thing allowed before us in the context list is more
7114 -- configuration pragmas.
7116 elsif Nkind
(Par
) = N_Compilation_Unit
7117 and then Context_Items
(Par
) = Lis
7124 elsif Nkind
(Prg
) /= N_Pragma
then
7134 end Is_Configuration_Pragma
;
7136 --------------------------
7137 -- Is_In_Context_Clause --
7138 --------------------------
7140 function Is_In_Context_Clause
return Boolean is
7142 Parent_Node
: Node_Id
;
7145 if not Is_List_Member
(N
) then
7149 Plist
:= List_Containing
(N
);
7150 Parent_Node
:= Parent
(Plist
);
7152 if Parent_Node
= Empty
7153 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
7154 or else Context_Items
(Parent_Node
) /= Plist
7161 end Is_In_Context_Clause
;
7163 ---------------------------------
7164 -- Is_Static_String_Expression --
7165 ---------------------------------
7167 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7168 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7169 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7172 Analyze_And_Resolve
(Argx
);
7174 -- Special case Ada 83, where the expression will never be static,
7175 -- but we will return true if we had a string literal to start with.
7177 if Ada_Version
= Ada_83
then
7180 -- Normal case, true only if we end up with a string literal that
7181 -- is marked as being the result of evaluating a static expression.
7184 return Is_OK_Static_Expression
(Argx
)
7185 and then Nkind
(Argx
) = N_String_Literal
;
7188 end Is_Static_String_Expression
;
7190 ----------------------
7191 -- Pragma_Misplaced --
7192 ----------------------
7194 procedure Pragma_Misplaced
is
7196 Error_Pragma
("incorrect placement of pragma%");
7197 end Pragma_Misplaced
;
7199 ------------------------------------------------
7200 -- Process_Atomic_Independent_Shared_Volatile --
7201 ------------------------------------------------
7203 procedure Process_Atomic_Independent_Shared_Volatile
is
7204 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
7205 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7207 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7208 -- Appropriately set flags on the given entity (either an array or
7209 -- record component, or an object declaration) according to the
7212 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7213 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7214 -- no explicit alignment was given, set alignment to unknown, since
7215 -- back end knows what the alignment requirements are for atomic and
7216 -- full access arrays. Note: this is necessary for derived types.
7218 -------------------------
7219 -- Check_VFA_Conflicts --
7220 -------------------------
7222 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7226 VFA_And_Atomic
: Boolean := False;
7227 -- Set True if atomic component present
7229 VFA_And_Aliased
: Boolean := False;
7230 -- Set True if aliased component present
7233 -- Fetch the type in case we are dealing with an object or
7236 if Is_Type
(Ent
) then
7239 pragma Assert
(Is_Object
(Ent
)
7241 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7246 -- Check Atomic and VFA used together
7248 if Prag_Id
= Pragma_Volatile_Full_Access
7249 or else Is_Volatile_Full_Access
(Ent
)
7251 if Prag_Id
= Pragma_Atomic
7252 or else Prag_Id
= Pragma_Shared
7253 or else Is_Atomic
(Ent
)
7255 VFA_And_Atomic
:= True;
7257 elsif Is_Array_Type
(Typ
) then
7258 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7260 -- Note: Has_Atomic_Components is not used below, as this flag
7261 -- represents the pragma of the same name, Atomic_Components,
7262 -- which only applies to arrays.
7264 elsif Is_Record_Type
(Typ
) then
7265 -- Attributes cannot be applied to discriminants, only
7266 -- regular record components.
7268 Comp
:= First_Component
(Typ
);
7269 while Present
(Comp
) loop
7271 or else Is_Atomic
(Typ
)
7273 VFA_And_Atomic
:= True;
7278 Next_Component
(Comp
);
7282 if VFA_And_Atomic
then
7284 ("cannot have Volatile_Full_Access and Atomic for same "
7289 -- Check for the application of VFA to an entity that has aliased
7292 if Prag_Id
= Pragma_Volatile_Full_Access
then
7293 if Is_Array_Type
(Typ
)
7294 and then Has_Aliased_Components
(Typ
)
7296 VFA_And_Aliased
:= True;
7298 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7299 -- and Has_Independent_Components, applies only to arrays.
7300 -- However, this flag does not have a corresponding pragma, so
7301 -- perhaps it should be possible to apply it to record types as
7302 -- well. Should this be done ???
7304 elsif Is_Record_Type
(Typ
) then
7305 -- It is possible to have an aliased discriminant, so they
7306 -- must be checked along with normal components.
7308 Comp
:= First_Component_Or_Discriminant
(Typ
);
7309 while Present
(Comp
) loop
7310 if Is_Aliased
(Comp
)
7311 or else Is_Aliased
(Etype
(Comp
))
7313 VFA_And_Aliased
:= True;
7314 Check_SPARK_05_Restriction
7315 ("aliased is not allowed", Comp
);
7320 Next_Component_Or_Discriminant
(Comp
);
7324 if VFA_And_Aliased
then
7326 ("cannot apply Volatile_Full_Access (aliased component "
7330 end Check_VFA_Conflicts
;
7332 ------------------------------
7333 -- Mark_Component_Or_Object --
7334 ------------------------------
7336 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7338 if Prag_Id
= Pragma_Atomic
7339 or else Prag_Id
= Pragma_Shared
7340 or else Prag_Id
= Pragma_Volatile_Full_Access
7342 if Prag_Id
= Pragma_Volatile_Full_Access
then
7343 Set_Is_Volatile_Full_Access
(Ent
);
7345 Set_Is_Atomic
(Ent
);
7348 -- If the object declaration has an explicit initialization, a
7349 -- temporary may have to be created to hold the expression, to
7350 -- ensure that access to the object remains atomic.
7352 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7353 and then Present
(Expression
(Parent
(Ent
)))
7355 Set_Has_Delayed_Freeze
(Ent
);
7359 -- Atomic/Shared/Volatile_Full_Access imply Independent
7361 if Prag_Id
/= Pragma_Volatile
then
7362 Set_Is_Independent
(Ent
);
7364 if Prag_Id
= Pragma_Independent
then
7365 Record_Independence_Check
(N
, Ent
);
7369 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7371 if Prag_Id
/= Pragma_Independent
then
7372 Set_Is_Volatile
(Ent
);
7373 Set_Treat_As_Volatile
(Ent
);
7375 end Mark_Component_Or_Object
;
7377 --------------------
7378 -- Set_Atomic_VFA --
7379 --------------------
7381 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7383 if Prag_Id
= Pragma_Volatile_Full_Access
then
7384 Set_Is_Volatile_Full_Access
(Ent
);
7386 Set_Is_Atomic
(Ent
);
7389 if not Has_Alignment_Clause
(Ent
) then
7390 Set_Alignment
(Ent
, Uint_0
);
7400 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7403 Check_Ada_83_Warning
;
7404 Check_No_Identifiers
;
7405 Check_Arg_Count
(1);
7406 Check_Arg_Is_Local_Name
(Arg1
);
7407 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7409 if Etype
(E_Arg
) = Any_Type
then
7413 E
:= Entity
(E_Arg
);
7415 -- A pragma that applies to a Ghost entity becomes Ghost for the
7416 -- purposes of legality checks and removal of ignored Ghost code.
7418 Mark_Ghost_Pragma
(N
, E
);
7420 -- Check duplicate before we chain ourselves
7422 Check_Duplicate_Pragma
(E
);
7424 -- Check appropriateness of the entity
7426 Decl
:= Declaration_Node
(E
);
7428 -- Deal with the case where the pragma/attribute is applied to a type
7431 if Rep_Item_Too_Early
(E
, N
)
7432 or else Rep_Item_Too_Late
(E
, N
)
7436 Check_First_Subtype
(Arg1
);
7439 -- Attribute belongs on the base type. If the view of the type is
7440 -- currently private, it also belongs on the underlying type.
7442 if Prag_Id
= Pragma_Atomic
7443 or else Prag_Id
= Pragma_Shared
7444 or else Prag_Id
= Pragma_Volatile_Full_Access
7447 Set_Atomic_VFA
(Base_Type
(E
));
7448 Set_Atomic_VFA
(Underlying_Type
(E
));
7451 -- Atomic/Shared/Volatile_Full_Access imply Independent
7453 if Prag_Id
/= Pragma_Volatile
then
7454 Set_Is_Independent
(E
);
7455 Set_Is_Independent
(Base_Type
(E
));
7456 Set_Is_Independent
(Underlying_Type
(E
));
7458 if Prag_Id
= Pragma_Independent
then
7459 Record_Independence_Check
(N
, Base_Type
(E
));
7463 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7465 if Prag_Id
/= Pragma_Independent
then
7466 Set_Is_Volatile
(E
);
7467 Set_Is_Volatile
(Base_Type
(E
));
7468 Set_Is_Volatile
(Underlying_Type
(E
));
7470 Set_Treat_As_Volatile
(E
);
7471 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7474 -- Apply Volatile to the composite type's individual components,
7477 if Prag_Id
= Pragma_Volatile
7478 and then Is_Record_Type
(Etype
(E
))
7483 Comp
:= First_Component
(E
);
7484 while Present
(Comp
) loop
7485 Mark_Component_Or_Object
(Comp
);
7487 Next_Component
(Comp
);
7492 -- Deal with the case where the pragma/attribute applies to a
7493 -- component or object declaration.
7495 elsif Nkind
(Decl
) = N_Object_Declaration
7496 or else (Nkind
(Decl
) = N_Component_Declaration
7497 and then Original_Record_Component
(E
) = E
)
7499 if Rep_Item_Too_Late
(E
, N
) then
7503 Mark_Component_Or_Object
(E
);
7505 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7508 -- Perform the checks needed to assure the proper use of the GNAT
7509 -- pragma Volatile_Full_Access.
7511 Check_VFA_Conflicts
(E
);
7513 -- The following check is only relevant when SPARK_Mode is on as
7514 -- this is not a standard Ada legality rule. Pragma Volatile can
7515 -- only apply to a full type declaration or an object declaration
7516 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7517 -- untagged derived types that are rewritten as subtypes of their
7518 -- respective root types.
7521 and then Prag_Id
= Pragma_Volatile
7522 and then not Nkind_In
(Original_Node
(Decl
),
7523 N_Full_Type_Declaration
,
7524 N_Object_Declaration
,
7525 N_Single_Protected_Declaration
,
7526 N_Single_Task_Declaration
)
7529 ("argument of pragma % must denote a full type or object "
7530 & "declaration", Arg1
);
7532 end Process_Atomic_Independent_Shared_Volatile
;
7534 -------------------------------------------
7535 -- Process_Compile_Time_Warning_Or_Error --
7536 -------------------------------------------
7538 procedure Process_Compile_Time_Warning_Or_Error
is
7539 Validation_Needed
: Boolean := False;
7541 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7542 -- Tree visitor that checks if N is an attribute reference that can
7543 -- be statically computed by the back end. Validation_Needed is set
7544 -- to True if found.
7550 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7552 if Nkind
(N
) = N_Attribute_Reference
7553 and then Is_Entity_Name
(Prefix
(N
))
7554 and then not Is_Generic_Unit
(Scope
(Entity
(Prefix
(N
))))
7557 Attr_Id
: constant Attribute_Id
:=
7558 Get_Attribute_Id
(Attribute_Name
(N
));
7560 if Attr_Id
= Attribute_Alignment
7561 or else Attr_Id
= Attribute_Size
7563 Validation_Needed
:= True;
7571 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7575 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7577 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7580 -- In GNATprove mode, pragmas Compile_Time_Error and
7581 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7582 -- same information as the compiler (in particular regarding size of
7583 -- objects decided in gigi) so it makes no sense to issue an error or
7584 -- warning in GNATprove.
7586 if GNATprove_Mode
then
7587 Rewrite
(N
, Make_Null_Statement
(Loc
));
7591 Check_Arg_Count
(2);
7592 Check_No_Identifiers
;
7593 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7594 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7596 if Compile_Time_Known_Value
(Arg1x
) then
7597 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7599 -- Register the expression for its validation after the back end has
7600 -- been called if it has occurrences of attributes Size or Alignment
7601 -- (because they may be statically computed by the back end and hence
7602 -- the whole expression needs to be reevaluated).
7605 Check_Expression
(Arg1x
);
7607 if Validation_Needed
then
7608 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7611 end Process_Compile_Time_Warning_Or_Error
;
7613 ------------------------
7614 -- Process_Convention --
7615 ------------------------
7617 procedure Process_Convention
7618 (C
: out Convention_Id
;
7619 Ent
: out Entity_Id
)
7623 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7624 -- Called if we have more than one Export/Import/Convention pragma.
7625 -- This is generally illegal, but we have a special case of allowing
7626 -- Import and Interface to coexist if they specify the convention in
7627 -- a consistent manner. We are allowed to do this, since Interface is
7628 -- an implementation defined pragma, and we choose to do it since we
7629 -- know Rational allows this combination. S is the entity id of the
7630 -- subprogram in question. This procedure also sets the special flag
7631 -- Import_Interface_Present in both pragmas in the case where we do
7632 -- have matching Import and Interface pragmas.
7634 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7635 -- Set convention in entity E, and also flag that the entity has a
7636 -- convention pragma. If entity is for a private or incomplete type,
7637 -- also set convention and flag on underlying type. This procedure
7638 -- also deals with the special case of C_Pass_By_Copy convention,
7639 -- and error checks for inappropriate convention specification.
7641 -------------------------------
7642 -- Diagnose_Multiple_Pragmas --
7643 -------------------------------
7645 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7646 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7650 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7651 -- Decl is a pragma node. This function returns True if this
7652 -- pragma has a first argument that is an identifier with a
7653 -- Chars field corresponding to the Convention_Id C.
7655 function Same_Name
(Decl
: Node_Id
) return Boolean;
7656 -- Decl is a pragma node. This function returns True if this
7657 -- pragma has a second argument that is an identifier with a
7658 -- Chars field that matches the Chars of the current subprogram.
7660 ---------------------
7661 -- Same_Convention --
7662 ---------------------
7664 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7665 Arg1
: constant Node_Id
:=
7666 First
(Pragma_Argument_Associations
(Decl
));
7669 if Present
(Arg1
) then
7671 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7673 if Nkind
(Arg
) = N_Identifier
7674 and then Is_Convention_Name
(Chars
(Arg
))
7675 and then Get_Convention_Id
(Chars
(Arg
)) = C
7683 end Same_Convention
;
7689 function Same_Name
(Decl
: Node_Id
) return Boolean is
7690 Arg1
: constant Node_Id
:=
7691 First
(Pragma_Argument_Associations
(Decl
));
7699 Arg2
:= Next
(Arg1
);
7706 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7708 if Nkind
(Arg
) = N_Identifier
7709 and then Chars
(Arg
) = Chars
(S
)
7718 -- Start of processing for Diagnose_Multiple_Pragmas
7723 -- Definitely give message if we have Convention/Export here
7725 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7728 -- If we have an Import or Export, scan back from pragma to
7729 -- find any previous pragma applying to the same procedure.
7730 -- The scan will be terminated by the start of the list, or
7731 -- hitting the subprogram declaration. This won't allow one
7732 -- pragma to appear in the public part and one in the private
7733 -- part, but that seems very unlikely in practice.
7737 while Present
(Decl
) and then Decl
/= Pdec
loop
7739 -- Look for pragma with same name as us
7741 if Nkind
(Decl
) = N_Pragma
7742 and then Same_Name
(Decl
)
7744 -- Give error if same as our pragma or Export/Convention
7746 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7749 Pragma_Name_Unmapped
(N
))
7753 -- Case of Import/Interface or the other way round
7755 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7756 Name_Interface
, Name_Import
)
7758 -- Here we know that we have Import and Interface. It
7759 -- doesn't matter which way round they are. See if
7760 -- they specify the same convention. If so, all OK,
7761 -- and set special flags to stop other messages
7763 if Same_Convention
(Decl
) then
7764 Set_Import_Interface_Present
(N
);
7765 Set_Import_Interface_Present
(Decl
);
7768 -- If different conventions, special message
7771 Error_Msg_Sloc
:= Sloc
(Decl
);
7773 ("convention differs from that given#", Arg1
);
7783 -- Give message if needed if we fall through those tests
7784 -- except on Relaxed_RM_Semantics where we let go: either this
7785 -- is a case accepted/ignored by other Ada compilers (e.g.
7786 -- a mix of Convention and Import), or another error will be
7787 -- generated later (e.g. using both Import and Export).
7789 if Err
and not Relaxed_RM_Semantics
then
7791 ("at most one Convention/Export/Import pragma is allowed",
7794 end Diagnose_Multiple_Pragmas
;
7796 --------------------------------
7797 -- Set_Convention_From_Pragma --
7798 --------------------------------
7800 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7802 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7803 -- for an overridden dispatching operation. Technically this is
7804 -- an amendment and should only be done in Ada 2005 mode. However,
7805 -- this is clearly a mistake, since the problem that is addressed
7806 -- by this AI is that there is a clear gap in the RM.
7808 if Is_Dispatching_Operation
(E
)
7809 and then Present
(Overridden_Operation
(E
))
7810 and then C
/= Convention
(Overridden_Operation
(E
))
7813 ("cannot change convention for overridden dispatching "
7814 & "operation", Arg1
);
7817 -- Special checks for Convention_Stdcall
7819 if C
= Convention_Stdcall
then
7821 -- A dispatching call is not allowed. A dispatching subprogram
7822 -- cannot be used to interface to the Win32 API, so in fact
7823 -- this check does not impose any effective restriction.
7825 if Is_Dispatching_Operation
(E
) then
7826 Error_Msg_Sloc
:= Sloc
(E
);
7828 -- Note: make this unconditional so that if there is more
7829 -- than one call to which the pragma applies, we get a
7830 -- message for each call. Also don't use Error_Pragma,
7831 -- so that we get multiple messages.
7834 ("dispatching subprogram# cannot use Stdcall convention!",
7837 -- Several allowed cases
7839 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7843 or else Ekind
(E
) = E_Variable
7845 -- A component as well. The entity does not have its Ekind
7846 -- set until the enclosing record declaration is fully
7849 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7851 -- An access to subprogram is also allowed
7855 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7857 -- Allow internal call to set convention of subprogram type
7859 or else Ekind
(E
) = E_Subprogram_Type
7865 ("second argument of pragma% must be subprogram (type)",
7870 -- Set the convention
7872 Set_Convention
(E
, C
);
7873 Set_Has_Convention_Pragma
(E
);
7875 -- For the case of a record base type, also set the convention of
7876 -- any anonymous access types declared in the record which do not
7877 -- currently have a specified convention.
7879 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7884 Comp
:= First_Component
(E
);
7885 while Present
(Comp
) loop
7886 if Present
(Etype
(Comp
))
7887 and then Ekind_In
(Etype
(Comp
),
7888 E_Anonymous_Access_Type
,
7889 E_Anonymous_Access_Subprogram_Type
)
7890 and then not Has_Convention_Pragma
(Comp
)
7892 Set_Convention
(Comp
, C
);
7895 Next_Component
(Comp
);
7900 -- Deal with incomplete/private type case, where underlying type
7901 -- is available, so set convention of that underlying type.
7903 if Is_Incomplete_Or_Private_Type
(E
)
7904 and then Present
(Underlying_Type
(E
))
7906 Set_Convention
(Underlying_Type
(E
), C
);
7907 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7910 -- A class-wide type should inherit the convention of the specific
7911 -- root type (although this isn't specified clearly by the RM).
7913 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7914 Set_Convention
(Class_Wide_Type
(E
), C
);
7917 -- If the entity is a record type, then check for special case of
7918 -- C_Pass_By_Copy, which is treated the same as C except that the
7919 -- special record flag is set. This convention is only permitted
7920 -- on record types (see AI95-00131).
7922 if Cname
= Name_C_Pass_By_Copy
then
7923 if Is_Record_Type
(E
) then
7924 Set_C_Pass_By_Copy
(Base_Type
(E
));
7925 elsif Is_Incomplete_Or_Private_Type
(E
)
7926 and then Is_Record_Type
(Underlying_Type
(E
))
7928 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7931 ("C_Pass_By_Copy convention allowed only for record type",
7936 -- If the entity is a derived boolean type, check for the special
7937 -- case of convention C, C++, or Fortran, where we consider any
7938 -- nonzero value to represent true.
7940 if Is_Discrete_Type
(E
)
7941 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7947 C
= Convention_Fortran
)
7949 Set_Nonzero_Is_True
(Base_Type
(E
));
7951 end Set_Convention_From_Pragma
;
7955 Comp_Unit
: Unit_Number_Type
;
7960 -- Start of processing for Process_Convention
7963 Check_At_Least_N_Arguments
(2);
7964 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7965 Check_Arg_Is_Identifier
(Arg1
);
7966 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7968 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7969 -- tested again below to set the critical flag).
7971 if Cname
= Name_C_Pass_By_Copy
then
7974 -- Otherwise we must have something in the standard convention list
7976 elsif Is_Convention_Name
(Cname
) then
7977 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7979 -- Otherwise warn on unrecognized convention
7982 if Warn_On_Export_Import
then
7984 ("??unrecognized convention name, C assumed",
7985 Get_Pragma_Arg
(Arg1
));
7991 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7992 Check_Arg_Is_Local_Name
(Arg2
);
7994 Id
:= Get_Pragma_Arg
(Arg2
);
7997 if not Is_Entity_Name
(Id
) then
7998 Error_Pragma_Arg
("entity name required", Arg2
);
8003 -- Set entity to return
8007 -- Ada_Pass_By_Copy special checking
8009 if C
= Convention_Ada_Pass_By_Copy
then
8010 if not Is_First_Subtype
(E
) then
8012 ("convention `Ada_Pass_By_Copy` only allowed for types",
8016 if Is_By_Reference_Type
(E
) then
8018 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8022 -- Ada_Pass_By_Reference special checking
8024 elsif C
= Convention_Ada_Pass_By_Reference
then
8025 if not Is_First_Subtype
(E
) then
8027 ("convention `Ada_Pass_By_Reference` only allowed for types",
8031 if Is_By_Copy_Type
(E
) then
8033 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8038 -- Go to renamed subprogram if present, since convention applies to
8039 -- the actual renamed entity, not to the renaming entity. If the
8040 -- subprogram is inherited, go to parent subprogram.
8042 if Is_Subprogram
(E
)
8043 and then Present
(Alias
(E
))
8045 if Nkind
(Parent
(Declaration_Node
(E
))) =
8046 N_Subprogram_Renaming_Declaration
8048 if Scope
(E
) /= Scope
(Alias
(E
)) then
8050 ("cannot apply pragma% to non-local entity&#", E
);
8055 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
8056 N_Private_Extension_Declaration
)
8057 and then Scope
(E
) = Scope
(Alias
(E
))
8061 -- Return the parent subprogram the entity was inherited from
8067 -- Check that we are not applying this to a specless body. Relax this
8068 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8070 if Is_Subprogram
(E
)
8071 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8072 and then not Relaxed_RM_Semantics
8075 ("pragma% requires separate spec and must come before body");
8078 -- Check that we are not applying this to a named constant
8080 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
8081 Error_Msg_Name_1
:= Pname
;
8083 ("cannot apply pragma% to named constant!",
8084 Get_Pragma_Arg
(Arg2
));
8086 ("\supply appropriate type for&!", Arg2
);
8089 if Ekind
(E
) = E_Enumeration_Literal
then
8090 Error_Pragma
("enumeration literal not allowed for pragma%");
8093 -- Check for rep item appearing too early or too late
8095 if Etype
(E
) = Any_Type
8096 or else Rep_Item_Too_Early
(E
, N
)
8100 elsif Present
(Underlying_Type
(E
)) then
8101 E
:= Underlying_Type
(E
);
8104 if Rep_Item_Too_Late
(E
, N
) then
8108 if Has_Convention_Pragma
(E
) then
8109 Diagnose_Multiple_Pragmas
(E
);
8111 elsif Convention
(E
) = Convention_Protected
8112 or else Ekind
(Scope
(E
)) = E_Protected_Type
8115 ("a protected operation cannot be given a different convention",
8119 -- For Intrinsic, a subprogram is required
8121 if C
= Convention_Intrinsic
8122 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8124 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8126 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8128 ("second argument of pragma% must be a subprogram", Arg2
);
8132 -- Deal with non-subprogram cases
8134 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8135 Set_Convention_From_Pragma
(E
);
8139 -- The pragma must apply to a first subtype, but it can also
8140 -- apply to a generic type in a generic formal part, in which
8141 -- case it will also appear in the corresponding instance.
8143 if Is_Generic_Type
(E
) or else In_Instance
then
8146 Check_First_Subtype
(Arg2
);
8149 Set_Convention_From_Pragma
(Base_Type
(E
));
8151 -- For access subprograms, we must set the convention on the
8152 -- internally generated directly designated type as well.
8154 if Ekind
(E
) = E_Access_Subprogram_Type
then
8155 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8159 -- For the subprogram case, set proper convention for all homonyms
8160 -- in same scope and the same declarative part, i.e. the same
8161 -- compilation unit.
8164 Comp_Unit
:= Get_Source_Unit
(E
);
8165 Set_Convention_From_Pragma
(E
);
8167 -- Treat a pragma Import as an implicit body, and pragma import
8168 -- as implicit reference (for navigation in GPS).
8170 if Prag_Id
= Pragma_Import
then
8171 Generate_Reference
(E
, Id
, 'b');
8173 -- For exported entities we restrict the generation of references
8174 -- to entities exported to foreign languages since entities
8175 -- exported to Ada do not provide further information to GPS and
8176 -- add undesired references to the output of the gnatxref tool.
8178 elsif Prag_Id
= Pragma_Export
8179 and then Convention
(E
) /= Convention_Ada
8181 Generate_Reference
(E
, Id
, 'i');
8184 -- If the pragma comes from an aspect, it only applies to the
8185 -- given entity, not its homonyms.
8187 if From_Aspect_Specification
(N
) then
8188 if C
= Convention_Intrinsic
8189 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8191 if Is_Fixed_Point_Type
(Etype
(Ent
))
8192 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8193 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8196 ("no intrinsic operator available for this fixed-point "
8199 ("\use expression functions with the desired "
8200 & "conversions made explicit", N
);
8207 -- Otherwise Loop through the homonyms of the pragma argument's
8208 -- entity, an apply convention to those in the current scope.
8214 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8216 -- Ignore entry for which convention is already set
8218 if Has_Convention_Pragma
(E1
) then
8222 if Is_Subprogram
(E1
)
8223 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8225 and then not Relaxed_RM_Semantics
8227 Set_Has_Completion
(E
); -- to prevent cascaded error
8229 ("pragma% requires separate spec and must come before "
8233 -- Do not set the pragma on inherited operations or on formal
8236 if Comes_From_Source
(E1
)
8237 and then Comp_Unit
= Get_Source_Unit
(E1
)
8238 and then not Is_Formal_Subprogram
(E1
)
8239 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8240 N_Full_Type_Declaration
8242 if Present
(Alias
(E1
))
8243 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8246 ("cannot apply pragma% to non-local entity& declared#",
8250 Set_Convention_From_Pragma
(E1
);
8252 if Prag_Id
= Pragma_Import
then
8253 Generate_Reference
(E1
, Id
, 'b');
8261 end Process_Convention
;
8263 ----------------------------------------
8264 -- Process_Disable_Enable_Atomic_Sync --
8265 ----------------------------------------
8267 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8269 Check_No_Identifiers
;
8270 Check_At_Most_N_Arguments
(1);
8272 -- Modeled internally as
8273 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8278 Pragma_Argument_Associations
=> New_List
(
8279 Make_Pragma_Argument_Association
(Loc
,
8281 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8283 if Present
(Arg1
) then
8284 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8288 end Process_Disable_Enable_Atomic_Sync
;
8290 -------------------------------------------------
8291 -- Process_Extended_Import_Export_Internal_Arg --
8292 -------------------------------------------------
8294 procedure Process_Extended_Import_Export_Internal_Arg
8295 (Arg_Internal
: Node_Id
:= Empty
)
8298 if No
(Arg_Internal
) then
8299 Error_Pragma
("Internal parameter required for pragma%");
8302 if Nkind
(Arg_Internal
) = N_Identifier
then
8305 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8306 and then (Prag_Id
= Pragma_Import_Function
8308 Prag_Id
= Pragma_Export_Function
)
8314 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8317 Check_Arg_Is_Local_Name
(Arg_Internal
);
8318 end Process_Extended_Import_Export_Internal_Arg
;
8320 --------------------------------------------------
8321 -- Process_Extended_Import_Export_Object_Pragma --
8322 --------------------------------------------------
8324 procedure Process_Extended_Import_Export_Object_Pragma
8325 (Arg_Internal
: Node_Id
;
8326 Arg_External
: Node_Id
;
8332 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8333 Def_Id
:= Entity
(Arg_Internal
);
8335 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8337 ("pragma% must designate an object", Arg_Internal
);
8340 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8342 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8345 ("previous Common/Psect_Object applies, pragma % not permitted",
8349 if Rep_Item_Too_Late
(Def_Id
, N
) then
8353 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8355 if Present
(Arg_Size
) then
8356 Check_Arg_Is_External_Name
(Arg_Size
);
8359 -- Export_Object case
8361 if Prag_Id
= Pragma_Export_Object
then
8362 if not Is_Library_Level_Entity
(Def_Id
) then
8364 ("argument for pragma% must be library level entity",
8368 if Ekind
(Current_Scope
) = E_Generic_Package
then
8369 Error_Pragma
("pragma& cannot appear in a generic unit");
8372 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8374 ("exported object must have compile time known size",
8378 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8379 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8381 Set_Exported
(Def_Id
, Arg_Internal
);
8384 -- Import_Object case
8387 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8389 ("cannot use pragma% for task/protected object",
8393 if Ekind
(Def_Id
) = E_Constant
then
8395 ("cannot import a constant", Arg_Internal
);
8398 if Warn_On_Export_Import
8399 and then Has_Discriminants
(Etype
(Def_Id
))
8402 ("imported value must be initialized??", Arg_Internal
);
8405 if Warn_On_Export_Import
8406 and then Is_Access_Type
(Etype
(Def_Id
))
8409 ("cannot import object of an access type??", Arg_Internal
);
8412 if Warn_On_Export_Import
8413 and then Is_Imported
(Def_Id
)
8415 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8417 -- Check for explicit initialization present. Note that an
8418 -- initialization generated by the code generator, e.g. for an
8419 -- access type, does not count here.
8421 elsif Present
(Expression
(Parent
(Def_Id
)))
8424 (Original_Node
(Expression
(Parent
(Def_Id
))))
8426 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8428 ("imported entities cannot be initialized (RM B.1(24))",
8429 "\no initialization allowed for & declared#", Arg1
);
8431 Set_Imported
(Def_Id
);
8432 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8435 end Process_Extended_Import_Export_Object_Pragma
;
8437 ------------------------------------------------------
8438 -- Process_Extended_Import_Export_Subprogram_Pragma --
8439 ------------------------------------------------------
8441 procedure Process_Extended_Import_Export_Subprogram_Pragma
8442 (Arg_Internal
: Node_Id
;
8443 Arg_External
: Node_Id
;
8444 Arg_Parameter_Types
: Node_Id
;
8445 Arg_Result_Type
: Node_Id
:= Empty
;
8446 Arg_Mechanism
: Node_Id
;
8447 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8453 Ambiguous
: Boolean;
8456 function Same_Base_Type
8458 Formal
: Entity_Id
) return Boolean;
8459 -- Determines if Ptype references the type of Formal. Note that only
8460 -- the base types need to match according to the spec. Ptype here is
8461 -- the argument from the pragma, which is either a type name, or an
8462 -- access attribute.
8464 --------------------
8465 -- Same_Base_Type --
8466 --------------------
8468 function Same_Base_Type
8470 Formal
: Entity_Id
) return Boolean
8472 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8476 -- Case where pragma argument is typ'Access
8478 if Nkind
(Ptype
) = N_Attribute_Reference
8479 and then Attribute_Name
(Ptype
) = Name_Access
8481 Pref
:= Prefix
(Ptype
);
8484 if not Is_Entity_Name
(Pref
)
8485 or else Entity
(Pref
) = Any_Type
8490 -- We have a match if the corresponding argument is of an
8491 -- anonymous access type, and its designated type matches the
8492 -- type of the prefix of the access attribute
8494 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8495 and then Base_Type
(Entity
(Pref
)) =
8496 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8498 -- Case where pragma argument is a type name
8503 if not Is_Entity_Name
(Ptype
)
8504 or else Entity
(Ptype
) = Any_Type
8509 -- We have a match if the corresponding argument is of the type
8510 -- given in the pragma (comparing base types)
8512 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8516 -- Start of processing for
8517 -- Process_Extended_Import_Export_Subprogram_Pragma
8520 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8524 -- Loop through homonyms (overloadings) of the entity
8526 Hom_Id
:= Entity
(Arg_Internal
);
8527 while Present
(Hom_Id
) loop
8528 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8530 -- We need a subprogram in the current scope
8532 if not Is_Subprogram
(Def_Id
)
8533 or else Scope
(Def_Id
) /= Current_Scope
8540 -- Pragma cannot apply to subprogram body
8542 if Is_Subprogram
(Def_Id
)
8543 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8547 ("pragma% requires separate spec and must come before "
8551 -- Test result type if given, note that the result type
8552 -- parameter can only be present for the function cases.
8554 if Present
(Arg_Result_Type
)
8555 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8559 elsif Etype
(Def_Id
) /= Standard_Void_Type
8560 and then Nam_In
(Pname
, Name_Export_Procedure
,
8561 Name_Import_Procedure
)
8565 -- Test parameter types if given. Note that this parameter has
8566 -- not been analyzed (and must not be, since it is semantic
8567 -- nonsense), so we get it as the parser left it.
8569 elsif Present
(Arg_Parameter_Types
) then
8570 Check_Matching_Types
: declare
8575 Formal
:= First_Formal
(Def_Id
);
8577 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8578 if Present
(Formal
) then
8582 -- A list of one type, e.g. (List) is parsed as a
8583 -- parenthesized expression.
8585 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8586 and then Paren_Count
(Arg_Parameter_Types
) = 1
8589 or else Present
(Next_Formal
(Formal
))
8594 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8597 -- A list of more than one type is parsed as a aggregate
8599 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8600 and then Paren_Count
(Arg_Parameter_Types
) = 0
8602 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8603 while Present
(Ptype
) or else Present
(Formal
) loop
8606 or else not Same_Base_Type
(Ptype
, Formal
)
8611 Next_Formal
(Formal
);
8616 -- Anything else is of the wrong form
8620 ("wrong form for Parameter_Types parameter",
8621 Arg_Parameter_Types
);
8623 end Check_Matching_Types
;
8626 -- Match is now False if the entry we found did not match
8627 -- either a supplied Parameter_Types or Result_Types argument
8633 -- Ambiguous case, the flag Ambiguous shows if we already
8634 -- detected this and output the initial messages.
8637 if not Ambiguous
then
8639 Error_Msg_Name_1
:= Pname
;
8641 ("pragma% does not uniquely identify subprogram!",
8643 Error_Msg_Sloc
:= Sloc
(Ent
);
8644 Error_Msg_N
("matching subprogram #!", N
);
8648 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8649 Error_Msg_N
("matching subprogram #!", N
);
8654 Hom_Id
:= Homonym
(Hom_Id
);
8657 -- See if we found an entry
8660 if not Ambiguous
then
8661 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8663 ("pragma% cannot be given for generic subprogram");
8666 ("pragma% does not identify local subprogram");
8673 -- Import pragmas must be for imported entities
8675 if Prag_Id
= Pragma_Import_Function
8677 Prag_Id
= Pragma_Import_Procedure
8679 Prag_Id
= Pragma_Import_Valued_Procedure
8681 if not Is_Imported
(Ent
) then
8683 ("pragma Import or Interface must precede pragma%");
8686 -- Here we have the Export case which can set the entity as exported
8688 -- But does not do so if the specified external name is null, since
8689 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8690 -- compatible) to request no external name.
8692 elsif Nkind
(Arg_External
) = N_String_Literal
8693 and then String_Length
(Strval
(Arg_External
)) = 0
8697 -- In all other cases, set entity as exported
8700 Set_Exported
(Ent
, Arg_Internal
);
8703 -- Special processing for Valued_Procedure cases
8705 if Prag_Id
= Pragma_Import_Valued_Procedure
8707 Prag_Id
= Pragma_Export_Valued_Procedure
8709 Formal
:= First_Formal
(Ent
);
8712 Error_Pragma
("at least one parameter required for pragma%");
8714 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8715 Error_Pragma
("first parameter must have mode out for pragma%");
8718 Set_Is_Valued_Procedure
(Ent
);
8722 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8724 -- Process Result_Mechanism argument if present. We have already
8725 -- checked that this is only allowed for the function case.
8727 if Present
(Arg_Result_Mechanism
) then
8728 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8731 -- Process Mechanism parameter if present. Note that this parameter
8732 -- is not analyzed, and must not be analyzed since it is semantic
8733 -- nonsense, so we get it in exactly as the parser left it.
8735 if Present
(Arg_Mechanism
) then
8743 -- A single mechanism association without a formal parameter
8744 -- name is parsed as a parenthesized expression. All other
8745 -- cases are parsed as aggregates, so we rewrite the single
8746 -- parameter case as an aggregate for consistency.
8748 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8749 and then Paren_Count
(Arg_Mechanism
) = 1
8751 Rewrite
(Arg_Mechanism
,
8752 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8753 Expressions
=> New_List
(
8754 Relocate_Node
(Arg_Mechanism
))));
8757 -- Case of only mechanism name given, applies to all formals
8759 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8760 Formal
:= First_Formal
(Ent
);
8761 while Present
(Formal
) loop
8762 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8763 Next_Formal
(Formal
);
8766 -- Case of list of mechanism associations given
8769 if Null_Record_Present
(Arg_Mechanism
) then
8771 ("inappropriate form for Mechanism parameter",
8775 -- Deal with positional ones first
8777 Formal
:= First_Formal
(Ent
);
8779 if Present
(Expressions
(Arg_Mechanism
)) then
8780 Mname
:= First
(Expressions
(Arg_Mechanism
));
8781 while Present
(Mname
) loop
8784 ("too many mechanism associations", Mname
);
8787 Set_Mechanism_Value
(Formal
, Mname
);
8788 Next_Formal
(Formal
);
8793 -- Deal with named entries
8795 if Present
(Component_Associations
(Arg_Mechanism
)) then
8796 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8797 while Present
(Massoc
) loop
8798 Choice
:= First
(Choices
(Massoc
));
8800 if Nkind
(Choice
) /= N_Identifier
8801 or else Present
(Next
(Choice
))
8804 ("incorrect form for mechanism association",
8808 Formal
:= First_Formal
(Ent
);
8812 ("parameter name & not present", Choice
);
8815 if Chars
(Choice
) = Chars
(Formal
) then
8817 (Formal
, Expression
(Massoc
));
8819 -- Set entity on identifier (needed by ASIS)
8821 Set_Entity
(Choice
, Formal
);
8826 Next_Formal
(Formal
);
8835 end Process_Extended_Import_Export_Subprogram_Pragma
;
8837 --------------------------
8838 -- Process_Generic_List --
8839 --------------------------
8841 procedure Process_Generic_List
is
8846 Check_No_Identifiers
;
8847 Check_At_Least_N_Arguments
(1);
8849 -- Check all arguments are names of generic units or instances
8852 while Present
(Arg
) loop
8853 Exp
:= Get_Pragma_Arg
(Arg
);
8856 if not Is_Entity_Name
(Exp
)
8858 (not Is_Generic_Instance
(Entity
(Exp
))
8860 not Is_Generic_Unit
(Entity
(Exp
)))
8863 ("pragma% argument must be name of generic unit/instance",
8869 end Process_Generic_List
;
8871 ------------------------------------
8872 -- Process_Import_Predefined_Type --
8873 ------------------------------------
8875 procedure Process_Import_Predefined_Type
is
8876 Loc
: constant Source_Ptr
:= Sloc
(N
);
8878 Ftyp
: Node_Id
:= Empty
;
8884 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8886 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8887 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8891 Ftyp
:= Node
(Elmt
);
8893 if Present
(Ftyp
) then
8895 -- Don't build a derived type declaration, because predefined C
8896 -- types have no declaration anywhere, so cannot really be named.
8897 -- Instead build a full type declaration, starting with an
8898 -- appropriate type definition is built
8900 if Is_Floating_Point_Type
(Ftyp
) then
8901 Def
:= Make_Floating_Point_Definition
(Loc
,
8902 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8903 Make_Real_Range_Specification
(Loc
,
8904 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8905 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8907 -- Should never have a predefined type we cannot handle
8910 raise Program_Error
;
8913 -- Build and insert a Full_Type_Declaration, which will be
8914 -- analyzed as soon as this list entry has been analyzed.
8916 Decl
:= Make_Full_Type_Declaration
(Loc
,
8917 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8918 Type_Definition
=> Def
);
8920 Insert_After
(N
, Decl
);
8921 Mark_Rewrite_Insertion
(Decl
);
8924 Error_Pragma_Arg
("no matching type found for pragma%",
8927 end Process_Import_Predefined_Type
;
8929 ---------------------------------
8930 -- Process_Import_Or_Interface --
8931 ---------------------------------
8933 procedure Process_Import_Or_Interface
is
8939 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8940 -- pragma Import (Entity, "external name");
8942 if Relaxed_RM_Semantics
8943 and then Arg_Count
= 2
8944 and then Prag_Id
= Pragma_Import
8945 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8948 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8951 if not Is_Entity_Name
(Def_Id
) then
8952 Error_Pragma_Arg
("entity name required", Arg1
);
8955 Def_Id
:= Entity
(Def_Id
);
8956 Kill_Size_Check_Code
(Def_Id
);
8957 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8960 Process_Convention
(C
, Def_Id
);
8962 -- A pragma that applies to a Ghost entity becomes Ghost for the
8963 -- purposes of legality checks and removal of ignored Ghost code.
8965 Mark_Ghost_Pragma
(N
, Def_Id
);
8966 Kill_Size_Check_Code
(Def_Id
);
8967 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8970 -- Various error checks
8972 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8974 -- We do not permit Import to apply to a renaming declaration
8976 if Present
(Renamed_Object
(Def_Id
)) then
8978 ("pragma% not allowed for object renaming", Arg2
);
8980 -- User initialization is not allowed for imported object, but
8981 -- the object declaration may contain a default initialization,
8982 -- that will be discarded. Note that an explicit initialization
8983 -- only counts if it comes from source, otherwise it is simply
8984 -- the code generator making an implicit initialization explicit.
8986 elsif Present
(Expression
(Parent
(Def_Id
)))
8987 and then Comes_From_Source
8988 (Original_Node
(Expression
(Parent
(Def_Id
))))
8990 -- Set imported flag to prevent cascaded errors
8992 Set_Is_Imported
(Def_Id
);
8994 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8996 ("no initialization allowed for declaration of& #",
8997 "\imported entities cannot be initialized (RM B.1(24))",
9001 -- If the pragma comes from an aspect specification the
9002 -- Is_Imported flag has already been set.
9004 if not From_Aspect_Specification
(N
) then
9005 Set_Imported
(Def_Id
);
9008 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9010 -- Note that we do not set Is_Public here. That's because we
9011 -- only want to set it if there is no address clause, and we
9012 -- don't know that yet, so we delay that processing till
9015 -- pragma Import completes deferred constants
9017 if Ekind
(Def_Id
) = E_Constant
then
9018 Set_Has_Completion
(Def_Id
);
9021 -- It is not possible to import a constant of an unconstrained
9022 -- array type (e.g. string) because there is no simple way to
9023 -- write a meaningful subtype for it.
9025 if Is_Array_Type
(Etype
(Def_Id
))
9026 and then not Is_Constrained
(Etype
(Def_Id
))
9029 ("imported constant& must have a constrained subtype",
9034 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9036 -- If the name is overloaded, pragma applies to all of the denoted
9037 -- entities in the same declarative part, unless the pragma comes
9038 -- from an aspect specification or was generated by the compiler
9039 -- (such as for pragma Provide_Shift_Operators).
9042 while Present
(Hom_Id
) loop
9044 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9046 -- Ignore inherited subprograms because the pragma will apply
9047 -- to the parent operation, which is the one called.
9049 if Is_Overloadable
(Def_Id
)
9050 and then Present
(Alias
(Def_Id
))
9054 -- If it is not a subprogram, it must be in an outer scope and
9055 -- pragma does not apply.
9057 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9060 -- The pragma does not apply to primitives of interfaces
9062 elsif Is_Dispatching_Operation
(Def_Id
)
9063 and then Present
(Find_Dispatching_Type
(Def_Id
))
9064 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9068 -- Verify that the homonym is in the same declarative part (not
9069 -- just the same scope). If the pragma comes from an aspect
9070 -- specification we know that it is part of the declaration.
9072 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
9073 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9074 and then not From_Aspect_Specification
(N
)
9079 -- If the pragma comes from an aspect specification the
9080 -- Is_Imported flag has already been set.
9082 if not From_Aspect_Specification
(N
) then
9083 Set_Imported
(Def_Id
);
9086 -- Reject an Import applied to an abstract subprogram
9088 if Is_Subprogram
(Def_Id
)
9089 and then Is_Abstract_Subprogram
(Def_Id
)
9091 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9093 ("cannot import abstract subprogram& declared#",
9097 -- Special processing for Convention_Intrinsic
9099 if C
= Convention_Intrinsic
then
9101 -- Link_Name argument not allowed for intrinsic
9105 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9107 -- If no external name is present, then check that this
9108 -- is a valid intrinsic subprogram. If an external name
9109 -- is present, then this is handled by the back end.
9112 Check_Intrinsic_Subprogram
9113 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9117 -- Verify that the subprogram does not have a completion
9118 -- through a renaming declaration. For other completions the
9119 -- pragma appears as a too late representation.
9122 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9126 and then Nkind
(Decl
) = N_Subprogram_Declaration
9127 and then Present
(Corresponding_Body
(Decl
))
9128 and then Nkind
(Unit_Declaration_Node
9129 (Corresponding_Body
(Decl
))) =
9130 N_Subprogram_Renaming_Declaration
9132 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9134 ("cannot import&, renaming already provided for "
9135 & "declaration #", N
, Def_Id
);
9139 -- If the pragma comes from an aspect specification, there
9140 -- must be an Import aspect specified as well. In the rare
9141 -- case where Import is set to False, the suprogram needs to
9142 -- have a local completion.
9145 Imp_Aspect
: constant Node_Id
:=
9146 Find_Aspect
(Def_Id
, Aspect_Import
);
9150 if Present
(Imp_Aspect
)
9151 and then Present
(Expression
(Imp_Aspect
))
9153 Expr
:= Expression
(Imp_Aspect
);
9154 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9156 if Is_Entity_Name
(Expr
)
9157 and then Entity
(Expr
) = Standard_True
9159 Set_Has_Completion
(Def_Id
);
9162 -- If there is no expression, the default is True, as for
9163 -- all boolean aspects. Same for the older pragma.
9166 Set_Has_Completion
(Def_Id
);
9170 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9173 if Is_Compilation_Unit
(Hom_Id
) then
9175 -- Its possible homonyms are not affected by the pragma.
9176 -- Such homonyms might be present in the context of other
9177 -- units being compiled.
9181 elsif From_Aspect_Specification
(N
) then
9184 -- If the pragma was created by the compiler, then we don't
9185 -- want it to apply to other homonyms. This kind of case can
9186 -- occur when using pragma Provide_Shift_Operators, which
9187 -- generates implicit shift and rotate operators with Import
9188 -- pragmas that might apply to earlier explicit or implicit
9189 -- declarations marked with Import (for example, coming from
9190 -- an earlier pragma Provide_Shift_Operators for another type),
9191 -- and we don't generally want other homonyms being treated
9192 -- as imported or the pragma flagged as an illegal duplicate.
9194 elsif not Comes_From_Source
(N
) then
9198 Hom_Id
:= Homonym
(Hom_Id
);
9202 -- Import a CPP class
9204 elsif C
= Convention_CPP
9205 and then (Is_Record_Type
(Def_Id
)
9206 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9208 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9209 if Present
(Full_View
(Def_Id
)) then
9210 Def_Id
:= Full_View
(Def_Id
);
9214 ("cannot import 'C'P'P type before full declaration seen",
9215 Get_Pragma_Arg
(Arg2
));
9217 -- Although we have reported the error we decorate it as
9218 -- CPP_Class to avoid reporting spurious errors
9220 Set_Is_CPP_Class
(Def_Id
);
9225 -- Types treated as CPP classes must be declared limited (note:
9226 -- this used to be a warning but there is no real benefit to it
9227 -- since we did effectively intend to treat the type as limited
9230 if not Is_Limited_Type
(Def_Id
) then
9232 ("imported 'C'P'P type must be limited",
9233 Get_Pragma_Arg
(Arg2
));
9236 if Etype
(Def_Id
) /= Def_Id
9237 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9239 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9242 Set_Is_CPP_Class
(Def_Id
);
9244 -- Imported CPP types must not have discriminants (because C++
9245 -- classes do not have discriminants).
9247 if Has_Discriminants
(Def_Id
) then
9249 ("imported 'C'P'P type cannot have discriminants",
9250 First
(Discriminant_Specifications
9251 (Declaration_Node
(Def_Id
))));
9254 -- Check that components of imported CPP types do not have default
9255 -- expressions. For private types this check is performed when the
9256 -- full view is analyzed (see Process_Full_View).
9258 if not Is_Private_Type
(Def_Id
) then
9259 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9262 -- Import a CPP exception
9264 elsif C
= Convention_CPP
9265 and then Ekind
(Def_Id
) = E_Exception
9269 ("'External_'Name arguments is required for 'Cpp exception",
9272 -- As only a string is allowed, Check_Arg_Is_External_Name
9275 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9278 if Present
(Arg4
) then
9280 ("Link_Name argument not allowed for imported Cpp exception",
9284 -- Do not call Set_Interface_Name as the name of the exception
9285 -- shouldn't be modified (and in particular it shouldn't be
9286 -- the External_Name). For exceptions, the External_Name is the
9287 -- name of the RTTI structure.
9289 -- ??? Emit an error if pragma Import/Export_Exception is present
9291 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9293 Check_Arg_Count
(3);
9294 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9296 Process_Import_Predefined_Type
;
9300 ("second argument of pragma% must be object, subprogram "
9301 & "or incomplete type",
9305 -- If this pragma applies to a compilation unit, then the unit, which
9306 -- is a subprogram, does not require (or allow) a body. We also do
9307 -- not need to elaborate imported procedures.
9309 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9311 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9313 Set_Body_Required
(Cunit
, False);
9316 end Process_Import_Or_Interface
;
9318 --------------------
9319 -- Process_Inline --
9320 --------------------
9322 procedure Process_Inline
(Status
: Inline_Status
) is
9329 Ghost_Error_Posted
: Boolean := False;
9330 -- Flag set when an error concerning the illegal mix of Ghost and
9331 -- non-Ghost subprograms is emitted.
9333 Ghost_Id
: Entity_Id
:= Empty
;
9334 -- The entity of the first Ghost subprogram encountered while
9335 -- processing the arguments of the pragma.
9337 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9338 -- Verify the placement of pragma Inline_Always with respect to the
9339 -- initial declaration of subprogram Spec_Id.
9341 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9342 -- Returns True if it can be determined at this stage that inlining
9343 -- is not possible, for example if the body is available and contains
9344 -- exception handlers, we prevent inlining, since otherwise we can
9345 -- get undefined symbols at link time. This function also emits a
9346 -- warning if the pragma appears too late.
9348 -- ??? is business with link symbols still valid, or does it relate
9349 -- to front end ZCX which is being phased out ???
9351 procedure Make_Inline
(Subp
: Entity_Id
);
9352 -- Subp is the defining unit name of the subprogram declaration. If
9353 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9354 -- the corresponding body, if there is one present.
9356 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9357 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9358 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9360 -----------------------------------
9361 -- Check_Inline_Always_Placement --
9362 -----------------------------------
9364 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9365 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9367 function Compilation_Unit_OK
return Boolean;
9368 pragma Inline
(Compilation_Unit_OK
);
9369 -- Determine whether pragma Inline_Always applies to a compatible
9370 -- compilation unit denoted by Spec_Id.
9372 function Declarative_List_OK
return Boolean;
9373 pragma Inline
(Declarative_List_OK
);
9374 -- Determine whether the initial declaration of subprogram Spec_Id
9375 -- and the pragma appear in compatible declarative lists.
9377 function Subprogram_Body_OK
return Boolean;
9378 pragma Inline
(Subprogram_Body_OK
);
9379 -- Determine whether pragma Inline_Always applies to a compatible
9380 -- subprogram body denoted by Spec_Id.
9382 -------------------------
9383 -- Compilation_Unit_OK --
9384 -------------------------
9386 function Compilation_Unit_OK
return Boolean is
9387 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9390 -- The pragma appears after the initial declaration of a
9391 -- compilation unit.
9393 -- procedure Comp_Unit;
9394 -- pragma Inline_Always (Comp_Unit);
9396 -- Note that for compatibility reasons, the following case is
9399 -- procedure Stand_Alone_Body_Comp_Unit is
9401 -- end Stand_Alone_Body_Comp_Unit;
9402 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9405 Nkind
(Comp_Unit
) = N_Compilation_Unit
9406 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9407 and then Is_List_Member
(N
)
9408 and then List_Containing
(N
) =
9409 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9410 end Compilation_Unit_OK
;
9412 -------------------------
9413 -- Declarative_List_OK --
9414 -------------------------
9416 function Declarative_List_OK
return Boolean is
9417 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9419 Init_Decl
: Node_Id
;
9420 Init_List
: List_Id
;
9421 Prag_List
: List_Id
;
9424 -- Determine the proper initial declaration. In general this is
9425 -- the declaration node of the subprogram except when the input
9426 -- denotes a generic instantiation.
9428 -- procedure Inst is new Gen;
9429 -- pragma Inline_Always (Inst);
9431 -- In this case the original subprogram is moved inside an
9432 -- anonymous package while pragma Inline_Always remains at the
9433 -- level of the anonymous package. Use the declaration of the
9434 -- package because it reflects the placement of the original
9437 -- package Anon_Pack is
9438 -- procedure Inst is ... end Inst; -- original
9441 -- procedure Inst renames Anon_Pack.Inst;
9442 -- pragma Inline_Always (Inst);
9444 if Is_Generic_Instance
(Spec_Id
) then
9445 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9446 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9448 Init_Decl
:= Spec_Decl
;
9451 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9452 Init_List
:= List_Containing
(Init_Decl
);
9453 Prag_List
:= List_Containing
(N
);
9455 -- The pragma and then initial declaration appear within the
9456 -- same declarative list.
9458 if Init_List
= Prag_List
then
9461 -- A special case of the above is when both the pragma and
9462 -- the initial declaration appear in different lists of a
9463 -- package spec, protected definition, or a task definition.
9468 -- pragma Inline_Always (Proc);
9471 elsif Nkind_In
(Context
, N_Package_Specification
,
9472 N_Protected_Definition
,
9474 and then Init_List
= Visible_Declarations
(Context
)
9475 and then Prag_List
= Private_Declarations
(Context
)
9482 end Declarative_List_OK
;
9484 ------------------------
9485 -- Subprogram_Body_OK --
9486 ------------------------
9488 function Subprogram_Body_OK
return Boolean is
9489 Body_Decl
: Node_Id
;
9492 -- The pragma appears within the declarative list of a stand-
9493 -- alone subprogram body.
9495 -- procedure Stand_Alone_Body is
9496 -- pragma Inline_Always (Stand_Alone_Body);
9499 -- end Stand_Alone_Body;
9501 -- The compiler creates a dummy spec in this case, however the
9502 -- pragma remains within the declarative list of the body.
9504 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9505 and then not Comes_From_Source
(Spec_Decl
)
9506 and then Present
(Corresponding_Body
(Spec_Decl
))
9509 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9511 if Present
(Declarations
(Body_Decl
))
9512 and then Is_List_Member
(N
)
9513 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9520 end Subprogram_Body_OK
;
9522 -- Start of processing for Check_Inline_Always_Placement
9525 -- This check is relevant only for pragma Inline_Always
9527 if Pname
/= Name_Inline_Always
then
9530 -- Nothing to do when the pragma is internally generated on the
9531 -- assumption that it is properly placed.
9533 elsif not Comes_From_Source
(N
) then
9536 -- Nothing to do for internally generated subprograms that act
9537 -- as accidental homonyms of a source subprogram being inlined.
9539 elsif not Comes_From_Source
(Spec_Id
) then
9542 -- Nothing to do for generic formal subprograms that act as
9543 -- homonyms of another source subprogram being inlined.
9545 elsif Is_Formal_Subprogram
(Spec_Id
) then
9548 elsif Compilation_Unit_OK
9549 or else Declarative_List_OK
9550 or else Subprogram_Body_OK
9555 -- At this point it is known that the pragma applies to or appears
9556 -- within a completing body, a completing stub, or a subunit.
9558 Error_Msg_Name_1
:= Pname
;
9559 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9560 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9563 ("pragma % must appear on initial declaration of subprogram "
9564 & "% defined #", N
);
9565 end Check_Inline_Always_Placement
;
9567 ---------------------------
9568 -- Inlining_Not_Possible --
9569 ---------------------------
9571 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9572 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9576 if Nkind
(Decl
) = N_Subprogram_Body
then
9577 Stats
:= Handled_Statement_Sequence
(Decl
);
9578 return Present
(Exception_Handlers
(Stats
))
9579 or else Present
(At_End_Proc
(Stats
));
9581 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9582 and then Present
(Corresponding_Body
(Decl
))
9584 if Analyzed
(Corresponding_Body
(Decl
)) then
9585 Error_Msg_N
("pragma appears too late, ignored??", N
);
9588 -- If the subprogram is a renaming as body, the body is just a
9589 -- call to the renamed subprogram, and inlining is trivially
9593 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9594 N_Subprogram_Renaming_Declaration
9600 Handled_Statement_Sequence
9601 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9604 Present
(Exception_Handlers
(Stats
))
9605 or else Present
(At_End_Proc
(Stats
));
9609 -- If body is not available, assume the best, the check is
9610 -- performed again when compiling enclosing package bodies.
9614 end Inlining_Not_Possible
;
9620 procedure Make_Inline
(Subp
: Entity_Id
) is
9621 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9622 Inner_Subp
: Entity_Id
:= Subp
;
9625 -- Ignore if bad type, avoid cascaded error
9627 if Etype
(Subp
) = Any_Type
then
9631 -- If inlining is not possible, for now do not treat as an error
9633 elsif Status
/= Suppressed
9634 and then Front_End_Inlining
9635 and then Inlining_Not_Possible
(Subp
)
9640 -- Here we have a candidate for inlining, but we must exclude
9641 -- derived operations. Otherwise we would end up trying to inline
9642 -- a phantom declaration, and the result would be to drag in a
9643 -- body which has no direct inlining associated with it. That
9644 -- would not only be inefficient but would also result in the
9645 -- backend doing cross-unit inlining in cases where it was
9646 -- definitely inappropriate to do so.
9648 -- However, a simple Comes_From_Source test is insufficient, since
9649 -- we do want to allow inlining of generic instances which also do
9650 -- not come from source. We also need to recognize specs generated
9651 -- by the front-end for bodies that carry the pragma. Finally,
9652 -- predefined operators do not come from source but are not
9653 -- inlineable either.
9655 elsif Is_Generic_Instance
(Subp
)
9656 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9660 elsif not Comes_From_Source
(Subp
)
9661 and then Scope
(Subp
) /= Standard_Standard
9667 -- The referenced entity must either be the enclosing entity, or
9668 -- an entity declared within the current open scope.
9670 if Present
(Scope
(Subp
))
9671 and then Scope
(Subp
) /= Current_Scope
9672 and then Subp
/= Current_Scope
9675 ("argument of% must be entity in current scope", Assoc
);
9679 -- Processing for procedure, operator or function. If subprogram
9680 -- is aliased (as for an instance) indicate that the renamed
9681 -- entity (if declared in the same unit) is inlined.
9682 -- If this is the anonymous subprogram created for a subprogram
9683 -- instance, the inlining applies to it directly. Otherwise we
9684 -- retrieve it as the alias of the visible subprogram instance.
9686 if Is_Subprogram
(Subp
) then
9688 -- Ensure that pragma Inline_Always is associated with the
9689 -- initial declaration of the subprogram.
9691 Check_Inline_Always_Placement
(Subp
);
9693 if Is_Wrapper_Package
(Scope
(Subp
)) then
9696 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9699 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9700 Set_Inline_Flags
(Inner_Subp
);
9702 Decl
:= Parent
(Parent
(Inner_Subp
));
9704 if Nkind
(Decl
) = N_Subprogram_Declaration
9705 and then Present
(Corresponding_Body
(Decl
))
9707 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9709 elsif Is_Generic_Instance
(Subp
)
9710 and then Comes_From_Source
(Subp
)
9712 -- Indicate that the body needs to be created for
9713 -- inlining subsequent calls. The instantiation node
9714 -- follows the declaration of the wrapper package
9715 -- created for it. The subprogram that requires the
9716 -- body is the anonymous one in the wrapper package.
9718 if Scope
(Subp
) /= Standard_Standard
9720 Need_Subprogram_Instance_Body
9721 (Next
(Unit_Declaration_Node
9722 (Scope
(Alias
(Subp
)))), Subp
)
9727 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9728 -- appear in a formal part to apply to a formal subprogram.
9729 -- Do not apply check within an instance or a formal package
9730 -- the test will have been applied to the original generic.
9732 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9733 and then List_Containing
(Decl
) = List_Containing
(N
)
9734 and then not In_Instance
9737 ("Inline cannot apply to a formal subprogram", N
);
9739 -- If Subp is a renaming, it is the renamed entity that
9740 -- will appear in any call, and be inlined. However, for
9741 -- ASIS uses it is convenient to indicate that the renaming
9742 -- itself is an inlined subprogram, so that some gnatcheck
9743 -- rules can be applied in the absence of expansion.
9745 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9746 Set_Inline_Flags
(Subp
);
9752 -- For a generic subprogram set flag as well, for use at the point
9753 -- of instantiation, to determine whether the body should be
9756 elsif Is_Generic_Subprogram
(Subp
) then
9757 Set_Inline_Flags
(Subp
);
9760 -- Literals are by definition inlined
9762 elsif Kind
= E_Enumeration_Literal
then
9765 -- Anything else is an error
9769 ("expect subprogram name for pragma%", Assoc
);
9773 ----------------------
9774 -- Set_Inline_Flags --
9775 ----------------------
9777 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9779 -- First set the Has_Pragma_XXX flags and issue the appropriate
9780 -- errors and warnings for suspicious combinations.
9782 if Prag_Id
= Pragma_No_Inline
then
9783 if Has_Pragma_Inline_Always
(Subp
) then
9785 ("Inline_Always and No_Inline are mutually exclusive", N
);
9786 elsif Has_Pragma_Inline
(Subp
) then
9788 ("Inline and No_Inline both specified for& ??",
9789 N
, Entity
(Subp_Id
));
9792 Set_Has_Pragma_No_Inline
(Subp
);
9794 if Prag_Id
= Pragma_Inline_Always
then
9795 if Has_Pragma_No_Inline
(Subp
) then
9797 ("Inline_Always and No_Inline are mutually exclusive",
9801 Set_Has_Pragma_Inline_Always
(Subp
);
9803 if Has_Pragma_No_Inline
(Subp
) then
9805 ("Inline and No_Inline both specified for& ??",
9806 N
, Entity
(Subp_Id
));
9810 Set_Has_Pragma_Inline
(Subp
);
9813 -- Then adjust the Is_Inlined flag. It can never be set if the
9814 -- subprogram is subject to pragma No_Inline.
9818 Set_Is_Inlined
(Subp
, False);
9824 if not Has_Pragma_No_Inline
(Subp
) then
9825 Set_Is_Inlined
(Subp
, True);
9829 -- A pragma that applies to a Ghost entity becomes Ghost for the
9830 -- purposes of legality checks and removal of ignored Ghost code.
9832 Mark_Ghost_Pragma
(N
, Subp
);
9834 -- Capture the entity of the first Ghost subprogram being
9835 -- processed for error detection purposes.
9837 if Is_Ghost_Entity
(Subp
) then
9838 if No
(Ghost_Id
) then
9842 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9843 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9845 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9846 Ghost_Error_Posted
:= True;
9848 Error_Msg_Name_1
:= Pname
;
9850 ("pragma % cannot mention ghost and non-ghost subprograms",
9853 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9854 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9856 Error_Msg_Sloc
:= Sloc
(Subp
);
9857 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9859 end Set_Inline_Flags
;
9861 -- Start of processing for Process_Inline
9864 Check_No_Identifiers
;
9865 Check_At_Least_N_Arguments
(1);
9867 if Status
= Enabled
then
9868 Inline_Processing_Required
:= True;
9872 while Present
(Assoc
) loop
9873 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9877 if Is_Entity_Name
(Subp_Id
) then
9878 Subp
:= Entity
(Subp_Id
);
9880 if Subp
= Any_Id
then
9882 -- If previous error, avoid cascaded errors
9884 Check_Error_Detected
;
9890 -- For the pragma case, climb homonym chain. This is
9891 -- what implements allowing the pragma in the renaming
9892 -- case, with the result applying to the ancestors, and
9893 -- also allows Inline to apply to all previous homonyms.
9895 if not From_Aspect_Specification
(N
) then
9896 while Present
(Homonym
(Subp
))
9897 and then Scope
(Homonym
(Subp
)) = Current_Scope
9899 Make_Inline
(Homonym
(Subp
));
9900 Subp
:= Homonym
(Subp
);
9907 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9913 -- If the context is a package declaration, the pragma indicates
9914 -- that inlining will require the presence of the corresponding
9915 -- body. (this may be further refined).
9918 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9919 N_Package_Declaration
9921 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9925 ----------------------------
9926 -- Process_Interface_Name --
9927 ----------------------------
9929 procedure Process_Interface_Name
9930 (Subprogram_Def
: Entity_Id
;
9937 String_Val
: String_Id
;
9939 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9940 -- SN is a string literal node for an interface name. This routine
9941 -- performs some minimal checks that the name is reasonable. In
9942 -- particular that no spaces or other obviously incorrect characters
9943 -- appear. This is only a warning, since any characters are allowed.
9945 ----------------------------------
9946 -- Check_Form_Of_Interface_Name --
9947 ----------------------------------
9949 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9950 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9951 SL
: constant Nat
:= String_Length
(S
);
9956 Error_Msg_N
("interface name cannot be null string", SN
);
9959 for J
in 1 .. SL
loop
9960 C
:= Get_String_Char
(S
, J
);
9962 -- Look for dubious character and issue unconditional warning.
9963 -- Definitely dubious if not in character range.
9965 if not In_Character_Range
(C
)
9967 -- Commas, spaces and (back)slashes are dubious
9969 or else Get_Character
(C
) = ','
9970 or else Get_Character
(C
) = '\'
9971 or else Get_Character
(C
) = ' '
9972 or else Get_Character
(C
) = '/'
9975 ("??interface name contains illegal character",
9976 Sloc
(SN
) + Source_Ptr
(J
));
9979 end Check_Form_Of_Interface_Name
;
9981 -- Start of processing for Process_Interface_Name
9984 -- If we are looking at a pragma that comes from an aspect then it
9985 -- needs to have its corresponding aspect argument expressions
9986 -- analyzed in addition to the generated pragma so that aspects
9987 -- within generic units get properly resolved.
9989 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9991 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9999 -- Obtain all interfacing aspects used to construct the pragma
10001 Get_Interfacing_Aspects
10002 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
10004 -- Analyze the expression of aspect External_Name
10006 if Present
(EN
) then
10007 Analyze
(Expression
(EN
));
10010 -- Analyze the expressio of aspect Link_Name
10012 if Present
(LN
) then
10013 Analyze
(Expression
(LN
));
10018 if No
(Link_Arg
) then
10019 if No
(Ext_Arg
) then
10022 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
10024 Link_Nam
:= Expression
(Ext_Arg
);
10027 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10028 Ext_Nam
:= Expression
(Ext_Arg
);
10033 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10034 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
10035 Ext_Nam
:= Expression
(Ext_Arg
);
10036 Link_Nam
:= Expression
(Link_Arg
);
10039 -- Check expressions for external name and link name are static
10041 if Present
(Ext_Nam
) then
10042 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
10043 Check_Form_Of_Interface_Name
(Ext_Nam
);
10045 -- Verify that external name is not the name of a local entity,
10046 -- which would hide the imported one and could lead to run-time
10047 -- surprises. The problem can only arise for entities declared in
10048 -- a package body (otherwise the external name is fully qualified
10049 -- and will not conflict).
10057 if Prag_Id
= Pragma_Import
then
10058 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
10059 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
10061 if Nam
/= Chars
(Subprogram_Def
)
10062 and then Present
(E
)
10063 and then not Is_Overloadable
(E
)
10064 and then Is_Immediately_Visible
(E
)
10065 and then not Is_Imported
(E
)
10066 and then Ekind
(Scope
(E
)) = E_Package
10069 while Present
(Par
) loop
10070 if Nkind
(Par
) = N_Package_Body
then
10071 Error_Msg_Sloc
:= Sloc
(E
);
10073 ("imported entity is hidden by & declared#",
10078 Par
:= Parent
(Par
);
10085 if Present
(Link_Nam
) then
10086 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
10087 Check_Form_Of_Interface_Name
(Link_Nam
);
10090 -- If there is no link name, just set the external name
10092 if No
(Link_Nam
) then
10093 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
10095 -- For the Link_Name case, the given literal is preceded by an
10096 -- asterisk, which indicates to GCC that the given name should be
10097 -- taken literally, and in particular that no prepending of
10098 -- underlines should occur, even in systems where this is the
10103 Store_String_Char
(Get_Char_Code
('*'));
10104 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
10105 Store_String_Chars
(String_Val
);
10107 Make_String_Literal
(Sloc
(Link_Nam
),
10108 Strval
=> End_String
);
10111 -- Set the interface name. If the entity is a generic instance, use
10112 -- its alias, which is the callable entity.
10114 if Is_Generic_Instance
(Subprogram_Def
) then
10115 Set_Encoded_Interface_Name
10116 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10118 Set_Encoded_Interface_Name
10119 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10122 Check_Duplicated_Export_Name
(Link_Nam
);
10123 end Process_Interface_Name
;
10125 -----------------------------------------
10126 -- Process_Interrupt_Or_Attach_Handler --
10127 -----------------------------------------
10129 procedure Process_Interrupt_Or_Attach_Handler
is
10130 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10131 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10134 -- A pragma that applies to a Ghost entity becomes Ghost for the
10135 -- purposes of legality checks and removal of ignored Ghost code.
10137 Mark_Ghost_Pragma
(N
, Handler
);
10138 Set_Is_Interrupt_Handler
(Handler
);
10140 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10142 Record_Rep_Item
(Prot_Typ
, N
);
10144 -- Chain the pragma on the contract for completeness
10146 Add_Contract_Item
(N
, Handler
);
10147 end Process_Interrupt_Or_Attach_Handler
;
10149 --------------------------------------------------
10150 -- Process_Restrictions_Or_Restriction_Warnings --
10151 --------------------------------------------------
10153 -- Note: some of the simple identifier cases were handled in par-prag,
10154 -- but it is harmless (and more straightforward) to simply handle all
10155 -- cases here, even if it means we repeat a bit of work in some cases.
10157 procedure Process_Restrictions_Or_Restriction_Warnings
10161 R_Id
: Restriction_Id
;
10167 -- Ignore all Restrictions pragmas in CodePeer mode
10169 if CodePeer_Mode
then
10173 Check_Ada_83_Warning
;
10174 Check_At_Least_N_Arguments
(1);
10175 Check_Valid_Configuration_Pragma
;
10178 while Present
(Arg
) loop
10180 Expr
:= Get_Pragma_Arg
(Arg
);
10182 -- Case of no restriction identifier present
10184 if Id
= No_Name
then
10185 if Nkind
(Expr
) /= N_Identifier
then
10187 ("invalid form for restriction", Arg
);
10192 (Process_Restriction_Synonyms
(Expr
));
10194 if R_Id
not in All_Boolean_Restrictions
then
10195 Error_Msg_Name_1
:= Pname
;
10197 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10199 -- Check for possible misspelling
10201 for J
in Restriction_Id
loop
10203 Rnm
: constant String := Restriction_Id
'Image (J
);
10206 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10207 Name_Len
:= Rnm
'Length;
10208 Set_Casing
(All_Lower_Case
);
10210 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10213 (Source_Index
(Current_Sem_Unit
)));
10214 Error_Msg_String
(1 .. Rnm
'Length) :=
10215 Name_Buffer
(1 .. Name_Len
);
10216 Error_Msg_Strlen
:= Rnm
'Length;
10217 Error_Msg_N
-- CODEFIX
10218 ("\possible misspelling of ""~""",
10219 Get_Pragma_Arg
(Arg
));
10228 if Implementation_Restriction
(R_Id
) then
10229 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10232 -- Special processing for No_Elaboration_Code restriction
10234 if R_Id
= No_Elaboration_Code
then
10236 -- Restriction is only recognized within a configuration
10237 -- pragma file, or within a unit of the main extended
10238 -- program. Note: the test for Main_Unit is needed to
10239 -- properly include the case of configuration pragma files.
10241 if not (Current_Sem_Unit
= Main_Unit
10242 or else In_Extended_Main_Source_Unit
(N
))
10246 -- Don't allow in a subunit unless already specified in
10249 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10250 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10251 and then not Restriction_Active
(No_Elaboration_Code
)
10254 ("invalid specification of ""No_Elaboration_Code""",
10257 ("\restriction cannot be specified in a subunit", N
);
10259 ("\unless also specified in body or spec", N
);
10262 -- If we accept a No_Elaboration_Code restriction, then it
10263 -- needs to be added to the configuration restriction set so
10264 -- that we get proper application to other units in the main
10265 -- extended source as required.
10268 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10272 -- If this is a warning, then set the warning unless we already
10273 -- have a real restriction active (we never want a warning to
10274 -- override a real restriction).
10277 if not Restriction_Active
(R_Id
) then
10278 Set_Restriction
(R_Id
, N
);
10279 Restriction_Warnings
(R_Id
) := True;
10282 -- If real restriction case, then set it and make sure that the
10283 -- restriction warning flag is off, since a real restriction
10284 -- always overrides a warning.
10287 Set_Restriction
(R_Id
, N
);
10288 Restriction_Warnings
(R_Id
) := False;
10291 -- Check for obsolescent restrictions in Ada 2005 mode
10294 and then Ada_Version
>= Ada_2005
10295 and then (R_Id
= No_Asynchronous_Control
10297 R_Id
= No_Unchecked_Deallocation
10299 R_Id
= No_Unchecked_Conversion
)
10301 Check_Restriction
(No_Obsolescent_Features
, N
);
10304 -- A very special case that must be processed here: pragma
10305 -- Restrictions (No_Exceptions) turns off all run-time
10306 -- checking. This is a bit dubious in terms of the formal
10307 -- language definition, but it is what is intended by RM
10308 -- H.4(12). Restriction_Warnings never affects generated code
10309 -- so this is done only in the real restriction case.
10311 -- Atomic_Synchronization is not a real check, so it is not
10312 -- affected by this processing).
10314 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10315 -- run-time checks in CodePeer and GNATprove modes: we want to
10316 -- generate checks for analysis purposes, as set respectively
10317 -- by -gnatC and -gnatd.F
10320 and then not (CodePeer_Mode
or GNATprove_Mode
)
10321 and then R_Id
= No_Exceptions
10323 for J
in Scope_Suppress
.Suppress
'Range loop
10324 if J
/= Atomic_Synchronization
then
10325 Scope_Suppress
.Suppress
(J
) := True;
10330 -- Case of No_Dependence => unit-name. Note that the parser
10331 -- already made the necessary entry in the No_Dependence table.
10333 elsif Id
= Name_No_Dependence
then
10334 if not OK_No_Dependence_Unit_Name
(Expr
) then
10338 -- Case of No_Specification_Of_Aspect => aspect-identifier
10340 elsif Id
= Name_No_Specification_Of_Aspect
then
10345 if Nkind
(Expr
) /= N_Identifier
then
10348 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10351 if A_Id
= No_Aspect
then
10352 Error_Pragma_Arg
("invalid restriction name", Arg
);
10354 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10358 -- Case of No_Use_Of_Attribute => attribute-identifier
10360 elsif Id
= Name_No_Use_Of_Attribute
then
10361 if Nkind
(Expr
) /= N_Identifier
10362 or else not Is_Attribute_Name
(Chars
(Expr
))
10364 Error_Msg_N
("unknown attribute name??", Expr
);
10367 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10370 -- Case of No_Use_Of_Entity => fully-qualified-name
10372 elsif Id
= Name_No_Use_Of_Entity
then
10374 -- Restriction is only recognized within a configuration
10375 -- pragma file, or within a unit of the main extended
10376 -- program. Note: the test for Main_Unit is needed to
10377 -- properly include the case of configuration pragma files.
10379 if Current_Sem_Unit
= Main_Unit
10380 or else In_Extended_Main_Source_Unit
(N
)
10382 if not OK_No_Dependence_Unit_Name
(Expr
) then
10383 Error_Msg_N
("wrong form for entity name", Expr
);
10385 Set_Restriction_No_Use_Of_Entity
10386 (Expr
, Warn
, No_Profile
);
10390 -- Case of No_Use_Of_Pragma => pragma-identifier
10392 elsif Id
= Name_No_Use_Of_Pragma
then
10393 if Nkind
(Expr
) /= N_Identifier
10394 or else not Is_Pragma_Name
(Chars
(Expr
))
10396 Error_Msg_N
("unknown pragma name??", Expr
);
10398 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10401 -- All other cases of restriction identifier present
10404 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10405 Analyze_And_Resolve
(Expr
, Any_Integer
);
10407 if R_Id
not in All_Parameter_Restrictions
then
10409 ("invalid restriction parameter identifier", Arg
);
10411 elsif not Is_OK_Static_Expression
(Expr
) then
10412 Flag_Non_Static_Expr
10413 ("value must be static expression!", Expr
);
10416 elsif not Is_Integer_Type
(Etype
(Expr
))
10417 or else Expr_Value
(Expr
) < 0
10420 ("value must be non-negative integer", Arg
);
10423 -- Restriction pragma is active
10425 Val
:= Expr_Value
(Expr
);
10427 if not UI_Is_In_Int_Range
(Val
) then
10429 ("pragma ignored, value too large??", Arg
);
10432 -- Warning case. If the real restriction is active, then we
10433 -- ignore the request, since warning never overrides a real
10434 -- restriction. Otherwise we set the proper warning. Note that
10435 -- this circuit sets the warning again if it is already set,
10436 -- which is what we want, since the constant may have changed.
10439 if not Restriction_Active
(R_Id
) then
10441 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10442 Restriction_Warnings
(R_Id
) := True;
10445 -- Real restriction case, set restriction and make sure warning
10446 -- flag is off since real restriction always overrides warning.
10449 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10450 Restriction_Warnings
(R_Id
) := False;
10456 end Process_Restrictions_Or_Restriction_Warnings
;
10458 ---------------------------------
10459 -- Process_Suppress_Unsuppress --
10460 ---------------------------------
10462 -- Note: this procedure makes entries in the check suppress data
10463 -- structures managed by Sem. See spec of package Sem for full
10464 -- details on how we handle recording of check suppression.
10466 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10471 In_Package_Spec
: constant Boolean :=
10472 Is_Package_Or_Generic_Package
(Current_Scope
)
10473 and then not In_Package_Body
(Current_Scope
);
10475 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10476 -- Used to suppress a single check on the given entity
10478 --------------------------------
10479 -- Suppress_Unsuppress_Echeck --
10480 --------------------------------
10482 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10484 -- Check for error of trying to set atomic synchronization for
10485 -- a non-atomic variable.
10487 if C
= Atomic_Synchronization
10488 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10491 ("pragma & requires atomic type or variable",
10492 Pragma_Identifier
(Original_Node
(N
)));
10495 Set_Checks_May_Be_Suppressed
(E
);
10497 if In_Package_Spec
then
10498 Push_Global_Suppress_Stack_Entry
10501 Suppress
=> Suppress_Case
);
10503 Push_Local_Suppress_Stack_Entry
10506 Suppress
=> Suppress_Case
);
10509 -- If this is a first subtype, and the base type is distinct,
10510 -- then also set the suppress flags on the base type.
10512 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10513 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10515 end Suppress_Unsuppress_Echeck
;
10517 -- Start of processing for Process_Suppress_Unsuppress
10520 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10521 -- on user code: we want to generate checks for analysis purposes, as
10522 -- set respectively by -gnatC and -gnatd.F
10524 if Comes_From_Source
(N
)
10525 and then (CodePeer_Mode
or GNATprove_Mode
)
10530 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10531 -- declarative part or a package spec (RM 11.5(5)).
10533 if not Is_Configuration_Pragma
then
10534 Check_Is_In_Decl_Part_Or_Package_Spec
;
10537 Check_At_Least_N_Arguments
(1);
10538 Check_At_Most_N_Arguments
(2);
10539 Check_No_Identifier
(Arg1
);
10540 Check_Arg_Is_Identifier
(Arg1
);
10542 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10544 if C
= No_Check_Id
then
10546 ("argument of pragma% is not valid check name", Arg1
);
10549 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10551 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10553 ("Suppress of Elaboration_Check ignored in SPARK??",
10554 "\elaboration checking rules are statically enforced "
10555 & "(SPARK RM 7.7)", Arg1
);
10558 -- One-argument case
10560 if Arg_Count
= 1 then
10562 -- Make an entry in the local scope suppress table. This is the
10563 -- table that directly shows the current value of the scope
10564 -- suppress check for any check id value.
10566 if C
= All_Checks
then
10568 -- For All_Checks, we set all specific predefined checks with
10569 -- the exception of Elaboration_Check, which is handled
10570 -- specially because of not wanting All_Checks to have the
10571 -- effect of deactivating static elaboration order processing.
10572 -- Atomic_Synchronization is also not affected, since this is
10573 -- not a real check.
10575 for J
in Scope_Suppress
.Suppress
'Range loop
10576 if J
/= Elaboration_Check
10578 J
/= Atomic_Synchronization
10580 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10584 -- If not All_Checks, and predefined check, then set appropriate
10585 -- scope entry. Note that we will set Elaboration_Check if this
10586 -- is explicitly specified. Atomic_Synchronization is allowed
10587 -- only if internally generated and entity is atomic.
10589 elsif C
in Predefined_Check_Id
10590 and then (not Comes_From_Source
(N
)
10591 or else C
/= Atomic_Synchronization
)
10593 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10596 -- Also make an entry in the Local_Entity_Suppress table
10598 Push_Local_Suppress_Stack_Entry
10601 Suppress
=> Suppress_Case
);
10603 -- Case of two arguments present, where the check is suppressed for
10604 -- a specified entity (given as the second argument of the pragma)
10607 -- This is obsolescent in Ada 2005 mode
10609 if Ada_Version
>= Ada_2005
then
10610 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10613 Check_Optional_Identifier
(Arg2
, Name_On
);
10614 E_Id
:= Get_Pragma_Arg
(Arg2
);
10617 if not Is_Entity_Name
(E_Id
) then
10619 ("second argument of pragma% must be entity name", Arg2
);
10622 E
:= Entity
(E_Id
);
10628 -- A pragma that applies to a Ghost entity becomes Ghost for the
10629 -- purposes of legality checks and removal of ignored Ghost code.
10631 Mark_Ghost_Pragma
(N
, E
);
10633 -- Enforce RM 11.5(7) which requires that for a pragma that
10634 -- appears within a package spec, the named entity must be
10635 -- within the package spec. We allow the package name itself
10636 -- to be mentioned since that makes sense, although it is not
10637 -- strictly allowed by 11.5(7).
10640 and then E
/= Current_Scope
10641 and then Scope
(E
) /= Current_Scope
10644 ("entity in pragma% is not in package spec (RM 11.5(7))",
10648 -- Loop through homonyms. As noted below, in the case of a package
10649 -- spec, only homonyms within the package spec are considered.
10652 Suppress_Unsuppress_Echeck
(E
, C
);
10654 if Is_Generic_Instance
(E
)
10655 and then Is_Subprogram
(E
)
10656 and then Present
(Alias
(E
))
10658 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10661 -- Move to next homonym if not aspect spec case
10663 exit when From_Aspect_Specification
(N
);
10667 -- If we are within a package specification, the pragma only
10668 -- applies to homonyms in the same scope.
10670 exit when In_Package_Spec
10671 and then Scope
(E
) /= Current_Scope
;
10674 end Process_Suppress_Unsuppress
;
10676 -------------------------------
10677 -- Record_Independence_Check --
10678 -------------------------------
10680 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10681 pragma Unreferenced
(N
, E
);
10683 -- For GCC back ends the validation is done a priori
10684 -- ??? This code is dead, might be useful in the future
10686 -- if not AAMP_On_Target then
10690 -- Independence_Checks.Append ((N, E));
10693 end Record_Independence_Check
;
10699 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10701 if Is_Imported
(E
) then
10703 ("cannot export entity& that was previously imported", Arg
);
10705 elsif Present
(Address_Clause
(E
))
10706 and then not Relaxed_RM_Semantics
10709 ("cannot export entity& that has an address clause", Arg
);
10712 Set_Is_Exported
(E
);
10714 -- Generate a reference for entity explicitly, because the
10715 -- identifier may be overloaded and name resolution will not
10718 Generate_Reference
(E
, Arg
);
10720 -- Deal with exporting non-library level entity
10722 if not Is_Library_Level_Entity
(E
) then
10724 -- Not allowed at all for subprograms
10726 if Is_Subprogram
(E
) then
10727 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10729 -- Otherwise set public and statically allocated
10733 Set_Is_Statically_Allocated
(E
);
10735 -- Warn if the corresponding W flag is set
10737 if Warn_On_Export_Import
10739 -- Only do this for something that was in the source. Not
10740 -- clear if this can be False now (there used for sure to be
10741 -- cases on some systems where it was False), but anyway the
10742 -- test is harmless if not needed, so it is retained.
10744 and then Comes_From_Source
(Arg
)
10747 ("?x?& has been made static as a result of Export",
10750 ("\?x?this usage is non-standard and non-portable",
10756 if Warn_On_Export_Import
and then Is_Type
(E
) then
10757 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10760 if Warn_On_Export_Import
and Inside_A_Generic
then
10762 ("all instances of& will have the same external name?x?",
10767 ----------------------------------------------
10768 -- Set_Extended_Import_Export_External_Name --
10769 ----------------------------------------------
10771 procedure Set_Extended_Import_Export_External_Name
10772 (Internal_Ent
: Entity_Id
;
10773 Arg_External
: Node_Id
)
10775 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10776 New_Name
: Node_Id
;
10779 if No
(Arg_External
) then
10783 Check_Arg_Is_External_Name
(Arg_External
);
10785 if Nkind
(Arg_External
) = N_String_Literal
then
10786 if String_Length
(Strval
(Arg_External
)) = 0 then
10789 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10792 elsif Nkind
(Arg_External
) = N_Identifier
then
10793 New_Name
:= Get_Default_External_Name
(Arg_External
);
10795 -- Check_Arg_Is_External_Name should let through only identifiers and
10796 -- string literals or static string expressions (which are folded to
10797 -- string literals).
10800 raise Program_Error
;
10803 -- If we already have an external name set (by a prior normal Import
10804 -- or Export pragma), then the external names must match
10806 if Present
(Interface_Name
(Internal_Ent
)) then
10808 -- Ignore mismatching names in CodePeer mode, to support some
10809 -- old compilers which would export the same procedure under
10810 -- different names, e.g:
10812 -- pragma Export_Procedure (P, "a");
10813 -- pragma Export_Procedure (P, "b");
10815 if CodePeer_Mode
then
10819 Check_Matching_Internal_Names
: declare
10820 S1
: constant String_Id
:= Strval
(Old_Name
);
10821 S2
: constant String_Id
:= Strval
(New_Name
);
10823 procedure Mismatch
;
10824 pragma No_Return
(Mismatch
);
10825 -- Called if names do not match
10831 procedure Mismatch
is
10833 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10835 ("external name does not match that given #",
10839 -- Start of processing for Check_Matching_Internal_Names
10842 if String_Length
(S1
) /= String_Length
(S2
) then
10846 for J
in 1 .. String_Length
(S1
) loop
10847 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10852 end Check_Matching_Internal_Names
;
10854 -- Otherwise set the given name
10857 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10858 Check_Duplicated_Export_Name
(New_Name
);
10860 end Set_Extended_Import_Export_External_Name
;
10866 procedure Set_Imported
(E
: Entity_Id
) is
10868 -- Error message if already imported or exported
10870 if Is_Exported
(E
) or else Is_Imported
(E
) then
10872 -- Error if being set Exported twice
10874 if Is_Exported
(E
) then
10875 Error_Msg_NE
("entity& was previously exported", N
, E
);
10877 -- Ignore error in CodePeer mode where we treat all imported
10878 -- subprograms as unknown.
10880 elsif CodePeer_Mode
then
10883 -- OK if Import/Interface case
10885 elsif Import_Interface_Present
(N
) then
10888 -- Error if being set Imported twice
10891 Error_Msg_NE
("entity& was previously imported", N
, E
);
10894 Error_Msg_Name_1
:= Pname
;
10896 ("\(pragma% applies to all previous entities)", N
);
10898 Error_Msg_Sloc
:= Sloc
(E
);
10899 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10901 -- Here if not previously imported or exported, OK to import
10904 Set_Is_Imported
(E
);
10906 -- For subprogram, set Import_Pragma field
10908 if Is_Subprogram
(E
) then
10909 Set_Import_Pragma
(E
, N
);
10912 -- If the entity is an object that is not at the library level,
10913 -- then it is statically allocated. We do not worry about objects
10914 -- with address clauses in this context since they are not really
10915 -- imported in the linker sense.
10918 and then not Is_Library_Level_Entity
(E
)
10919 and then No
(Address_Clause
(E
))
10921 Set_Is_Statically_Allocated
(E
);
10928 -------------------------
10929 -- Set_Mechanism_Value --
10930 -------------------------
10932 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10933 -- analyzed, since it is semantic nonsense), so we get it in the exact
10934 -- form created by the parser.
10936 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10937 procedure Bad_Mechanism
;
10938 pragma No_Return
(Bad_Mechanism
);
10939 -- Signal bad mechanism name
10941 -------------------
10942 -- Bad_Mechanism --
10943 -------------------
10945 procedure Bad_Mechanism
is
10947 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10950 -- Start of processing for Set_Mechanism_Value
10953 if Mechanism
(Ent
) /= Default_Mechanism
then
10955 ("mechanism for & has already been set", Mech_Name
, Ent
);
10958 -- MECHANISM_NAME ::= value | reference
10960 if Nkind
(Mech_Name
) = N_Identifier
then
10961 if Chars
(Mech_Name
) = Name_Value
then
10962 Set_Mechanism
(Ent
, By_Copy
);
10965 elsif Chars
(Mech_Name
) = Name_Reference
then
10966 Set_Mechanism
(Ent
, By_Reference
);
10969 elsif Chars
(Mech_Name
) = Name_Copy
then
10971 ("bad mechanism name, Value assumed", Mech_Name
);
10980 end Set_Mechanism_Value
;
10982 --------------------------
10983 -- Set_Rational_Profile --
10984 --------------------------
10986 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10987 -- extension to the semantics of renaming declarations.
10989 procedure Set_Rational_Profile
is
10991 Implicit_Packing
:= True;
10992 Overriding_Renamings
:= True;
10993 Use_VADS_Size
:= True;
10994 end Set_Rational_Profile
;
10996 ---------------------------
10997 -- Set_Ravenscar_Profile --
10998 ---------------------------
11000 -- The tasks to be done here are
11002 -- Set required policies
11004 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11005 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11006 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11007 -- (For GNAT_Ravenscar_EDF profile)
11008 -- pragma Locking_Policy (Ceiling_Locking)
11010 -- Set Detect_Blocking mode
11012 -- Set required restrictions (see System.Rident for detailed list)
11014 -- Set the No_Dependence rules
11015 -- No_Dependence => Ada.Asynchronous_Task_Control
11016 -- No_Dependence => Ada.Calendar
11017 -- No_Dependence => Ada.Execution_Time.Group_Budget
11018 -- No_Dependence => Ada.Execution_Time.Timers
11019 -- No_Dependence => Ada.Task_Attributes
11020 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11022 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11023 procedure Set_Error_Msg_To_Profile_Name
;
11024 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11027 -----------------------------------
11028 -- Set_Error_Msg_To_Profile_Name --
11029 -----------------------------------
11031 procedure Set_Error_Msg_To_Profile_Name
is
11032 Prof_Nam
: constant Node_Id
:=
11034 (First
(Pragma_Argument_Associations
(N
)));
11037 Get_Name_String
(Chars
(Prof_Nam
));
11038 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11039 Error_Msg_Strlen
:= Name_Len
;
11040 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11041 end Set_Error_Msg_To_Profile_Name
;
11050 Profile_Dispatching_Policy
: Character;
11052 -- Start of processing for Set_Ravenscar_Profile
11055 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11057 if Profile
= GNAT_Ravenscar_EDF
then
11058 Profile_Dispatching_Policy
:= 'E';
11060 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11063 Profile_Dispatching_Policy
:= 'F';
11066 if Task_Dispatching_Policy
/= ' '
11067 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11069 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11070 Set_Error_Msg_To_Profile_Name
;
11071 Error_Pragma
("Profile (~) incompatible with policy#");
11073 -- Set the FIFO_Within_Priorities policy, but always preserve
11074 -- System_Location since we like the error message with the run time
11078 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11080 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11081 Task_Dispatching_Policy_Sloc
:= Loc
;
11085 -- pragma Locking_Policy (Ceiling_Locking)
11087 if Locking_Policy
/= ' '
11088 and then Locking_Policy
/= 'C'
11090 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11091 Set_Error_Msg_To_Profile_Name
;
11092 Error_Pragma
("Profile (~) incompatible with policy#");
11094 -- Set the Ceiling_Locking policy, but preserve System_Location since
11095 -- we like the error message with the run time name.
11098 Locking_Policy
:= 'C';
11100 if Locking_Policy_Sloc
/= System_Location
then
11101 Locking_Policy_Sloc
:= Loc
;
11105 -- pragma Detect_Blocking
11107 Detect_Blocking
:= True;
11109 -- Set the corresponding restrictions
11111 Set_Profile_Restrictions
11112 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11114 -- Set the No_Dependence restrictions
11116 -- The following No_Dependence restrictions:
11117 -- No_Dependence => Ada.Asynchronous_Task_Control
11118 -- No_Dependence => Ada.Calendar
11119 -- No_Dependence => Ada.Task_Attributes
11120 -- are already set by previous call to Set_Profile_Restrictions.
11122 -- Set the following restrictions which were added to Ada 2005:
11123 -- No_Dependence => Ada.Execution_Time.Group_Budget
11124 -- No_Dependence => Ada.Execution_Time.Timers
11126 if Ada_Version
>= Ada_2005
then
11127 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
11128 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
11131 Make_Selected_Component
11134 Selector_Name
=> Sel_Id
);
11136 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
11139 Make_Selected_Component
11142 Selector_Name
=> Sel_Id
);
11144 Set_Restriction_No_Dependence
11146 Warn
=> Treat_Restrictions_As_Warnings
,
11147 Profile
=> Ravenscar
);
11149 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
11152 Make_Selected_Component
11155 Selector_Name
=> Sel_Id
);
11157 Set_Restriction_No_Dependence
11159 Warn
=> Treat_Restrictions_As_Warnings
,
11160 Profile
=> Ravenscar
);
11163 -- Set the following restriction which was added to Ada 2012 (see
11165 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11167 if Ada_Version
>= Ada_2012
then
11168 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
11169 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
11172 Make_Selected_Component
11175 Selector_Name
=> Sel_Id
);
11177 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
11180 Make_Selected_Component
11183 Selector_Name
=> Sel_Id
);
11185 Set_Restriction_No_Dependence
11187 Warn
=> Treat_Restrictions_As_Warnings
,
11188 Profile
=> Ravenscar
);
11190 end Set_Ravenscar_Profile
;
11192 -----------------------------------
11193 -- Validate_Acc_Condition_Clause --
11194 -----------------------------------
11196 procedure Validate_Acc_Condition_Clause
(Clause
: Node_Id
) is
11198 Analyze_And_Resolve
(Clause
);
11200 if not Is_Boolean_Type
(Etype
(Clause
)) then
11201 Error_Pragma
("expected a boolean");
11203 end Validate_Acc_Condition_Clause
;
11205 ------------------------------
11206 -- Validate_Acc_Data_Clause --
11207 ------------------------------
11209 procedure Validate_Acc_Data_Clause
(Clause
: Node_Id
) is
11213 Expr
:= Acc_First
(Clause
);
11214 while Present
(Expr
) loop
11215 if Nkind
(Expr
) /= N_Identifier
then
11216 Error_Pragma
("expected an identifer");
11219 Analyze_And_Resolve
(Expr
);
11221 Expr
:= Acc_Next
(Expr
);
11223 end Validate_Acc_Data_Clause
;
11225 ----------------------------------
11226 -- Validate_Acc_Int_Expr_Clause --
11227 ----------------------------------
11229 procedure Validate_Acc_Int_Expr_Clause
(Clause
: Node_Id
) is
11231 Analyze_And_Resolve
(Clause
);
11233 if not Is_Integer_Type
(Etype
(Clause
)) then
11234 Error_Pragma_Arg
("expected an integer", Clause
);
11236 end Validate_Acc_Int_Expr_Clause
;
11238 ---------------------------------------
11239 -- Validate_Acc_Int_Expr_List_Clause --
11240 ---------------------------------------
11242 procedure Validate_Acc_Int_Expr_List_Clause
(Clause
: Node_Id
) is
11246 Expr
:= Acc_First
(Clause
);
11247 while Present
(Expr
) loop
11248 Analyze_And_Resolve
(Expr
);
11250 if not Is_Integer_Type
(Etype
(Expr
)) then
11251 Error_Pragma
("expected an integer");
11254 Expr
:= Acc_Next
(Expr
);
11256 end Validate_Acc_Int_Expr_List_Clause
;
11258 --------------------------------
11259 -- Validate_Acc_Loop_Collapse --
11260 --------------------------------
11262 procedure Validate_Acc_Loop_Collapse
(Clause
: Node_Id
) is
11264 Par_Loop
: Node_Id
;
11268 -- Make sure the argument is a positive integer
11270 Analyze_And_Resolve
(Clause
);
11272 Count
:= Static_Integer
(Clause
);
11273 if Count
= No_Uint
or else Count
< 1 then
11274 Error_Pragma_Arg
("expected a positive integer", Clause
);
11277 -- Then, make sure we have at least Count-1 tightly-nested loops
11278 -- (i.e. loops with no statements in between).
11280 Par_Loop
:= Parent
(Parent
(Parent
(Clause
)));
11281 Stmt
:= First
(Statements
(Par_Loop
));
11283 -- Skip first pragmas in the parent loop
11285 while Present
(Stmt
) and then Nkind
(Stmt
) = N_Pragma
loop
11289 if not Present
(Next
(Stmt
)) then
11290 while Nkind
(Stmt
) = N_Loop_Statement
and Count
> 1 loop
11291 Stmt
:= First
(Statements
(Stmt
));
11292 exit when Present
(Next
(Stmt
));
11294 Count
:= Count
- 1;
11300 ("Collapse argument too high or loops not tightly nested",
11303 end Validate_Acc_Loop_Collapse
;
11305 ----------------------------
11306 -- Validate_Acc_Loop_Gang --
11307 ----------------------------
11309 procedure Validate_Acc_Loop_Gang
(Clause
: Node_Id
) is
11311 Error_Pragma_Arg
("Loop_Gang not implemented", Clause
);
11312 end Validate_Acc_Loop_Gang
;
11314 ------------------------------
11315 -- Validate_Acc_Loop_Vector --
11316 ------------------------------
11318 procedure Validate_Acc_Loop_Vector
(Clause
: Node_Id
) is
11320 Error_Pragma_Arg
("Loop_Vector not implemented", Clause
);
11321 end Validate_Acc_Loop_Vector
;
11323 -------------------------------
11324 -- Validate_Acc_Loop_Worker --
11325 -------------------------------
11327 procedure Validate_Acc_Loop_Worker
(Clause
: Node_Id
) is
11329 Error_Pragma_Arg
("Loop_Worker not implemented", Clause
);
11330 end Validate_Acc_Loop_Worker
;
11332 ---------------------------------
11333 -- Validate_Acc_Name_Reduction --
11334 ---------------------------------
11336 procedure Validate_Acc_Name_Reduction
(Clause
: Node_Id
) is
11338 -- ??? On top of the following operations, the OpenAcc spec adds the
11339 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11340 -- ".neqv" for Fortran. Can we, should we and how do we support them
11343 type Reduction_Op
is (Add_Op
, Mul_Op
, Max_Op
, Min_Op
, And_Op
, Or_Op
);
11345 function To_Reduction_Op
(Op
: String) return Reduction_Op
;
11346 -- Convert operator Op described by a String into its corresponding
11347 -- enumeration value.
11349 ---------------------
11350 -- To_Reduction_Op --
11351 ---------------------
11353 function To_Reduction_Op
(Op
: String) return Reduction_Op
is
11358 elsif Op
= "*" then
11361 elsif Op
= "max" then
11364 elsif Op
= "min" then
11367 elsif Op
= "and" then
11370 elsif Op
= "or" then
11374 Error_Pragma
("unsuported reduction operation");
11376 end To_Reduction_Op
;
11380 Seen
: constant Elist_Id
:= New_Elmt_List
;
11383 Reduc_Op
: Node_Id
;
11384 Reduc_Var
: Node_Id
;
11386 -- Start of processing for Validate_Acc_Name_Reduction
11389 -- Reduction operations appear in the following form:
11390 -- ("+" => (a, b), "*" => c)
11392 Expr
:= First
(Component_Associations
(Clause
));
11393 while Present
(Expr
) loop
11394 Reduc_Op
:= First
(Choices
(Expr
));
11395 String_To_Name_Buffer
(Strval
(Reduc_Op
));
11397 case To_Reduction_Op
(Name_Buffer
(1 .. Name_Len
)) is
11403 Reduc_Var
:= Acc_First
(Expression
(Expr
));
11404 while Present
(Reduc_Var
) loop
11405 Analyze_And_Resolve
(Reduc_Var
);
11407 if Contains
(Seen
, Entity
(Reduc_Var
)) then
11408 Error_Pragma
("variable used in multiple reductions");
11411 if Nkind
(Reduc_Var
) /= N_Identifier
11412 or not Is_Numeric_Type
(Etype
(Reduc_Var
))
11415 ("expected an identifier for a Numeric");
11418 Append_Elmt
(Entity
(Reduc_Var
), Seen
);
11421 Reduc_Var
:= Acc_Next
(Reduc_Var
);
11427 Reduc_Var
:= Acc_First
(Expression
(Expr
));
11428 while Present
(Reduc_Var
) loop
11429 Analyze_And_Resolve
(Reduc_Var
);
11431 if Contains
(Seen
, Entity
(Reduc_Var
)) then
11432 Error_Pragma
("variable used in multiple reductions");
11435 if Nkind
(Reduc_Var
) /= N_Identifier
11436 or not Is_Boolean_Type
(Etype
(Reduc_Var
))
11439 ("expected a variable of type boolean");
11442 Append_Elmt
(Entity
(Reduc_Var
), Seen
);
11445 Reduc_Var
:= Acc_Next
(Reduc_Var
);
11451 end Validate_Acc_Name_Reduction
;
11453 -----------------------------------
11454 -- Validate_Acc_Size_Expressions --
11455 -----------------------------------
11457 procedure Validate_Acc_Size_Expressions
(Clause
: Node_Id
) is
11458 function Validate_Size_Expr
(Expr
: Node_Id
) return Boolean;
11459 -- A size expr is either an integer expression or "*"
11461 ------------------------
11462 -- Validate_Size_Expr --
11463 ------------------------
11465 function Validate_Size_Expr
(Expr
: Node_Id
) return Boolean is
11467 if Nkind
(Expr
) = N_Operator_Symbol
then
11468 return Get_String_Char
(Strval
(Expr
), 1) = Get_Char_Code
('*');
11471 Analyze_And_Resolve
(Expr
);
11473 return Is_Integer_Type
(Etype
(Expr
));
11474 end Validate_Size_Expr
;
11480 -- Start of processing for Validate_Acc_Size_Expressions
11483 Expr
:= Acc_First
(Clause
);
11484 while Present
(Expr
) loop
11485 if not Validate_Size_Expr
(Expr
) then
11487 ("Size expressions should be either integers or '*'");
11490 Expr
:= Acc_Next
(Expr
);
11492 end Validate_Acc_Size_Expressions
;
11494 -- Start of processing for Analyze_Pragma
11497 -- The following code is a defense against recursion. Not clear that
11498 -- this can happen legitimately, but perhaps some error situations can
11499 -- cause it, and we did see this recursion during testing.
11501 if Analyzed
(N
) then
11507 Check_Restriction_No_Use_Of_Pragma
(N
);
11509 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11510 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11512 if Should_Ignore_Pragma_Sem
(N
)
11513 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11514 and then Ignore_Rep_Clauses
)
11519 -- Deal with unrecognized pragma
11521 if not Is_Pragma_Name
(Pname
) then
11522 if Warn_On_Unrecognized_Pragma
then
11523 Error_Msg_Name_1
:= Pname
;
11524 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11526 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11527 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11528 Error_Msg_Name_1
:= PN
;
11529 Error_Msg_N
-- CODEFIX
11530 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11539 -- Here to start processing for recognized pragma
11541 Pname
:= Original_Aspect_Pragma_Name
(N
);
11543 -- Capture setting of Opt.Uneval_Old
11545 case Opt
.Uneval_Old
is
11547 Set_Uneval_Old_Accept
(N
);
11553 Set_Uneval_Old_Warn
(N
);
11556 raise Program_Error
;
11559 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11560 -- is already set, indicating that we have already checked the policy
11561 -- at the right point. This happens for example in the case of a pragma
11562 -- that is derived from an Aspect.
11564 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11567 -- For a pragma that is a rewriting of another pragma, copy the
11568 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11570 elsif Is_Rewrite_Substitution
(N
)
11571 and then Nkind
(Original_Node
(N
)) = N_Pragma
11573 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11574 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11576 -- Otherwise query the applicable policy at this point
11579 Check_Applicable_Policy
(N
);
11581 -- If pragma is disabled, rewrite as NULL and skip analysis
11583 if Is_Disabled
(N
) then
11584 Rewrite
(N
, Make_Null_Statement
(Loc
));
11590 -- Preset arguments
11598 if Present
(Pragma_Argument_Associations
(N
)) then
11599 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11600 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11602 if Present
(Arg1
) then
11603 Arg2
:= Next
(Arg1
);
11605 if Present
(Arg2
) then
11606 Arg3
:= Next
(Arg2
);
11608 if Present
(Arg3
) then
11609 Arg4
:= Next
(Arg3
);
11615 -- An enumeration type defines the pragmas that are supported by the
11616 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11617 -- into the corresponding enumeration value for the following case.
11625 -- pragma Abort_Defer;
11627 when Pragma_Abort_Defer
=>
11629 Check_Arg_Count
(0);
11631 -- The only required semantic processing is to check the
11632 -- placement. This pragma must appear at the start of the
11633 -- statement sequence of a handled sequence of statements.
11635 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11636 or else N
/= First
(Statements
(Parent
(N
)))
11641 --------------------
11642 -- Abstract_State --
11643 --------------------
11645 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11647 -- ABSTRACT_STATE_LIST ::=
11649 -- | STATE_NAME_WITH_OPTIONS
11650 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11652 -- STATE_NAME_WITH_OPTIONS ::=
11654 -- | (STATE_NAME with OPTION_LIST)
11656 -- OPTION_LIST ::= OPTION {, OPTION}
11660 -- | NAME_VALUE_OPTION
11662 -- SIMPLE_OPTION ::= Ghost | Synchronous
11664 -- NAME_VALUE_OPTION ::=
11665 -- Part_Of => ABSTRACT_STATE
11666 -- | External [=> EXTERNAL_PROPERTY_LIST]
11668 -- EXTERNAL_PROPERTY_LIST ::=
11669 -- EXTERNAL_PROPERTY
11670 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11672 -- EXTERNAL_PROPERTY ::=
11673 -- Async_Readers [=> boolean_EXPRESSION]
11674 -- | Async_Writers [=> boolean_EXPRESSION]
11675 -- | Effective_Reads [=> boolean_EXPRESSION]
11676 -- | Effective_Writes [=> boolean_EXPRESSION]
11677 -- others => boolean_EXPRESSION
11679 -- STATE_NAME ::= defining_identifier
11681 -- ABSTRACT_STATE ::= name
11683 -- Characteristics:
11685 -- * Analysis - The annotation is fully analyzed immediately upon
11686 -- elaboration as it cannot forward reference entities.
11688 -- * Expansion - None.
11690 -- * Template - The annotation utilizes the generic template of the
11691 -- related package declaration.
11693 -- * Globals - The annotation cannot reference global entities.
11695 -- * Instance - The annotation is instantiated automatically when
11696 -- the related generic package is instantiated.
11698 when Pragma_Abstract_State
=> Abstract_State
: declare
11699 Missing_Parentheses
: Boolean := False;
11700 -- Flag set when a state declaration with options is not properly
11703 -- Flags used to verify the consistency of states
11705 Non_Null_Seen
: Boolean := False;
11706 Null_Seen
: Boolean := False;
11708 procedure Analyze_Abstract_State
11710 Pack_Id
: Entity_Id
);
11711 -- Verify the legality of a single state declaration. Create and
11712 -- decorate a state abstraction entity and introduce it into the
11713 -- visibility chain. Pack_Id denotes the entity or the related
11714 -- package where pragma Abstract_State appears.
11716 procedure Malformed_State_Error
(State
: Node_Id
);
11717 -- Emit an error concerning the illegal declaration of abstract
11718 -- state State. This routine diagnoses syntax errors that lead to
11719 -- a different parse tree. The error is issued regardless of the
11720 -- SPARK mode in effect.
11722 ----------------------------
11723 -- Analyze_Abstract_State --
11724 ----------------------------
11726 procedure Analyze_Abstract_State
11728 Pack_Id
: Entity_Id
)
11730 -- Flags used to verify the consistency of options
11732 AR_Seen
: Boolean := False;
11733 AW_Seen
: Boolean := False;
11734 ER_Seen
: Boolean := False;
11735 EW_Seen
: Boolean := False;
11736 External_Seen
: Boolean := False;
11737 Ghost_Seen
: Boolean := False;
11738 Others_Seen
: Boolean := False;
11739 Part_Of_Seen
: Boolean := False;
11740 Synchronous_Seen
: Boolean := False;
11742 -- Flags used to store the static value of all external states'
11745 AR_Val
: Boolean := False;
11746 AW_Val
: Boolean := False;
11747 ER_Val
: Boolean := False;
11748 EW_Val
: Boolean := False;
11750 State_Id
: Entity_Id
:= Empty
;
11751 -- The entity to be generated for the current state declaration
11753 procedure Analyze_External_Option
(Opt
: Node_Id
);
11754 -- Verify the legality of option External
11756 procedure Analyze_External_Property
11758 Expr
: Node_Id
:= Empty
);
11759 -- Verify the legailty of a single external property. Prop
11760 -- denotes the external property. Expr is the expression used
11761 -- to set the property.
11763 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11764 -- Verify the legality of option Part_Of
11766 procedure Check_Duplicate_Option
11768 Status
: in out Boolean);
11769 -- Flag Status denotes whether a particular option has been
11770 -- seen while processing a state. This routine verifies that
11771 -- Opt is not a duplicate option and sets the flag Status
11772 -- (SPARK RM 7.1.4(1)).
11774 procedure Check_Duplicate_Property
11776 Status
: in out Boolean);
11777 -- Flag Status denotes whether a particular property has been
11778 -- seen while processing option External. This routine verifies
11779 -- that Prop is not a duplicate property and sets flag Status.
11780 -- Opt is not a duplicate property and sets the flag Status.
11781 -- (SPARK RM 7.1.4(2))
11783 procedure Check_Ghost_Synchronous
;
11784 -- Ensure that the abstract state is not subject to both Ghost
11785 -- and Synchronous simple options. Emit an error if this is the
11788 procedure Create_Abstract_State
11792 Is_Null
: Boolean);
11793 -- Generate an abstract state entity with name Nam and enter it
11794 -- into visibility. Decl is the "declaration" of the state as
11795 -- it appears in pragma Abstract_State. Loc is the location of
11796 -- the related state "declaration". Flag Is_Null should be set
11797 -- when the associated Abstract_State pragma defines a null
11800 -----------------------------
11801 -- Analyze_External_Option --
11802 -----------------------------
11804 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11805 Errors
: constant Nat
:= Serious_Errors_Detected
;
11807 Props
: Node_Id
:= Empty
;
11810 if Nkind
(Opt
) = N_Component_Association
then
11811 Props
:= Expression
(Opt
);
11814 -- External state with properties
11816 if Present
(Props
) then
11818 -- Multiple properties appear as an aggregate
11820 if Nkind
(Props
) = N_Aggregate
then
11822 -- Simple property form
11824 Prop
:= First
(Expressions
(Props
));
11825 while Present
(Prop
) loop
11826 Analyze_External_Property
(Prop
);
11830 -- Property with expression form
11832 Prop
:= First
(Component_Associations
(Props
));
11833 while Present
(Prop
) loop
11834 Analyze_External_Property
11835 (Prop
=> First
(Choices
(Prop
)),
11836 Expr
=> Expression
(Prop
));
11844 Analyze_External_Property
(Props
);
11847 -- An external state defined without any properties defaults
11848 -- all properties to True.
11857 -- Once all external properties have been processed, verify
11858 -- their mutual interaction. Do not perform the check when
11859 -- at least one of the properties is illegal as this will
11860 -- produce a bogus error.
11862 if Errors
= Serious_Errors_Detected
then
11863 Check_External_Properties
11864 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11866 end Analyze_External_Option
;
11868 -------------------------------
11869 -- Analyze_External_Property --
11870 -------------------------------
11872 procedure Analyze_External_Property
11874 Expr
: Node_Id
:= Empty
)
11876 Expr_Val
: Boolean;
11879 -- Check the placement of "others" (if available)
11881 if Nkind
(Prop
) = N_Others_Choice
then
11882 if Others_Seen
then
11884 ("only one others choice allowed in option External",
11887 Others_Seen
:= True;
11890 elsif Others_Seen
then
11892 ("others must be the last property in option External",
11895 -- The only remaining legal options are the four predefined
11896 -- external properties.
11898 elsif Nkind
(Prop
) = N_Identifier
11899 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11900 Name_Async_Writers
,
11901 Name_Effective_Reads
,
11902 Name_Effective_Writes
)
11906 -- Otherwise the construct is not a valid property
11909 SPARK_Msg_N
("invalid external state property", Prop
);
11913 -- Ensure that the expression of the external state property
11914 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11916 if Present
(Expr
) then
11917 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11919 if Is_OK_Static_Expression
(Expr
) then
11920 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11923 ("expression of external state property must be "
11928 -- The lack of expression defaults the property to True
11934 -- Named properties
11936 if Nkind
(Prop
) = N_Identifier
then
11937 if Chars
(Prop
) = Name_Async_Readers
then
11938 Check_Duplicate_Property
(Prop
, AR_Seen
);
11939 AR_Val
:= Expr_Val
;
11941 elsif Chars
(Prop
) = Name_Async_Writers
then
11942 Check_Duplicate_Property
(Prop
, AW_Seen
);
11943 AW_Val
:= Expr_Val
;
11945 elsif Chars
(Prop
) = Name_Effective_Reads
then
11946 Check_Duplicate_Property
(Prop
, ER_Seen
);
11947 ER_Val
:= Expr_Val
;
11950 Check_Duplicate_Property
(Prop
, EW_Seen
);
11951 EW_Val
:= Expr_Val
;
11954 -- The handling of property "others" must take into account
11955 -- all other named properties that have been encountered so
11956 -- far. Only those that have not been seen are affected by
11960 if not AR_Seen
then
11961 AR_Val
:= Expr_Val
;
11964 if not AW_Seen
then
11965 AW_Val
:= Expr_Val
;
11968 if not ER_Seen
then
11969 ER_Val
:= Expr_Val
;
11972 if not EW_Seen
then
11973 EW_Val
:= Expr_Val
;
11976 end Analyze_External_Property
;
11978 ----------------------------
11979 -- Analyze_Part_Of_Option --
11980 ----------------------------
11982 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11983 Encap
: constant Node_Id
:= Expression
(Opt
);
11984 Constits
: Elist_Id
;
11985 Encap_Id
: Entity_Id
;
11989 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11992 (Indic
=> First
(Choices
(Opt
)),
11993 Item_Id
=> State_Id
,
11995 Encap_Id
=> Encap_Id
,
11998 -- The Part_Of indicator transforms the abstract state into
11999 -- a constituent of the encapsulating state or single
12000 -- concurrent type.
12003 pragma Assert
(Present
(Encap_Id
));
12004 Constits
:= Part_Of_Constituents
(Encap_Id
);
12006 if No
(Constits
) then
12007 Constits
:= New_Elmt_List
;
12008 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12011 Append_Elmt
(State_Id
, Constits
);
12012 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12014 end Analyze_Part_Of_Option
;
12016 ----------------------------
12017 -- Check_Duplicate_Option --
12018 ----------------------------
12020 procedure Check_Duplicate_Option
12022 Status
: in out Boolean)
12026 SPARK_Msg_N
("duplicate state option", Opt
);
12030 end Check_Duplicate_Option
;
12032 ------------------------------
12033 -- Check_Duplicate_Property --
12034 ------------------------------
12036 procedure Check_Duplicate_Property
12038 Status
: in out Boolean)
12042 SPARK_Msg_N
("duplicate external property", Prop
);
12046 end Check_Duplicate_Property
;
12048 -----------------------------
12049 -- Check_Ghost_Synchronous --
12050 -----------------------------
12052 procedure Check_Ghost_Synchronous
is
12054 -- A synchronized abstract state cannot be Ghost and vice
12055 -- versa (SPARK RM 6.9(19)).
12057 if Ghost_Seen
and Synchronous_Seen
then
12058 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12060 end Check_Ghost_Synchronous
;
12062 ---------------------------
12063 -- Create_Abstract_State --
12064 ---------------------------
12066 procedure Create_Abstract_State
12073 -- The abstract state may be semi-declared when the related
12074 -- package was withed through a limited with clause. In that
12075 -- case reuse the entity to fully declare the state.
12077 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12078 State_Id
:= Entity
(Decl
);
12080 -- Otherwise the elaboration of pragma Abstract_State
12081 -- declares the state.
12084 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12086 if Present
(Decl
) then
12087 Set_Entity
(Decl
, State_Id
);
12091 -- Null states never come from source
12093 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12094 Set_Parent
(State_Id
, State
);
12095 Set_Ekind
(State_Id
, E_Abstract_State
);
12096 Set_Etype
(State_Id
, Standard_Void_Type
);
12097 Set_Encapsulating_State
(State_Id
, Empty
);
12099 -- Set the SPARK mode from the current context
12101 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12102 Set_SPARK_Pragma_Inherited
(State_Id
);
12104 -- An abstract state declared within a Ghost region becomes
12105 -- Ghost (SPARK RM 6.9(2)).
12107 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12108 Set_Is_Ghost_Entity
(State_Id
);
12111 -- Establish a link between the state declaration and the
12112 -- abstract state entity. Note that a null state remains as
12113 -- N_Null and does not carry any linkages.
12115 if not Is_Null
then
12116 if Present
(Decl
) then
12117 Set_Entity
(Decl
, State_Id
);
12118 Set_Etype
(Decl
, Standard_Void_Type
);
12121 -- Every non-null state must be defined, nameable and
12124 Push_Scope
(Pack_Id
);
12125 Generate_Definition
(State_Id
);
12126 Enter_Name
(State_Id
);
12129 end Create_Abstract_State
;
12136 -- Start of processing for Analyze_Abstract_State
12139 -- A package with a null abstract state is not allowed to
12140 -- declare additional states.
12144 ("package & has null abstract state", State
, Pack_Id
);
12146 -- Null states appear as internally generated entities
12148 elsif Nkind
(State
) = N_Null
then
12149 Create_Abstract_State
12150 (Nam
=> New_Internal_Name
('S'),
12152 Loc
=> Sloc
(State
),
12156 -- Catch a case where a null state appears in a list of
12157 -- non-null states.
12159 if Non_Null_Seen
then
12161 ("package & has non-null abstract state",
12165 -- Simple state declaration
12167 elsif Nkind
(State
) = N_Identifier
then
12168 Create_Abstract_State
12169 (Nam
=> Chars
(State
),
12171 Loc
=> Sloc
(State
),
12173 Non_Null_Seen
:= True;
12175 -- State declaration with various options. This construct
12176 -- appears as an extension aggregate in the tree.
12178 elsif Nkind
(State
) = N_Extension_Aggregate
then
12179 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12180 Create_Abstract_State
12181 (Nam
=> Chars
(Ancestor_Part
(State
)),
12182 Decl
=> Ancestor_Part
(State
),
12183 Loc
=> Sloc
(Ancestor_Part
(State
)),
12185 Non_Null_Seen
:= True;
12188 ("state name must be an identifier",
12189 Ancestor_Part
(State
));
12192 -- Options External, Ghost and Synchronous appear as
12195 Opt
:= First
(Expressions
(State
));
12196 while Present
(Opt
) loop
12197 if Nkind
(Opt
) = N_Identifier
then
12201 if Chars
(Opt
) = Name_External
then
12202 Check_Duplicate_Option
(Opt
, External_Seen
);
12203 Analyze_External_Option
(Opt
);
12207 elsif Chars
(Opt
) = Name_Ghost
then
12208 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12209 Check_Ghost_Synchronous
;
12211 if Present
(State_Id
) then
12212 Set_Is_Ghost_Entity
(State_Id
);
12217 elsif Chars
(Opt
) = Name_Synchronous
then
12218 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12219 Check_Ghost_Synchronous
;
12221 -- Option Part_Of without an encapsulating state is
12222 -- illegal (SPARK RM 7.1.4(9)).
12224 elsif Chars
(Opt
) = Name_Part_Of
then
12226 ("indicator Part_Of must denote abstract state, "
12227 & "single protected type or single task type",
12230 -- Do not emit an error message when a previous state
12231 -- declaration with options was not parenthesized as
12232 -- the option is actually another state declaration.
12234 -- with Abstract_State
12235 -- (State_1 with ..., -- missing parentheses
12236 -- (State_2 with ...),
12237 -- State_3) -- ok state declaration
12239 elsif Missing_Parentheses
then
12242 -- Otherwise the option is not allowed. Note that it
12243 -- is not possible to distinguish between an option
12244 -- and a state declaration when a previous state with
12245 -- options not properly parentheses.
12247 -- with Abstract_State
12248 -- (State_1 with ..., -- missing parentheses
12249 -- State_2); -- could be an option
12253 ("simple option not allowed in state declaration",
12257 -- Catch a case where missing parentheses around a state
12258 -- declaration with options cause a subsequent state
12259 -- declaration with options to be treated as an option.
12261 -- with Abstract_State
12262 -- (State_1 with ..., -- missing parentheses
12263 -- (State_2 with ...))
12265 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12266 Missing_Parentheses
:= True;
12268 ("state declaration must be parenthesized",
12269 Ancestor_Part
(State
));
12271 -- Otherwise the option is malformed
12274 SPARK_Msg_N
("malformed option", Opt
);
12280 -- Options External and Part_Of appear as component
12283 Opt
:= First
(Component_Associations
(State
));
12284 while Present
(Opt
) loop
12285 Opt_Nam
:= First
(Choices
(Opt
));
12287 if Nkind
(Opt_Nam
) = N_Identifier
then
12288 if Chars
(Opt_Nam
) = Name_External
then
12289 Analyze_External_Option
(Opt
);
12291 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12292 Analyze_Part_Of_Option
(Opt
);
12295 SPARK_Msg_N
("invalid state option", Opt
);
12298 SPARK_Msg_N
("invalid state option", Opt
);
12304 -- Any other attempt to declare a state is illegal
12307 Malformed_State_Error
(State
);
12311 -- Guard against a junk state. In such cases no entity is
12312 -- generated and the subsequent checks cannot be applied.
12314 if Present
(State_Id
) then
12316 -- Verify whether the state does not introduce an illegal
12317 -- hidden state within a package subject to a null abstract
12320 Check_No_Hidden_State
(State_Id
);
12322 -- Check whether the lack of option Part_Of agrees with the
12323 -- placement of the abstract state with respect to the state
12326 if not Part_Of_Seen
then
12327 Check_Missing_Part_Of
(State_Id
);
12330 -- Associate the state with its related package
12332 if No
(Abstract_States
(Pack_Id
)) then
12333 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12336 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12338 end Analyze_Abstract_State
;
12340 ---------------------------
12341 -- Malformed_State_Error --
12342 ---------------------------
12344 procedure Malformed_State_Error
(State
: Node_Id
) is
12346 Error_Msg_N
("malformed abstract state declaration", State
);
12348 -- An abstract state with a simple option is being declared
12349 -- with "=>" rather than the legal "with". The state appears
12350 -- as a component association.
12352 if Nkind
(State
) = N_Component_Association
then
12353 Error_Msg_N
("\use WITH to specify simple option", State
);
12355 end Malformed_State_Error
;
12359 Pack_Decl
: Node_Id
;
12360 Pack_Id
: Entity_Id
;
12364 -- Start of processing for Abstract_State
12368 Check_No_Identifiers
;
12369 Check_Arg_Count
(1);
12371 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12373 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
12374 N_Package_Declaration
)
12380 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12382 -- A pragma that applies to a Ghost entity becomes Ghost for the
12383 -- purposes of legality checks and removal of ignored Ghost code.
12385 Mark_Ghost_Pragma
(N
, Pack_Id
);
12386 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12388 -- Chain the pragma on the contract for completeness
12390 Add_Contract_Item
(N
, Pack_Id
);
12392 -- The legality checks of pragmas Abstract_State, Initializes, and
12393 -- Initial_Condition are affected by the SPARK mode in effect. In
12394 -- addition, these three pragmas are subject to an inherent order:
12396 -- 1) Abstract_State
12398 -- 3) Initial_Condition
12400 -- Analyze all these pragmas in the order outlined above
12402 Analyze_If_Present
(Pragma_SPARK_Mode
);
12403 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12405 -- Multiple non-null abstract states appear as an aggregate
12407 if Nkind
(States
) = N_Aggregate
then
12408 State
:= First
(Expressions
(States
));
12409 while Present
(State
) loop
12410 Analyze_Abstract_State
(State
, Pack_Id
);
12414 -- An abstract state with a simple option is being illegaly
12415 -- declared with "=>" rather than "with". In this case the
12416 -- state declaration appears as a component association.
12418 if Present
(Component_Associations
(States
)) then
12419 State
:= First
(Component_Associations
(States
));
12420 while Present
(State
) loop
12421 Malformed_State_Error
(State
);
12426 -- Various forms of a single abstract state. Note that these may
12427 -- include malformed state declarations.
12430 Analyze_Abstract_State
(States
, Pack_Id
);
12433 Analyze_If_Present
(Pragma_Initializes
);
12434 Analyze_If_Present
(Pragma_Initial_Condition
);
12435 end Abstract_State
;
12441 when Pragma_Acc_Data
=> Acc_Data
: declare
12442 Clause_Names
: constant Name_List
:=
12455 Clauses
: Args_List
(Clause_Names
'Range);
12458 if not OpenAcc_Enabled
then
12464 if Nkind
(Parent
(N
)) /= N_Loop_Statement
then
12466 ("Acc_Data pragma should be placed in loop or block "
12470 Gather_Associations
(Clause_Names
, Clauses
);
12472 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12473 Clause
:= Clauses
(Id
);
12475 if Present
(Clause
) then
12476 case Clause_Names
(Id
) is
12484 Validate_Acc_Data_Clause
(Clause
);
12491 Error_Pragma
("unsupported pragma clause");
12494 raise Program_Error
;
12499 Set_Is_OpenAcc_Environment
(Parent
(N
));
12506 when Pragma_Acc_Loop
=> Acc_Loop
: declare
12507 Clause_Names
: constant Name_List
:=
12520 Clauses
: Args_List
(Clause_Names
'Range);
12524 if not OpenAcc_Enabled
then
12530 -- Make sure the pragma is in an openacc construct
12532 Check_Loop_Pragma_Placement
;
12535 while Present
(Par
)
12536 and then (Nkind
(Par
) /= N_Loop_Statement
12537 or else not Is_OpenAcc_Environment
(Par
))
12539 Par
:= Parent
(Par
);
12542 if not Is_OpenAcc_Environment
(Par
) then
12544 ("Acc_Loop directive must be associated with an OpenAcc "
12545 & "construct region");
12548 Gather_Associations
(Clause_Names
, Clauses
);
12550 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12551 Clause
:= Clauses
(Id
);
12553 if Present
(Clause
) then
12554 case Clause_Names
(Id
) is
12561 when Name_Collapse
=>
12562 Validate_Acc_Loop_Collapse
(Clause
);
12565 Validate_Acc_Loop_Gang
(Clause
);
12567 when Name_Acc_Private
=>
12568 Validate_Acc_Data_Clause
(Clause
);
12570 when Name_Reduction
=>
12571 Validate_Acc_Name_Reduction
(Clause
);
12574 Validate_Acc_Size_Expressions
(Clause
);
12576 when Name_Vector
=>
12577 Validate_Acc_Loop_Vector
(Clause
);
12579 when Name_Worker
=>
12580 Validate_Acc_Loop_Worker
(Clause
);
12583 raise Program_Error
;
12588 Set_Is_OpenAcc_Loop
(Parent
(N
));
12591 ----------------------------------
12592 -- Acc_Parallel and Acc_Kernels --
12593 ----------------------------------
12595 when Pragma_Acc_Parallel
12596 | Pragma_Acc_Kernels
12598 Acc_Kernels_Or_Parallel
: declare
12599 Clause_Names
: constant Name_List
:=
12612 Name_Vector_Length
,
12618 Name_First_Private
,
12627 Clauses
: Args_List
(Clause_Names
'Range);
12630 if not OpenAcc_Enabled
then
12635 Check_Loop_Pragma_Placement
;
12637 if Nkind
(Parent
(N
)) /= N_Loop_Statement
then
12639 ("pragma should be placed in loop or block statements");
12642 Gather_Associations
(Clause_Names
, Clauses
);
12644 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12645 Clause
:= Clauses
(Id
);
12647 if Present
(Clause
) then
12648 if Chars
(Parent
(Clause
)) = No_Name
then
12649 Error_Pragma
("all arguments should be associations");
12651 case Clause_Names
(Id
) is
12653 -- Note: According to the OpenAcc Standard v2.6,
12654 -- Async's argument should be optional. Because this
12655 -- complicates parsing the clause, the argument is
12656 -- made mandatory. The standard defines two negative
12657 -- values, acc_async_noval and acc_async_sync. When
12658 -- given acc_async_noval as value, the clause should
12659 -- behave as if no argument was given. According to
12660 -- the standard, acc_async_noval is defined in header
12661 -- files for C and Fortran, thus this value should
12662 -- probably be defined in the OpenAcc Ada library once
12663 -- it is implemented.
12668 | Name_Vector_Length
12670 Validate_Acc_Int_Expr_Clause
(Clause
);
12672 when Name_Acc_If
=>
12673 Validate_Acc_Condition_Clause
(Clause
);
12675 -- Unsupported by GCC
12680 Error_Pragma
("unsupported clause");
12682 when Name_Acc_Private
12683 | Name_First_Private
12685 if Prag_Id
/= Pragma_Acc_Parallel
then
12687 ("argument is only available for 'Parallel' "
12690 Validate_Acc_Data_Clause
(Clause
);
12700 Validate_Acc_Data_Clause
(Clause
);
12702 when Name_Reduction
=>
12703 if Prag_Id
/= Pragma_Acc_Parallel
then
12705 ("argument is only available for 'Parallel' "
12708 Validate_Acc_Name_Reduction
(Clause
);
12711 when Name_Default
=>
12712 if Chars
(Clause
) /= Name_None
then
12713 Error_Pragma
("expected none");
12716 when Name_Device_Type
=>
12717 Error_Pragma
("unsupported pragma clause");
12719 -- Similar to Name_Async, Name_Wait's arguments should
12720 -- be optional. However, this can be simulated using
12721 -- acc_async_noval, hence, we do not bother making the
12722 -- argument optional for now.
12725 Validate_Acc_Int_Expr_List_Clause
(Clause
);
12728 raise Program_Error
;
12734 Set_Is_OpenAcc_Environment
(Parent
(N
));
12735 end Acc_Kernels_Or_Parallel
;
12743 -- Note: this pragma also has some specific processing in Par.Prag
12744 -- because we want to set the Ada version mode during parsing.
12746 when Pragma_Ada_83
=>
12748 Check_Arg_Count
(0);
12750 -- We really should check unconditionally for proper configuration
12751 -- pragma placement, since we really don't want mixed Ada modes
12752 -- within a single unit, and the GNAT reference manual has always
12753 -- said this was a configuration pragma, but we did not check and
12754 -- are hesitant to add the check now.
12756 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12757 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12758 -- or Ada 2012 mode.
12760 if Ada_Version
>= Ada_2005
then
12761 Check_Valid_Configuration_Pragma
;
12764 -- Now set Ada 83 mode
12766 if Latest_Ada_Only
then
12767 Error_Pragma
("??pragma% ignored");
12769 Ada_Version
:= Ada_83
;
12770 Ada_Version_Explicit
:= Ada_83
;
12771 Ada_Version_Pragma
:= N
;
12780 -- Note: this pragma also has some specific processing in Par.Prag
12781 -- because we want to set the Ada 83 version mode during parsing.
12783 when Pragma_Ada_95
=>
12785 Check_Arg_Count
(0);
12787 -- We really should check unconditionally for proper configuration
12788 -- pragma placement, since we really don't want mixed Ada modes
12789 -- within a single unit, and the GNAT reference manual has always
12790 -- said this was a configuration pragma, but we did not check and
12791 -- are hesitant to add the check now.
12793 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12794 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12796 if Ada_Version
>= Ada_2005
then
12797 Check_Valid_Configuration_Pragma
;
12800 -- Now set Ada 95 mode
12802 if Latest_Ada_Only
then
12803 Error_Pragma
("??pragma% ignored");
12805 Ada_Version
:= Ada_95
;
12806 Ada_Version_Explicit
:= Ada_95
;
12807 Ada_Version_Pragma
:= N
;
12810 ---------------------
12811 -- Ada_05/Ada_2005 --
12812 ---------------------
12815 -- pragma Ada_05 (LOCAL_NAME);
12817 -- pragma Ada_2005;
12818 -- pragma Ada_2005 (LOCAL_NAME):
12820 -- Note: these pragmas also have some specific processing in Par.Prag
12821 -- because we want to set the Ada 2005 version mode during parsing.
12823 -- The one argument form is used for managing the transition from
12824 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12825 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12826 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12827 -- mode, a preference rule is established which does not choose
12828 -- such an entity unless it is unambiguously specified. This avoids
12829 -- extra subprograms marked this way from generating ambiguities in
12830 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12831 -- intended for exclusive use in the GNAT run-time library.
12842 if Arg_Count
= 1 then
12843 Check_Arg_Is_Local_Name
(Arg1
);
12844 E_Id
:= Get_Pragma_Arg
(Arg1
);
12846 if Etype
(E_Id
) = Any_Type
then
12850 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12851 Record_Rep_Item
(Entity
(E_Id
), N
);
12854 Check_Arg_Count
(0);
12856 -- For Ada_2005 we unconditionally enforce the documented
12857 -- configuration pragma placement, since we do not want to
12858 -- tolerate mixed modes in a unit involving Ada 2005. That
12859 -- would cause real difficulties for those cases where there
12860 -- are incompatibilities between Ada 95 and Ada 2005.
12862 Check_Valid_Configuration_Pragma
;
12864 -- Now set appropriate Ada mode
12866 if Latest_Ada_Only
then
12867 Error_Pragma
("??pragma% ignored");
12869 Ada_Version
:= Ada_2005
;
12870 Ada_Version_Explicit
:= Ada_2005
;
12871 Ada_Version_Pragma
:= N
;
12876 ---------------------
12877 -- Ada_12/Ada_2012 --
12878 ---------------------
12881 -- pragma Ada_12 (LOCAL_NAME);
12883 -- pragma Ada_2012;
12884 -- pragma Ada_2012 (LOCAL_NAME):
12886 -- Note: these pragmas also have some specific processing in Par.Prag
12887 -- because we want to set the Ada 2012 version mode during parsing.
12889 -- The one argument form is used for managing the transition from Ada
12890 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12891 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12892 -- mode will generate a warning. In addition, in any pre-Ada_2012
12893 -- mode, a preference rule is established which does not choose
12894 -- such an entity unless it is unambiguously specified. This avoids
12895 -- extra subprograms marked this way from generating ambiguities in
12896 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12897 -- intended for exclusive use in the GNAT run-time library.
12908 if Arg_Count
= 1 then
12909 Check_Arg_Is_Local_Name
(Arg1
);
12910 E_Id
:= Get_Pragma_Arg
(Arg1
);
12912 if Etype
(E_Id
) = Any_Type
then
12916 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12917 Record_Rep_Item
(Entity
(E_Id
), N
);
12920 Check_Arg_Count
(0);
12922 -- For Ada_2012 we unconditionally enforce the documented
12923 -- configuration pragma placement, since we do not want to
12924 -- tolerate mixed modes in a unit involving Ada 2012. That
12925 -- would cause real difficulties for those cases where there
12926 -- are incompatibilities between Ada 95 and Ada 2012. We could
12927 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12929 Check_Valid_Configuration_Pragma
;
12931 -- Now set appropriate Ada mode
12933 Ada_Version
:= Ada_2012
;
12934 Ada_Version_Explicit
:= Ada_2012
;
12935 Ada_Version_Pragma
:= N
;
12943 -- pragma Ada_2020;
12945 -- Note: this pragma also has some specific processing in Par.Prag
12946 -- because we want to set the Ada 2020 version mode during parsing.
12948 when Pragma_Ada_2020
=>
12951 Check_Arg_Count
(0);
12953 Check_Valid_Configuration_Pragma
;
12955 -- Now set appropriate Ada mode
12957 Ada_Version
:= Ada_2020
;
12958 Ada_Version_Explicit
:= Ada_2020
;
12959 Ada_Version_Pragma
:= N
;
12961 ----------------------
12962 -- All_Calls_Remote --
12963 ----------------------
12965 -- pragma All_Calls_Remote [(library_package_NAME)];
12967 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12968 Lib_Entity
: Entity_Id
;
12971 Check_Ada_83_Warning
;
12972 Check_Valid_Library_Unit_Pragma
;
12974 if Nkind
(N
) = N_Null_Statement
then
12978 Lib_Entity
:= Find_Lib_Unit_Name
;
12980 -- A pragma that applies to a Ghost entity becomes Ghost for the
12981 -- purposes of legality checks and removal of ignored Ghost code.
12983 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12985 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12987 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12988 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12989 Error_Pragma
("pragma% only apply to rci unit");
12991 -- Set flag for entity of the library unit
12994 Set_Has_All_Calls_Remote
(Lib_Entity
);
12997 end All_Calls_Remote
;
12999 ---------------------------
13000 -- Allow_Integer_Address --
13001 ---------------------------
13003 -- pragma Allow_Integer_Address;
13005 when Pragma_Allow_Integer_Address
=>
13007 Check_Valid_Configuration_Pragma
;
13008 Check_Arg_Count
(0);
13010 -- If Address is a private type, then set the flag to allow
13011 -- integer address values. If Address is not private, then this
13012 -- pragma has no purpose, so it is simply ignored. Not clear if
13013 -- there are any such targets now.
13015 if Opt
.Address_Is_Private
then
13016 Opt
.Allow_Integer_Address
:= True;
13024 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13025 -- ARG ::= NAME | EXPRESSION
13027 -- The first two arguments are by convention intended to refer to an
13028 -- external tool and a tool-specific function. These arguments are
13031 when Pragma_Annotate
=> Annotate
: declare
13038 Check_At_Least_N_Arguments
(1);
13040 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
13042 -- Determine whether the last argument is "Entity => local_NAME"
13043 -- and if it is, perform the required semantic checks. Remove the
13044 -- argument from further processing.
13046 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
13047 and then Chars
(Nam_Arg
) = Name_Entity
13049 Check_Arg_Is_Local_Name
(Nam_Arg
);
13050 Arg_Count
:= Arg_Count
- 1;
13052 -- A pragma that applies to a Ghost entity becomes Ghost for
13053 -- the purposes of legality checks and removal of ignored Ghost
13056 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
13057 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
13059 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
13062 -- Not allowed in compiler units (bootstrap issues)
13064 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
13067 -- Continue the processing with last argument removed for now
13069 Check_Arg_Is_Identifier
(Arg1
);
13070 Check_No_Identifiers
;
13073 -- The second parameter is optional, it is never analyzed
13078 -- Otherwise there is a second parameter
13081 -- The second parameter must be an identifier
13083 Check_Arg_Is_Identifier
(Arg2
);
13085 -- Process the remaining parameters (if any)
13087 Arg
:= Next
(Arg2
);
13088 while Present
(Arg
) loop
13089 Expr
:= Get_Pragma_Arg
(Arg
);
13092 if Is_Entity_Name
(Expr
) then
13095 -- For string literals, we assume Standard_String as the
13096 -- type, unless the string contains wide or wide_wide
13099 elsif Nkind
(Expr
) = N_String_Literal
then
13100 if Has_Wide_Wide_Character
(Expr
) then
13101 Resolve
(Expr
, Standard_Wide_Wide_String
);
13102 elsif Has_Wide_Character
(Expr
) then
13103 Resolve
(Expr
, Standard_Wide_String
);
13105 Resolve
(Expr
, Standard_String
);
13108 elsif Is_Overloaded
(Expr
) then
13109 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13120 -------------------------------------------------
13121 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13122 -------------------------------------------------
13125 -- ( [Check => ] Boolean_EXPRESSION
13126 -- [, [Message =>] Static_String_EXPRESSION]);
13128 -- pragma Assert_And_Cut
13129 -- ( [Check => ] Boolean_EXPRESSION
13130 -- [, [Message =>] Static_String_EXPRESSION]);
13133 -- ( [Check => ] Boolean_EXPRESSION
13134 -- [, [Message =>] Static_String_EXPRESSION]);
13136 -- pragma Loop_Invariant
13137 -- ( [Check => ] Boolean_EXPRESSION
13138 -- [, [Message =>] Static_String_EXPRESSION]);
13141 | Pragma_Assert_And_Cut
13143 | Pragma_Loop_Invariant
13146 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13147 -- Determine whether expression Expr contains a Loop_Entry
13148 -- attribute reference.
13150 -------------------------
13151 -- Contains_Loop_Entry --
13152 -------------------------
13154 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13155 Has_Loop_Entry
: Boolean := False;
13157 function Process
(N
: Node_Id
) return Traverse_Result
;
13158 -- Process function for traversal to look for Loop_Entry
13164 function Process
(N
: Node_Id
) return Traverse_Result
is
13166 if Nkind
(N
) = N_Attribute_Reference
13167 and then Attribute_Name
(N
) = Name_Loop_Entry
13169 Has_Loop_Entry
:= True;
13176 procedure Traverse
is new Traverse_Proc
(Process
);
13178 -- Start of processing for Contains_Loop_Entry
13182 return Has_Loop_Entry
;
13183 end Contains_Loop_Entry
;
13188 New_Args
: List_Id
;
13190 -- Start of processing for Assert
13193 -- Assert is an Ada 2005 RM-defined pragma
13195 if Prag_Id
= Pragma_Assert
then
13198 -- The remaining ones are GNAT pragmas
13204 Check_At_Least_N_Arguments
(1);
13205 Check_At_Most_N_Arguments
(2);
13206 Check_Arg_Order
((Name_Check
, Name_Message
));
13207 Check_Optional_Identifier
(Arg1
, Name_Check
);
13208 Expr
:= Get_Pragma_Arg
(Arg1
);
13210 -- Special processing for Loop_Invariant, Loop_Variant or for
13211 -- other cases where a Loop_Entry attribute is present. If the
13212 -- assertion pragma contains attribute Loop_Entry, ensure that
13213 -- the related pragma is within a loop.
13215 if Prag_Id
= Pragma_Loop_Invariant
13216 or else Prag_Id
= Pragma_Loop_Variant
13217 or else Contains_Loop_Entry
(Expr
)
13219 Check_Loop_Pragma_Placement
;
13221 -- Perform preanalysis to deal with embedded Loop_Entry
13224 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13227 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13228 -- a corresponding Check pragma:
13230 -- pragma Check (name, condition [, msg]);
13232 -- Where name is the identifier matching the pragma name. So
13233 -- rewrite pragma in this manner, transfer the message argument
13234 -- if present, and analyze the result
13236 -- Note: When dealing with a semantically analyzed tree, the
13237 -- information that a Check node N corresponds to a source Assert,
13238 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13239 -- pragma kind of Original_Node(N).
13241 New_Args
:= New_List
(
13242 Make_Pragma_Argument_Association
(Loc
,
13243 Expression
=> Make_Identifier
(Loc
, Pname
)),
13244 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13245 Expression
=> Expr
));
13247 if Arg_Count
> 1 then
13248 Check_Optional_Identifier
(Arg2
, Name_Message
);
13250 -- Provide semantic annnotations for optional argument, for
13251 -- ASIS use, before rewriting.
13253 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13254 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13257 -- Rewrite as Check pragma
13261 Chars
=> Name_Check
,
13262 Pragma_Argument_Associations
=> New_Args
));
13267 ----------------------
13268 -- Assertion_Policy --
13269 ----------------------
13271 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13273 -- The following form is Ada 2012 only, but we allow it in all modes
13275 -- Pragma Assertion_Policy (
13276 -- ASSERTION_KIND => POLICY_IDENTIFIER
13277 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13279 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13281 -- RM_ASSERTION_KIND ::= Assert |
13282 -- Static_Predicate |
13283 -- Dynamic_Predicate |
13288 -- Type_Invariant |
13289 -- Type_Invariant'Class
13291 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13293 -- Contract_Cases |
13295 -- Default_Initial_Condition |
13297 -- Initial_Condition |
13298 -- Loop_Invariant |
13304 -- Statement_Assertions
13306 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13307 -- ID_ASSERTION_KIND list contains implementation-defined additions
13308 -- recognized by GNAT. The effect is to control the behavior of
13309 -- identically named aspects and pragmas, depending on the specified
13310 -- policy identifier:
13312 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13314 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13315 -- implementation-defined addition that results in totally ignoring
13316 -- the corresponding assertion. If Disable is specified, then the
13317 -- argument of the assertion is not even analyzed. This is useful
13318 -- when the aspect/pragma argument references entities in a with'ed
13319 -- package that is replaced by a dummy package in the final build.
13321 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13322 -- and Type_Invariant'Class were recognized by the parser and
13323 -- transformed into references to the special internal identifiers
13324 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13325 -- processing is required here.
13327 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13328 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13329 -- Converts the assertion policy 'Suppressible' to either Check or
13330 -- Ignore based on whether checks are suppressed via -gnatp.
13332 --------------------------
13333 -- Resolve_Suppressible --
13334 --------------------------
13336 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13337 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13341 -- Transform policy argument Suppressible into either Ignore or
13342 -- Check depending on whether checks are enabled or suppressed.
13344 if Chars
(Arg
) = Name_Suppressible
then
13345 if Suppress_Checks
then
13346 Nam
:= Name_Ignore
;
13351 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13353 end Resolve_Suppressible
;
13365 -- This can always appear as a configuration pragma
13367 if Is_Configuration_Pragma
then
13370 -- It can also appear in a declarative part or package spec in Ada
13371 -- 2012 mode. We allow this in other modes, but in that case we
13372 -- consider that we have an Ada 2012 pragma on our hands.
13375 Check_Is_In_Decl_Part_Or_Package_Spec
;
13379 -- One argument case with no identifier (first form above)
13382 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13383 or else Chars
(Arg1
) = No_Name
)
13385 Check_Arg_Is_One_Of
(Arg1
,
13386 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13388 Resolve_Suppressible
(Arg1
);
13390 -- Treat one argument Assertion_Policy as equivalent to:
13392 -- pragma Check_Policy (Assertion, policy)
13394 -- So rewrite pragma in that manner and link on to the chain
13395 -- of Check_Policy pragmas, marking the pragma as analyzed.
13397 Policy
:= Get_Pragma_Arg
(Arg1
);
13401 Chars
=> Name_Check_Policy
,
13402 Pragma_Argument_Associations
=> New_List
(
13403 Make_Pragma_Argument_Association
(Loc
,
13404 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13406 Make_Pragma_Argument_Association
(Loc
,
13408 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13411 -- Here if we have two or more arguments
13414 Check_At_Least_N_Arguments
(1);
13417 -- Loop through arguments
13420 while Present
(Arg
) loop
13421 LocP
:= Sloc
(Arg
);
13423 -- Kind must be specified
13425 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13426 or else Chars
(Arg
) = No_Name
13429 ("missing assertion kind for pragma%", Arg
);
13432 -- Check Kind and Policy have allowed forms
13434 Kind
:= Chars
(Arg
);
13435 Policy
:= Get_Pragma_Arg
(Arg
);
13437 if not Is_Valid_Assertion_Kind
(Kind
) then
13439 ("invalid assertion kind for pragma%", Arg
);
13442 Check_Arg_Is_One_Of
(Arg
,
13443 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13445 Resolve_Suppressible
(Arg
);
13447 if Kind
= Name_Ghost
then
13449 -- The Ghost policy must be either Check or Ignore
13450 -- (SPARK RM 6.9(6)).
13452 if not Nam_In
(Chars
(Policy
), Name_Check
,
13456 ("argument of pragma % Ghost must be Check or "
13457 & "Ignore", Policy
);
13460 -- Pragma Assertion_Policy specifying a Ghost policy
13461 -- cannot occur within a Ghost subprogram or package
13462 -- (SPARK RM 6.9(14)).
13464 if Ghost_Mode
> None
then
13466 ("pragma % cannot appear within ghost subprogram or "
13471 -- Rewrite the Assertion_Policy pragma as a series of
13472 -- Check_Policy pragmas of the form:
13474 -- Check_Policy (Kind, Policy);
13476 -- Note: the insertion of the pragmas cannot be done with
13477 -- Insert_Action because in the configuration case, there
13478 -- are no scopes on the scope stack and the mechanism will
13481 Insert_Before_And_Analyze
(N
,
13483 Chars
=> Name_Check_Policy
,
13484 Pragma_Argument_Associations
=> New_List
(
13485 Make_Pragma_Argument_Association
(LocP
,
13486 Expression
=> Make_Identifier
(LocP
, Kind
)),
13487 Make_Pragma_Argument_Association
(LocP
,
13488 Expression
=> Policy
))));
13493 -- Rewrite the Assertion_Policy pragma as null since we have
13494 -- now inserted all the equivalent Check pragmas.
13496 Rewrite
(N
, Make_Null_Statement
(Loc
));
13499 end Assertion_Policy
;
13501 ------------------------------
13502 -- Assume_No_Invalid_Values --
13503 ------------------------------
13505 -- pragma Assume_No_Invalid_Values (On | Off);
13507 when Pragma_Assume_No_Invalid_Values
=>
13509 Check_Valid_Configuration_Pragma
;
13510 Check_Arg_Count
(1);
13511 Check_No_Identifiers
;
13512 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13514 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13515 Assume_No_Invalid_Values
:= True;
13517 Assume_No_Invalid_Values
:= False;
13520 --------------------------
13521 -- Attribute_Definition --
13522 --------------------------
13524 -- pragma Attribute_Definition
13525 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13526 -- [Entity =>] LOCAL_NAME,
13527 -- [Expression =>] EXPRESSION | NAME);
13529 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
13530 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13535 Check_Arg_Count
(3);
13536 Check_Optional_Identifier
(Arg1
, "attribute");
13537 Check_Optional_Identifier
(Arg2
, "entity");
13538 Check_Optional_Identifier
(Arg3
, "expression");
13540 if Nkind
(Attribute_Designator
) /= N_Identifier
then
13541 Error_Msg_N
("attribute name expected", Attribute_Designator
);
13545 Check_Arg_Is_Local_Name
(Arg2
);
13547 -- If the attribute is not recognized, then issue a warning (not
13548 -- an error), and ignore the pragma.
13550 Aname
:= Chars
(Attribute_Designator
);
13552 if not Is_Attribute_Name
(Aname
) then
13553 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
13557 -- Otherwise, rewrite the pragma as an attribute definition clause
13560 Make_Attribute_Definition_Clause
(Loc
,
13561 Name
=> Get_Pragma_Arg
(Arg2
),
13563 Expression
=> Get_Pragma_Arg
(Arg3
)));
13565 end Attribute_Definition
;
13567 ------------------------------------------------------------------
13568 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13569 ------------------------------------------------------------------
13571 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
13572 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
13573 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13574 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13576 when Pragma_Async_Readers
13577 | Pragma_Async_Writers
13578 | Pragma_Effective_Reads
13579 | Pragma_Effective_Writes
13581 Async_Effective
: declare
13582 Obj_Decl
: Node_Id
;
13583 Obj_Id
: Entity_Id
;
13587 Check_No_Identifiers
;
13588 Check_At_Most_N_Arguments
(1);
13590 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13592 -- Object declaration
13594 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
13599 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13601 -- Perform minimal verification to ensure that the argument is at
13602 -- least a variable. Subsequent finer grained checks will be done
13603 -- at the end of the declarative region the contains the pragma.
13605 if Ekind
(Obj_Id
) = E_Variable
then
13607 -- A pragma that applies to a Ghost entity becomes Ghost for
13608 -- the purposes of legality checks and removal of ignored Ghost
13611 Mark_Ghost_Pragma
(N
, Obj_Id
);
13613 -- Chain the pragma on the contract for further processing by
13614 -- Analyze_External_Property_In_Decl_Part.
13616 Add_Contract_Item
(N
, Obj_Id
);
13618 -- Analyze the Boolean expression (if any)
13620 if Present
(Arg1
) then
13621 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13624 -- Otherwise the external property applies to a constant
13627 Error_Pragma
("pragma % must apply to a volatile object");
13629 end Async_Effective
;
13635 -- pragma Asynchronous (LOCAL_NAME);
13637 when Pragma_Asynchronous
=> Asynchronous
: declare
13640 Formal
: Entity_Id
;
13645 procedure Process_Async_Pragma
;
13646 -- Common processing for procedure and access-to-procedure case
13648 --------------------------
13649 -- Process_Async_Pragma --
13650 --------------------------
13652 procedure Process_Async_Pragma
is
13655 Set_Is_Asynchronous
(Nm
);
13659 -- The formals should be of mode IN (RM E.4.1(6))
13662 while Present
(S
) loop
13663 Formal
:= Defining_Identifier
(S
);
13665 if Nkind
(Formal
) = N_Defining_Identifier
13666 and then Ekind
(Formal
) /= E_In_Parameter
13669 ("pragma% procedure can only have IN parameter",
13676 Set_Is_Asynchronous
(Nm
);
13677 end Process_Async_Pragma
;
13679 -- Start of processing for pragma Asynchronous
13682 Check_Ada_83_Warning
;
13683 Check_No_Identifiers
;
13684 Check_Arg_Count
(1);
13685 Check_Arg_Is_Local_Name
(Arg1
);
13687 if Debug_Flag_U
then
13691 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13692 Analyze
(Get_Pragma_Arg
(Arg1
));
13693 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
13695 -- A pragma that applies to a Ghost entity becomes Ghost for the
13696 -- purposes of legality checks and removal of ignored Ghost code.
13698 Mark_Ghost_Pragma
(N
, Nm
);
13700 if not Is_Remote_Call_Interface
(C_Ent
)
13701 and then not Is_Remote_Types
(C_Ent
)
13703 -- This pragma should only appear in an RCI or Remote Types
13704 -- unit (RM E.4.1(4)).
13707 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13710 if Ekind
(Nm
) = E_Procedure
13711 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
13713 if not Is_Remote_Call_Interface
(Nm
) then
13715 ("pragma% cannot be applied on non-remote procedure",
13719 L
:= Parameter_Specifications
(Parent
(Nm
));
13720 Process_Async_Pragma
;
13723 elsif Ekind
(Nm
) = E_Function
then
13725 ("pragma% cannot be applied to function", Arg1
);
13727 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
13728 if Is_Record_Type
(Nm
) then
13730 -- A record type that is the Equivalent_Type for a remote
13731 -- access-to-subprogram type.
13733 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13736 -- A non-expanded RAS type (distribution is not enabled)
13738 Decl
:= Declaration_Node
(Nm
);
13741 if Nkind
(Decl
) = N_Full_Type_Declaration
13742 and then Nkind
(Type_Definition
(Decl
)) =
13743 N_Access_Procedure_Definition
13745 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13746 Process_Async_Pragma
;
13748 if Is_Asynchronous
(Nm
)
13749 and then Expander_Active
13750 and then Get_PCS_Name
/= Name_No_DSA
13752 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13757 ("pragma% cannot reference access-to-function type",
13761 -- Only other possibility is Access-to-class-wide type
13763 elsif Is_Access_Type
(Nm
)
13764 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13766 Check_First_Subtype
(Arg1
);
13767 Set_Is_Asynchronous
(Nm
);
13768 if Expander_Active
then
13769 RACW_Type_Is_Asynchronous
(Nm
);
13773 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13781 -- pragma Atomic (LOCAL_NAME);
13783 when Pragma_Atomic
=>
13784 Process_Atomic_Independent_Shared_Volatile
;
13786 -----------------------
13787 -- Atomic_Components --
13788 -----------------------
13790 -- pragma Atomic_Components (array_LOCAL_NAME);
13792 -- This processing is shared by Volatile_Components
13794 when Pragma_Atomic_Components
13795 | Pragma_Volatile_Components
13797 Atomic_Components
: declare
13804 Check_Ada_83_Warning
;
13805 Check_No_Identifiers
;
13806 Check_Arg_Count
(1);
13807 Check_Arg_Is_Local_Name
(Arg1
);
13808 E_Id
:= Get_Pragma_Arg
(Arg1
);
13810 if Etype
(E_Id
) = Any_Type
then
13814 E
:= Entity
(E_Id
);
13816 -- A pragma that applies to a Ghost entity becomes Ghost for the
13817 -- purposes of legality checks and removal of ignored Ghost code.
13819 Mark_Ghost_Pragma
(N
, E
);
13820 Check_Duplicate_Pragma
(E
);
13822 if Rep_Item_Too_Early
(E
, N
)
13824 Rep_Item_Too_Late
(E
, N
)
13829 D
:= Declaration_Node
(E
);
13832 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13834 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13835 and then Nkind
(D
) = N_Object_Declaration
13836 and then Nkind
(Object_Definition
(D
)) =
13837 N_Constrained_Array_Definition
)
13839 -- The flag is set on the object, or on the base type
13841 if Nkind
(D
) /= N_Object_Declaration
then
13842 E
:= Base_Type
(E
);
13845 -- Atomic implies both Independent and Volatile
13847 if Prag_Id
= Pragma_Atomic_Components
then
13848 Set_Has_Atomic_Components
(E
);
13849 Set_Has_Independent_Components
(E
);
13852 Set_Has_Volatile_Components
(E
);
13855 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13857 end Atomic_Components
;
13859 --------------------
13860 -- Attach_Handler --
13861 --------------------
13863 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13865 when Pragma_Attach_Handler
=>
13866 Check_Ada_83_Warning
;
13867 Check_No_Identifiers
;
13868 Check_Arg_Count
(2);
13870 if No_Run_Time_Mode
then
13871 Error_Msg_CRT
("Attach_Handler pragma", N
);
13873 Check_Interrupt_Or_Attach_Handler
;
13875 -- The expression that designates the attribute may depend on a
13876 -- discriminant, and is therefore a per-object expression, to
13877 -- be expanded in the init proc. If expansion is enabled, then
13878 -- perform semantic checks on a copy only.
13883 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13886 -- In Relaxed_RM_Semantics mode, we allow any static
13887 -- integer value, for compatibility with other compilers.
13889 if Relaxed_RM_Semantics
13890 and then Nkind
(Parg2
) = N_Integer_Literal
13892 Typ
:= Standard_Integer
;
13894 Typ
:= RTE
(RE_Interrupt_ID
);
13897 if Expander_Active
then
13898 Temp
:= New_Copy_Tree
(Parg2
);
13899 Set_Parent
(Temp
, N
);
13900 Preanalyze_And_Resolve
(Temp
, Typ
);
13903 Resolve
(Parg2
, Typ
);
13907 Process_Interrupt_Or_Attach_Handler
;
13910 --------------------
13911 -- C_Pass_By_Copy --
13912 --------------------
13914 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13916 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13922 Check_Valid_Configuration_Pragma
;
13923 Check_Arg_Count
(1);
13924 Check_Optional_Identifier
(Arg1
, "max_size");
13926 Arg
:= Get_Pragma_Arg
(Arg1
);
13927 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13929 Val
:= Expr_Value
(Arg
);
13933 ("maximum size for pragma% must be positive", Arg1
);
13935 elsif UI_Is_In_Int_Range
(Val
) then
13936 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13938 -- If a giant value is given, Int'Last will do well enough.
13939 -- If sometime someone complains that a record larger than
13940 -- two gigabytes is not copied, we will worry about it then.
13943 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13945 end C_Pass_By_Copy
;
13951 -- pragma Check ([Name =>] CHECK_KIND,
13952 -- [Check =>] Boolean_EXPRESSION
13953 -- [,[Message =>] String_EXPRESSION]);
13955 -- CHECK_KIND ::= IDENTIFIER |
13958 -- Invariant'Class |
13959 -- Type_Invariant'Class
13961 -- The identifiers Assertions and Statement_Assertions are not
13962 -- allowed, since they have special meaning for Check_Policy.
13964 -- WARNING: The code below manages Ghost regions. Return statements
13965 -- must be replaced by gotos which jump to the end of the code and
13966 -- restore the Ghost mode.
13968 when Pragma_Check
=> Check
: declare
13969 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13970 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13971 -- Save the Ghost-related attributes to restore on exit
13977 pragma Warnings
(Off
, Str
);
13980 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13981 -- the mode now to ensure that any nodes generated during analysis
13982 -- and expansion are marked as Ghost.
13984 Set_Ghost_Mode
(N
);
13987 Check_At_Least_N_Arguments
(2);
13988 Check_At_Most_N_Arguments
(3);
13989 Check_Optional_Identifier
(Arg1
, Name_Name
);
13990 Check_Optional_Identifier
(Arg2
, Name_Check
);
13992 if Arg_Count
= 3 then
13993 Check_Optional_Identifier
(Arg3
, Name_Message
);
13994 Str
:= Get_Pragma_Arg
(Arg3
);
13997 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13998 Check_Arg_Is_Identifier
(Arg1
);
13999 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
14001 -- Check forbidden name Assertions or Statement_Assertions
14004 when Name_Assertions
=>
14006 ("""Assertions"" is not allowed as a check kind for "
14007 & "pragma%", Arg1
);
14009 when Name_Statement_Assertions
=>
14011 ("""Statement_Assertions"" is not allowed as a check kind "
14012 & "for pragma%", Arg1
);
14018 -- Check applicable policy. We skip this if Checked/Ignored status
14019 -- is already set (e.g. in the case of a pragma from an aspect).
14021 if Is_Checked
(N
) or else Is_Ignored
(N
) then
14024 -- For a non-source pragma that is a rewriting of another pragma,
14025 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14027 elsif Is_Rewrite_Substitution
(N
)
14028 and then Nkind
(Original_Node
(N
)) = N_Pragma
14030 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
14031 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
14033 -- Otherwise query the applicable policy at this point
14036 case Check_Kind
(Cname
) is
14037 when Name_Ignore
=>
14038 Set_Is_Ignored
(N
, True);
14039 Set_Is_Checked
(N
, False);
14042 Set_Is_Ignored
(N
, False);
14043 Set_Is_Checked
(N
, True);
14045 -- For disable, rewrite pragma as null statement and skip
14046 -- rest of the analysis of the pragma.
14048 when Name_Disable
=>
14049 Rewrite
(N
, Make_Null_Statement
(Loc
));
14053 -- No other possibilities
14056 raise Program_Error
;
14060 -- If check kind was not Disable, then continue pragma analysis
14062 Expr
:= Get_Pragma_Arg
(Arg2
);
14064 -- Deal with SCO generation
14066 if Is_Checked
(N
) and then not Split_PPC
(N
) then
14067 Set_SCO_Pragma_Enabled
(Loc
);
14070 -- Deal with analyzing the string argument. If checks are not
14071 -- on we don't want any expansion (since such expansion would
14072 -- not get properly deleted) but we do want to analyze (to get
14073 -- proper references). The Preanalyze_And_Resolve routine does
14074 -- just what we want. Ditto if pragma is active, because it will
14075 -- be rewritten as an if-statement whose analysis will complete
14076 -- analysis and expansion of the string message. This makes a
14077 -- difference in the unusual case where the expression for the
14078 -- string may have a side effect, such as raising an exception.
14079 -- This is mandated by RM 11.4.2, which specifies that the string
14080 -- expression is only evaluated if the check fails and
14081 -- Assertion_Error is to be raised.
14083 if Arg_Count
= 3 then
14084 Preanalyze_And_Resolve
(Str
, Standard_String
);
14087 -- Now you might think we could just do the same with the Boolean
14088 -- expression if checks are off (and expansion is on) and then
14089 -- rewrite the check as a null statement. This would work but we
14090 -- would lose the useful warnings about an assertion being bound
14091 -- to fail even if assertions are turned off.
14093 -- So instead we wrap the boolean expression in an if statement
14094 -- that looks like:
14096 -- if False and then condition then
14100 -- The reason we do this rewriting during semantic analysis rather
14101 -- than as part of normal expansion is that we cannot analyze and
14102 -- expand the code for the boolean expression directly, or it may
14103 -- cause insertion of actions that would escape the attempt to
14104 -- suppress the check code.
14106 -- Note that the Sloc for the if statement corresponds to the
14107 -- argument condition, not the pragma itself. The reason for
14108 -- this is that we may generate a warning if the condition is
14109 -- False at compile time, and we do not want to delete this
14110 -- warning when we delete the if statement.
14112 if Expander_Active
and Is_Ignored
(N
) then
14113 Eloc
:= Sloc
(Expr
);
14116 Make_If_Statement
(Eloc
,
14118 Make_And_Then
(Eloc
,
14119 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14120 Right_Opnd
=> Expr
),
14121 Then_Statements
=> New_List
(
14122 Make_Null_Statement
(Eloc
))));
14124 -- Now go ahead and analyze the if statement
14126 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14128 -- One rather special treatment. If we are now in Eliminated
14129 -- overflow mode, then suppress overflow checking since we do
14130 -- not want to drag in the bignum stuff if we are in Ignore
14131 -- mode anyway. This is particularly important if we are using
14132 -- a configurable run time that does not support bignum ops.
14134 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14136 Svo
: constant Boolean :=
14137 Scope_Suppress
.Suppress
(Overflow_Check
);
14139 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14140 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14142 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14143 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14146 -- Not that special case
14152 -- All done with this check
14154 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14156 -- Check is active or expansion not active. In these cases we can
14157 -- just go ahead and analyze the boolean with no worries.
14160 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14161 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14162 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14165 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14168 --------------------------
14169 -- Check_Float_Overflow --
14170 --------------------------
14172 -- pragma Check_Float_Overflow;
14174 when Pragma_Check_Float_Overflow
=>
14176 Check_Valid_Configuration_Pragma
;
14177 Check_Arg_Count
(0);
14178 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14184 -- pragma Check_Name (check_IDENTIFIER);
14186 when Pragma_Check_Name
=>
14188 Check_No_Identifiers
;
14189 Check_Valid_Configuration_Pragma
;
14190 Check_Arg_Count
(1);
14191 Check_Arg_Is_Identifier
(Arg1
);
14194 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14197 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14198 if Check_Names
.Table
(J
) = Nam
then
14203 Check_Names
.Append
(Nam
);
14210 -- This is the old style syntax, which is still allowed in all modes:
14212 -- pragma Check_Policy ([Name =>] CHECK_KIND
14213 -- [Policy =>] POLICY_IDENTIFIER);
14215 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14217 -- CHECK_KIND ::= IDENTIFIER |
14220 -- Type_Invariant'Class |
14223 -- This is the new style syntax, compatible with Assertion_Policy
14224 -- and also allowed in all modes.
14226 -- Pragma Check_Policy (
14227 -- CHECK_KIND => POLICY_IDENTIFIER
14228 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14230 -- Note: the identifiers Name and Policy are not allowed as
14231 -- Check_Kind values. This avoids ambiguities between the old and
14232 -- new form syntax.
14234 when Pragma_Check_Policy
=> Check_Policy
: declare
14239 Check_At_Least_N_Arguments
(1);
14241 -- A Check_Policy pragma can appear either as a configuration
14242 -- pragma, or in a declarative part or a package spec (see RM
14243 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14244 -- followed for Check_Policy).
14246 if not Is_Configuration_Pragma
then
14247 Check_Is_In_Decl_Part_Or_Package_Spec
;
14250 -- Figure out if we have the old or new syntax. We have the
14251 -- old syntax if the first argument has no identifier, or the
14252 -- identifier is Name.
14254 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14255 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
14259 Check_Arg_Count
(2);
14260 Check_Optional_Identifier
(Arg1
, Name_Name
);
14261 Kind
:= Get_Pragma_Arg
(Arg1
);
14262 Rewrite_Assertion_Kind
(Kind
,
14263 From_Policy
=> Comes_From_Source
(N
));
14264 Check_Arg_Is_Identifier
(Arg1
);
14266 -- Check forbidden check kind
14268 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
14269 Error_Msg_Name_2
:= Chars
(Kind
);
14271 ("pragma% does not allow% as check name", Arg1
);
14276 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14277 Check_Arg_Is_One_Of
14279 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14281 -- And chain pragma on the Check_Policy_List for search
14283 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14284 Opt
.Check_Policy_List
:= N
;
14286 -- For the new syntax, what we do is to convert each argument to
14287 -- an old syntax equivalent. We do that because we want to chain
14288 -- old style Check_Policy pragmas for the search (we don't want
14289 -- to have to deal with multiple arguments in the search).
14300 while Present
(Arg
) loop
14301 LocP
:= Sloc
(Arg
);
14302 Argx
:= Get_Pragma_Arg
(Arg
);
14304 -- Kind must be specified
14306 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14307 or else Chars
(Arg
) = No_Name
14310 ("missing assertion kind for pragma%", Arg
);
14313 -- Construct equivalent old form syntax Check_Policy
14314 -- pragma and insert it to get remaining checks.
14318 Chars
=> Name_Check_Policy
,
14319 Pragma_Argument_Associations
=> New_List
(
14320 Make_Pragma_Argument_Association
(LocP
,
14322 Make_Identifier
(LocP
, Chars
(Arg
))),
14323 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14324 Expression
=> Argx
)));
14328 -- For a configuration pragma, insert old form in
14329 -- the corresponding file.
14331 if Is_Configuration_Pragma
then
14332 Insert_After
(N
, New_P
);
14336 Insert_Action
(N
, New_P
);
14340 -- Rewrite original Check_Policy pragma to null, since we
14341 -- have converted it into a series of old syntax pragmas.
14343 Rewrite
(N
, Make_Null_Statement
(Loc
));
14353 -- pragma Comment (static_string_EXPRESSION)
14355 -- Processing for pragma Comment shares the circuitry for pragma
14356 -- Ident. The only differences are that Ident enforces a limit of 31
14357 -- characters on its argument, and also enforces limitations on
14358 -- placement for DEC compatibility. Pragma Comment shares neither of
14359 -- these restrictions.
14361 -------------------
14362 -- Common_Object --
14363 -------------------
14365 -- pragma Common_Object (
14366 -- [Internal =>] LOCAL_NAME
14367 -- [, [External =>] EXTERNAL_SYMBOL]
14368 -- [, [Size =>] EXTERNAL_SYMBOL]);
14370 -- Processing for this pragma is shared with Psect_Object
14372 ------------------------
14373 -- Compile_Time_Error --
14374 ------------------------
14376 -- pragma Compile_Time_Error
14377 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14379 when Pragma_Compile_Time_Error
=>
14381 Process_Compile_Time_Warning_Or_Error
;
14383 --------------------------
14384 -- Compile_Time_Warning --
14385 --------------------------
14387 -- pragma Compile_Time_Warning
14388 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14390 when Pragma_Compile_Time_Warning
=>
14392 Process_Compile_Time_Warning_Or_Error
;
14394 ---------------------------
14395 -- Compiler_Unit_Warning --
14396 ---------------------------
14398 -- pragma Compiler_Unit_Warning;
14402 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14403 -- errors not warnings. This means that we had introduced a big extra
14404 -- inertia to compiler changes, since even if we implemented a new
14405 -- feature, and even if all versions to be used for bootstrapping
14406 -- implemented this new feature, we could not use it, since old
14407 -- compilers would give errors for using this feature in units
14408 -- having Compiler_Unit pragmas.
14410 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14411 -- problem. We no longer have any units mentioning Compiler_Unit,
14412 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14413 -- and thus generates a warning which can be ignored. So that deals
14414 -- with the problem of old compilers not implementing the newer form
14417 -- Newer compilers recognize the new pragma, but generate warning
14418 -- messages instead of errors, which again can be ignored in the
14419 -- case of an old compiler which implements a wanted new feature
14420 -- but at the time felt like warning about it for older compilers.
14422 -- We retain Compiler_Unit so that new compilers can be used to build
14423 -- older run-times that use this pragma. That's an unusual case, but
14424 -- it's easy enough to handle, so why not?
14426 when Pragma_Compiler_Unit
14427 | Pragma_Compiler_Unit_Warning
14430 Check_Arg_Count
(0);
14432 -- Only recognized in main unit
14434 if Current_Sem_Unit
= Main_Unit
then
14435 Compiler_Unit
:= True;
14438 -----------------------------
14439 -- Complete_Representation --
14440 -----------------------------
14442 -- pragma Complete_Representation;
14444 when Pragma_Complete_Representation
=>
14446 Check_Arg_Count
(0);
14448 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14450 ("pragma & must appear within record representation clause");
14453 ----------------------------
14454 -- Complex_Representation --
14455 ----------------------------
14457 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14459 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14466 Check_Arg_Count
(1);
14467 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14468 Check_Arg_Is_Local_Name
(Arg1
);
14469 E_Id
:= Get_Pragma_Arg
(Arg1
);
14471 if Etype
(E_Id
) = Any_Type
then
14475 E
:= Entity
(E_Id
);
14477 if not Is_Record_Type
(E
) then
14479 ("argument for pragma% must be record type", Arg1
);
14482 Ent
:= First_Entity
(E
);
14485 or else No
(Next_Entity
(Ent
))
14486 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14487 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14488 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14491 ("record for pragma% must have two fields of the same "
14492 & "floating-point type", Arg1
);
14495 Set_Has_Complex_Representation
(Base_Type
(E
));
14497 -- We need to treat the type has having a non-standard
14498 -- representation, for back-end purposes, even though in
14499 -- general a complex will have the default representation
14500 -- of a record with two real components.
14502 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14504 end Complex_Representation
;
14506 -------------------------
14507 -- Component_Alignment --
14508 -------------------------
14510 -- pragma Component_Alignment (
14511 -- [Form =>] ALIGNMENT_CHOICE
14512 -- [, [Name =>] type_LOCAL_NAME]);
14514 -- ALIGNMENT_CHOICE ::=
14516 -- | Component_Size_4
14520 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
14521 Args
: Args_List
(1 .. 2);
14522 Names
: constant Name_List
(1 .. 2) := (
14526 Form
: Node_Id
renames Args
(1);
14527 Name
: Node_Id
renames Args
(2);
14529 Atype
: Component_Alignment_Kind
;
14534 Gather_Associations
(Names
, Args
);
14537 Error_Pragma
("missing Form argument for pragma%");
14540 Check_Arg_Is_Identifier
(Form
);
14542 -- Get proper alignment, note that Default = Component_Size on all
14543 -- machines we have so far, and we want to set this value rather
14544 -- than the default value to indicate that it has been explicitly
14545 -- set (and thus will not get overridden by the default component
14546 -- alignment for the current scope)
14548 if Chars
(Form
) = Name_Component_Size
then
14549 Atype
:= Calign_Component_Size
;
14551 elsif Chars
(Form
) = Name_Component_Size_4
then
14552 Atype
:= Calign_Component_Size_4
;
14554 elsif Chars
(Form
) = Name_Default
then
14555 Atype
:= Calign_Component_Size
;
14557 elsif Chars
(Form
) = Name_Storage_Unit
then
14558 Atype
:= Calign_Storage_Unit
;
14562 ("invalid Form parameter for pragma%", Form
);
14565 -- The pragma appears in a configuration file
14567 if No
(Parent
(N
)) then
14568 Check_Valid_Configuration_Pragma
;
14570 -- Capture the component alignment in a global variable when
14571 -- the pragma appears in a configuration file. Note that the
14572 -- scope stack is empty at this point and cannot be used to
14573 -- store the alignment value.
14575 Configuration_Component_Alignment
:= Atype
;
14577 -- Case with no name, supplied, affects scope table entry
14579 elsif No
(Name
) then
14581 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
14583 -- Case of name supplied
14586 Check_Arg_Is_Local_Name
(Name
);
14588 Typ
:= Entity
(Name
);
14591 or else Rep_Item_Too_Early
(Typ
, N
)
14595 Typ
:= Underlying_Type
(Typ
);
14598 if not Is_Record_Type
(Typ
)
14599 and then not Is_Array_Type
(Typ
)
14602 ("Name parameter of pragma% must identify record or "
14603 & "array type", Name
);
14606 -- An explicit Component_Alignment pragma overrides an
14607 -- implicit pragma Pack, but not an explicit one.
14609 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
14610 Set_Is_Packed
(Base_Type
(Typ
), False);
14611 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
14614 end Component_AlignmentP
;
14616 --------------------------------
14617 -- Constant_After_Elaboration --
14618 --------------------------------
14620 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14622 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
14624 Obj_Decl
: Node_Id
;
14625 Obj_Id
: Entity_Id
;
14629 Check_No_Identifiers
;
14630 Check_At_Most_N_Arguments
(1);
14632 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14634 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
14639 Obj_Id
:= Defining_Entity
(Obj_Decl
);
14641 -- The object declaration must be a library-level variable which
14642 -- is either explicitly initialized or obtains a value during the
14643 -- elaboration of a package body (SPARK RM 3.3.1).
14645 if Ekind
(Obj_Id
) = E_Variable
then
14646 if not Is_Library_Level_Entity
(Obj_Id
) then
14648 ("pragma % must apply to a library level variable");
14652 -- Otherwise the pragma applies to a constant, which is illegal
14655 Error_Pragma
("pragma % must apply to a variable declaration");
14659 -- A pragma that applies to a Ghost entity becomes Ghost for the
14660 -- purposes of legality checks and removal of ignored Ghost code.
14662 Mark_Ghost_Pragma
(N
, Obj_Id
);
14664 -- Chain the pragma on the contract for completeness
14666 Add_Contract_Item
(N
, Obj_Id
);
14668 -- Analyze the Boolean expression (if any)
14670 if Present
(Arg1
) then
14671 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14673 end Constant_After_Elaboration
;
14675 --------------------
14676 -- Contract_Cases --
14677 --------------------
14679 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14681 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14683 -- CASE_GUARD ::= boolean_EXPRESSION | others
14685 -- CONSEQUENCE ::= boolean_EXPRESSION
14687 -- Characteristics:
14689 -- * Analysis - The annotation undergoes initial checks to verify
14690 -- the legal placement and context. Secondary checks preanalyze the
14693 -- Analyze_Contract_Cases_In_Decl_Part
14695 -- * Expansion - The annotation is expanded during the expansion of
14696 -- the related subprogram [body] contract as performed in:
14698 -- Expand_Subprogram_Contract
14700 -- * Template - The annotation utilizes the generic template of the
14701 -- related subprogram [body] when it is:
14703 -- aspect on subprogram declaration
14704 -- aspect on stand-alone subprogram body
14705 -- pragma on stand-alone subprogram body
14707 -- The annotation must prepare its own template when it is:
14709 -- pragma on subprogram declaration
14711 -- * Globals - Capture of global references must occur after full
14714 -- * Instance - The annotation is instantiated automatically when
14715 -- the related generic subprogram [body] is instantiated except for
14716 -- the "pragma on subprogram declaration" case. In that scenario
14717 -- the annotation must instantiate itself.
14719 when Pragma_Contract_Cases
=> Contract_Cases
: declare
14720 Spec_Id
: Entity_Id
;
14721 Subp_Decl
: Node_Id
;
14722 Subp_Spec
: Node_Id
;
14726 Check_No_Identifiers
;
14727 Check_Arg_Count
(1);
14729 -- Ensure the proper placement of the pragma. Contract_Cases must
14730 -- be associated with a subprogram declaration or a body that acts
14734 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14738 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14741 -- Generic subprogram
14743 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14746 -- Body acts as spec
14748 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14749 and then No
(Corresponding_Spec
(Subp_Decl
))
14753 -- Body stub acts as spec
14755 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14756 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14762 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14763 Subp_Spec
:= Specification
(Subp_Decl
);
14765 -- Pragma Contract_Cases is forbidden on null procedures, as
14766 -- this may lead to potential ambiguities in behavior when
14767 -- interface null procedures are involved.
14769 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14770 and then Null_Present
(Subp_Spec
)
14772 Error_Msg_N
(Fix_Error
14773 ("pragma % cannot apply to null procedure"), N
);
14782 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14784 -- A pragma that applies to a Ghost entity becomes Ghost for the
14785 -- purposes of legality checks and removal of ignored Ghost code.
14787 Mark_Ghost_Pragma
(N
, Spec_Id
);
14788 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14790 -- Chain the pragma on the contract for further processing by
14791 -- Analyze_Contract_Cases_In_Decl_Part.
14793 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14795 -- Fully analyze the pragma when it appears inside an entry
14796 -- or subprogram body because it cannot benefit from forward
14799 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14801 N_Subprogram_Body_Stub
)
14803 -- The legality checks of pragma Contract_Cases are affected by
14804 -- the SPARK mode in effect and the volatility of the context.
14805 -- Analyze all pragmas in a specific order.
14807 Analyze_If_Present
(Pragma_SPARK_Mode
);
14808 Analyze_If_Present
(Pragma_Volatile_Function
);
14809 Analyze_Contract_Cases_In_Decl_Part
(N
);
14811 end Contract_Cases
;
14817 -- pragma Controlled (first_subtype_LOCAL_NAME);
14819 when Pragma_Controlled
=> Controlled
: declare
14823 Check_No_Identifiers
;
14824 Check_Arg_Count
(1);
14825 Check_Arg_Is_Local_Name
(Arg1
);
14826 Arg
:= Get_Pragma_Arg
(Arg1
);
14828 if not Is_Entity_Name
(Arg
)
14829 or else not Is_Access_Type
(Entity
(Arg
))
14831 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14833 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14841 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14842 -- [Entity =>] LOCAL_NAME);
14844 when Pragma_Convention
=> Convention
: declare
14847 pragma Warnings
(Off
, C
);
14848 pragma Warnings
(Off
, E
);
14851 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14852 Check_Ada_83_Warning
;
14853 Check_Arg_Count
(2);
14854 Process_Convention
(C
, E
);
14856 -- A pragma that applies to a Ghost entity becomes Ghost for the
14857 -- purposes of legality checks and removal of ignored Ghost code.
14859 Mark_Ghost_Pragma
(N
, E
);
14862 ---------------------------
14863 -- Convention_Identifier --
14864 ---------------------------
14866 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14867 -- [Convention =>] convention_IDENTIFIER);
14869 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14875 Check_Arg_Order
((Name_Name
, Name_Convention
));
14876 Check_Arg_Count
(2);
14877 Check_Optional_Identifier
(Arg1
, Name_Name
);
14878 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14879 Check_Arg_Is_Identifier
(Arg1
);
14880 Check_Arg_Is_Identifier
(Arg2
);
14881 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14882 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14884 if Is_Convention_Name
(Cname
) then
14885 Record_Convention_Identifier
14886 (Idnam
, Get_Convention_Id
(Cname
));
14889 ("second arg for % pragma must be convention", Arg2
);
14891 end Convention_Identifier
;
14897 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14899 when Pragma_CPP_Class
=>
14902 if Warn_On_Obsolescent_Feature
then
14904 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14905 & "effect; replace it by pragma import?j?", N
);
14908 Check_Arg_Count
(1);
14912 Chars
=> Name_Import
,
14913 Pragma_Argument_Associations
=> New_List
(
14914 Make_Pragma_Argument_Association
(Loc
,
14915 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14916 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14919 ---------------------
14920 -- CPP_Constructor --
14921 ---------------------
14923 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14924 -- [, [External_Name =>] static_string_EXPRESSION ]
14925 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14927 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14930 Def_Id
: Entity_Id
;
14931 Tag_Typ
: Entity_Id
;
14935 Check_At_Least_N_Arguments
(1);
14936 Check_At_Most_N_Arguments
(3);
14937 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14938 Check_Arg_Is_Local_Name
(Arg1
);
14940 Id
:= Get_Pragma_Arg
(Arg1
);
14941 Find_Program_Unit_Name
(Id
);
14943 -- If we did not find the name, we are done
14945 if Etype
(Id
) = Any_Type
then
14949 Def_Id
:= Entity
(Id
);
14951 -- Check if already defined as constructor
14953 if Is_Constructor
(Def_Id
) then
14955 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14959 if Ekind
(Def_Id
) = E_Function
14960 and then (Is_CPP_Class
(Etype
(Def_Id
))
14961 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14963 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14965 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14967 ("'C'P'P constructor must be defined in the scope of "
14968 & "its returned type", Arg1
);
14971 if Arg_Count
>= 2 then
14972 Set_Imported
(Def_Id
);
14973 Set_Is_Public
(Def_Id
);
14974 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14977 Set_Has_Completion
(Def_Id
);
14978 Set_Is_Constructor
(Def_Id
);
14979 Set_Convention
(Def_Id
, Convention_CPP
);
14981 -- Imported C++ constructors are not dispatching primitives
14982 -- because in C++ they don't have a dispatch table slot.
14983 -- However, in Ada the constructor has the profile of a
14984 -- function that returns a tagged type and therefore it has
14985 -- been treated as a primitive operation during semantic
14986 -- analysis. We now remove it from the list of primitive
14987 -- operations of the type.
14989 if Is_Tagged_Type
(Etype
(Def_Id
))
14990 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14991 and then Is_Dispatching_Operation
(Def_Id
)
14993 Tag_Typ
:= Etype
(Def_Id
);
14995 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14996 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
15000 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
15001 Set_Is_Dispatching_Operation
(Def_Id
, False);
15004 -- For backward compatibility, if the constructor returns a
15005 -- class wide type, and we internally change the return type to
15006 -- the corresponding root type.
15008 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
15009 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
15013 ("pragma% requires function returning a 'C'P'P_Class type",
15016 end CPP_Constructor
;
15022 when Pragma_CPP_Virtual
=>
15025 if Warn_On_Obsolescent_Feature
then
15027 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15035 when Pragma_CPP_Vtable
=>
15038 if Warn_On_Obsolescent_Feature
then
15040 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15048 -- pragma CPU (EXPRESSION);
15050 when Pragma_CPU
=> CPU
: declare
15051 P
: constant Node_Id
:= Parent
(N
);
15057 Check_No_Identifiers
;
15058 Check_Arg_Count
(1);
15062 if Nkind
(P
) = N_Subprogram_Body
then
15063 Check_In_Main_Program
;
15065 Arg
:= Get_Pragma_Arg
(Arg1
);
15066 Analyze_And_Resolve
(Arg
, Any_Integer
);
15068 Ent
:= Defining_Unit_Name
(Specification
(P
));
15070 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15071 Ent
:= Defining_Identifier
(Ent
);
15076 if not Is_OK_Static_Expression
(Arg
) then
15077 Flag_Non_Static_Expr
15078 ("main subprogram affinity is not static!", Arg
);
15081 -- If constraint error, then we already signalled an error
15083 elsif Raises_Constraint_Error
(Arg
) then
15086 -- Otherwise check in range
15090 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15091 -- This is the entity System.Multiprocessors.CPU_Range;
15093 Val
: constant Uint
:= Expr_Value
(Arg
);
15096 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15098 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15101 ("main subprogram CPU is out of range", Arg1
);
15107 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15111 elsif Nkind
(P
) = N_Task_Definition
then
15112 Arg
:= Get_Pragma_Arg
(Arg1
);
15113 Ent
:= Defining_Identifier
(Parent
(P
));
15115 -- The expression must be analyzed in the special manner
15116 -- described in "Handling of Default and Per-Object
15117 -- Expressions" in sem.ads.
15119 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15121 -- Anything else is incorrect
15127 -- Check duplicate pragma before we chain the pragma in the Rep
15128 -- Item chain of Ent.
15130 Check_Duplicate_Pragma
(Ent
);
15131 Record_Rep_Item
(Ent
, N
);
15134 --------------------
15135 -- Deadline_Floor --
15136 --------------------
15138 -- pragma Deadline_Floor (time_span_EXPRESSION);
15140 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15141 P
: constant Node_Id
:= Parent
(N
);
15147 Check_No_Identifiers
;
15148 Check_Arg_Count
(1);
15150 Arg
:= Get_Pragma_Arg
(Arg1
);
15152 -- The expression must be analyzed in the special manner described
15153 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15155 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15157 -- Only protected types allowed
15159 if Nkind
(P
) /= N_Protected_Definition
then
15163 Ent
:= Defining_Identifier
(Parent
(P
));
15165 -- Check duplicate pragma before we chain the pragma in the Rep
15166 -- Item chain of Ent.
15168 Check_Duplicate_Pragma
(Ent
);
15169 Record_Rep_Item
(Ent
, N
);
15171 end Deadline_Floor
;
15177 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15179 when Pragma_Debug
=> Debug
: declare
15186 -- The condition for executing the call is that the expander
15187 -- is active and that we are not ignoring this debug pragma.
15192 (Expander_Active
and then not Is_Ignored
(N
)),
15195 if not Is_Ignored
(N
) then
15196 Set_SCO_Pragma_Enabled
(Loc
);
15199 if Arg_Count
= 2 then
15201 Make_And_Then
(Loc
,
15202 Left_Opnd
=> Relocate_Node
(Cond
),
15203 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15204 Call
:= Get_Pragma_Arg
(Arg2
);
15206 Call
:= Get_Pragma_Arg
(Arg1
);
15209 if Nkind_In
(Call
, N_Expanded_Name
,
15212 N_Indexed_Component
,
15213 N_Selected_Component
)
15215 -- If this pragma Debug comes from source, its argument was
15216 -- parsed as a name form (which is syntactically identical).
15217 -- In a generic context a parameterless call will be left as
15218 -- an expanded name (if global) or selected_component if local.
15219 -- Change it to a procedure call statement now.
15221 Change_Name_To_Procedure_Call_Statement
(Call
);
15223 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15225 -- Already in the form of a procedure call statement: nothing
15226 -- to do (could happen in case of an internally generated
15232 -- All other cases: diagnose error
15235 ("argument of pragma ""Debug"" is not procedure call",
15240 -- Rewrite into a conditional with an appropriate condition. We
15241 -- wrap the procedure call in a block so that overhead from e.g.
15242 -- use of the secondary stack does not generate execution overhead
15243 -- for suppressed conditions.
15245 -- Normally the analysis that follows will freeze the subprogram
15246 -- being called. However, if the call is to a null procedure,
15247 -- we want to freeze it before creating the block, because the
15248 -- analysis that follows may be done with expansion disabled, in
15249 -- which case the body will not be generated, leading to spurious
15252 if Nkind
(Call
) = N_Procedure_Call_Statement
15253 and then Is_Entity_Name
(Name
(Call
))
15255 Analyze
(Name
(Call
));
15256 Freeze_Before
(N
, Entity
(Name
(Call
)));
15260 Make_Implicit_If_Statement
(N
,
15262 Then_Statements
=> New_List
(
15263 Make_Block_Statement
(Loc
,
15264 Handled_Statement_Sequence
=>
15265 Make_Handled_Sequence_Of_Statements
(Loc
,
15266 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15269 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15270 -- after analysis of the normally rewritten node, to capture all
15271 -- references to entities, which avoids issuing wrong warnings
15272 -- about unused entities.
15274 if GNATprove_Mode
then
15275 Rewrite
(N
, Make_Null_Statement
(Loc
));
15283 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15285 when Pragma_Debug_Policy
=>
15287 Check_Arg_Count
(1);
15288 Check_No_Identifiers
;
15289 Check_Arg_Is_Identifier
(Arg1
);
15291 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15292 -- rewrite it that way, and let the rest of the checking come
15293 -- from analyzing the rewritten pragma.
15297 Chars
=> Name_Check_Policy
,
15298 Pragma_Argument_Associations
=> New_List
(
15299 Make_Pragma_Argument_Association
(Loc
,
15300 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15302 Make_Pragma_Argument_Association
(Loc
,
15303 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15306 -------------------------------
15307 -- Default_Initial_Condition --
15308 -------------------------------
15310 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15312 when Pragma_Default_Initial_Condition
=> DIC
: declare
15319 Check_No_Identifiers
;
15320 Check_At_Most_N_Arguments
(1);
15324 while Present
(Stmt
) loop
15326 -- Skip prior pragmas, but check for duplicates
15328 if Nkind
(Stmt
) = N_Pragma
then
15329 if Pragma_Name
(Stmt
) = Pname
then
15336 -- Skip internally generated code. Note that derived type
15337 -- declarations of untagged types with discriminants are
15338 -- rewritten as private type declarations.
15340 elsif not Comes_From_Source
(Stmt
)
15341 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15345 -- The associated private type [extension] has been found, stop
15348 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
15349 N_Private_Type_Declaration
)
15351 Typ
:= Defining_Entity
(Stmt
);
15354 -- The pragma does not apply to a legal construct, issue an
15355 -- error and stop the analysis.
15362 Stmt
:= Prev
(Stmt
);
15365 -- The pragma does not apply to a legal construct, issue an error
15366 -- and stop the analysis.
15373 -- A pragma that applies to a Ghost entity becomes Ghost for the
15374 -- purposes of legality checks and removal of ignored Ghost code.
15376 Mark_Ghost_Pragma
(N
, Typ
);
15378 -- The pragma signals that the type defines its own DIC assertion
15381 Set_Has_Own_DIC
(Typ
);
15383 -- Chain the pragma on the rep item chain for further processing
15385 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15387 -- Create the declaration of the procedure which verifies the
15388 -- assertion expression of pragma DIC at runtime.
15390 Build_DIC_Procedure_Declaration
(Typ
);
15393 ----------------------------------
15394 -- Default_Scalar_Storage_Order --
15395 ----------------------------------
15397 -- pragma Default_Scalar_Storage_Order
15398 -- (High_Order_First | Low_Order_First);
15400 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
15401 Default
: Character;
15405 Check_Arg_Count
(1);
15407 -- Default_Scalar_Storage_Order can appear as a configuration
15408 -- pragma, or in a declarative part of a package spec.
15410 if not Is_Configuration_Pragma
then
15411 Check_Is_In_Decl_Part_Or_Package_Spec
;
15414 Check_No_Identifiers
;
15415 Check_Arg_Is_One_Of
15416 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
15417 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15418 Default
:= Fold_Upper
(Name_Buffer
(1));
15420 if not Support_Nondefault_SSO_On_Target
15421 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
15423 if Warn_On_Unrecognized_Pragma
then
15425 ("non-default Scalar_Storage_Order not supported "
15426 & "on target?g?", N
);
15428 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
15431 -- Here set the specified default
15434 Opt
.Default_SSO
:= Default
;
15438 --------------------------
15439 -- Default_Storage_Pool --
15440 --------------------------
15442 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15444 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
15449 Check_Arg_Count
(1);
15451 -- Default_Storage_Pool can appear as a configuration pragma, or
15452 -- in a declarative part of a package spec.
15454 if not Is_Configuration_Pragma
then
15455 Check_Is_In_Decl_Part_Or_Package_Spec
;
15458 if From_Aspect_Specification
(N
) then
15460 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
15462 if not In_Open_Scopes
(E
) then
15464 ("aspect must apply to package or subprogram", N
);
15469 if Present
(Arg1
) then
15470 Pool
:= Get_Pragma_Arg
(Arg1
);
15472 -- Case of Default_Storage_Pool (null);
15474 if Nkind
(Pool
) = N_Null
then
15477 -- This is an odd case, this is not really an expression,
15478 -- so we don't have a type for it. So just set the type to
15481 Set_Etype
(Pool
, Empty
);
15483 -- Case of Default_Storage_Pool (storage_pool_NAME);
15486 -- If it's a configuration pragma, then the only allowed
15487 -- argument is "null".
15489 if Is_Configuration_Pragma
then
15490 Error_Pragma_Arg
("NULL expected", Arg1
);
15493 -- The expected type for a non-"null" argument is
15494 -- Root_Storage_Pool'Class, and the pool must be a variable.
15496 Analyze_And_Resolve
15497 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
15499 if Is_Variable
(Pool
) then
15501 -- A pragma that applies to a Ghost entity becomes Ghost
15502 -- for the purposes of legality checks and removal of
15503 -- ignored Ghost code.
15505 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
15509 ("default storage pool must be a variable", Arg1
);
15513 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15514 -- access type will use this information to set the appropriate
15515 -- attributes of the access type. If the pragma appears in a
15516 -- generic unit it is ignored, given that it may refer to a
15519 if not Inside_A_Generic
then
15520 Default_Pool
:= Pool
;
15523 end Default_Storage_Pool
;
15529 -- pragma Depends (DEPENDENCY_RELATION);
15531 -- DEPENDENCY_RELATION ::=
15533 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15535 -- DEPENDENCY_CLAUSE ::=
15536 -- OUTPUT_LIST =>[+] INPUT_LIST
15537 -- | NULL_DEPENDENCY_CLAUSE
15539 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15541 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15543 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15545 -- OUTPUT ::= NAME | FUNCTION_RESULT
15548 -- where FUNCTION_RESULT is a function Result attribute_reference
15550 -- Characteristics:
15552 -- * Analysis - The annotation undergoes initial checks to verify
15553 -- the legal placement and context. Secondary checks fully analyze
15554 -- the dependency clauses in:
15556 -- Analyze_Depends_In_Decl_Part
15558 -- * Expansion - None.
15560 -- * Template - The annotation utilizes the generic template of the
15561 -- related subprogram [body] when it is:
15563 -- aspect on subprogram declaration
15564 -- aspect on stand-alone subprogram body
15565 -- pragma on stand-alone subprogram body
15567 -- The annotation must prepare its own template when it is:
15569 -- pragma on subprogram declaration
15571 -- * Globals - Capture of global references must occur after full
15574 -- * Instance - The annotation is instantiated automatically when
15575 -- the related generic subprogram [body] is instantiated except for
15576 -- the "pragma on subprogram declaration" case. In that scenario
15577 -- the annotation must instantiate itself.
15579 when Pragma_Depends
=> Depends
: declare
15581 Spec_Id
: Entity_Id
;
15582 Subp_Decl
: Node_Id
;
15585 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15589 -- Chain the pragma on the contract for further processing by
15590 -- Analyze_Depends_In_Decl_Part.
15592 Add_Contract_Item
(N
, Spec_Id
);
15594 -- Fully analyze the pragma when it appears inside an entry
15595 -- or subprogram body because it cannot benefit from forward
15598 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15600 N_Subprogram_Body_Stub
)
15602 -- The legality checks of pragmas Depends and Global are
15603 -- affected by the SPARK mode in effect and the volatility
15604 -- of the context. In addition these two pragmas are subject
15605 -- to an inherent order:
15610 -- Analyze all these pragmas in the order outlined above
15612 Analyze_If_Present
(Pragma_SPARK_Mode
);
15613 Analyze_If_Present
(Pragma_Volatile_Function
);
15614 Analyze_If_Present
(Pragma_Global
);
15615 Analyze_Depends_In_Decl_Part
(N
);
15620 ---------------------
15621 -- Detect_Blocking --
15622 ---------------------
15624 -- pragma Detect_Blocking;
15626 when Pragma_Detect_Blocking
=>
15628 Check_Arg_Count
(0);
15629 Check_Valid_Configuration_Pragma
;
15630 Detect_Blocking
:= True;
15632 ------------------------------------
15633 -- Disable_Atomic_Synchronization --
15634 ------------------------------------
15636 -- pragma Disable_Atomic_Synchronization [(Entity)];
15638 when Pragma_Disable_Atomic_Synchronization
=>
15640 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
15642 -------------------
15643 -- Discard_Names --
15644 -------------------
15646 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15648 when Pragma_Discard_Names
=> Discard_Names
: declare
15653 Check_Ada_83_Warning
;
15655 -- Deal with configuration pragma case
15657 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
15658 Global_Discard_Names
:= True;
15661 -- Otherwise, check correct appropriate context
15664 Check_Is_In_Decl_Part_Or_Package_Spec
;
15666 if Arg_Count
= 0 then
15668 -- If there is no parameter, then from now on this pragma
15669 -- applies to any enumeration, exception or tagged type
15670 -- defined in the current declarative part, and recursively
15671 -- to any nested scope.
15673 Set_Discard_Names
(Current_Scope
);
15677 Check_Arg_Count
(1);
15678 Check_Optional_Identifier
(Arg1
, Name_On
);
15679 Check_Arg_Is_Local_Name
(Arg1
);
15681 E_Id
:= Get_Pragma_Arg
(Arg1
);
15683 if Etype
(E_Id
) = Any_Type
then
15687 E
:= Entity
(E_Id
);
15689 -- A pragma that applies to a Ghost entity becomes Ghost for
15690 -- the purposes of legality checks and removal of ignored
15693 Mark_Ghost_Pragma
(N
, E
);
15695 if (Is_First_Subtype
(E
)
15697 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
15698 or else Ekind
(E
) = E_Exception
15700 Set_Discard_Names
(E
);
15701 Record_Rep_Item
(E
, N
);
15705 ("inappropriate entity for pragma%", Arg1
);
15711 ------------------------
15712 -- Dispatching_Domain --
15713 ------------------------
15715 -- pragma Dispatching_Domain (EXPRESSION);
15717 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
15718 P
: constant Node_Id
:= Parent
(N
);
15724 Check_No_Identifiers
;
15725 Check_Arg_Count
(1);
15727 -- This pragma is born obsolete, but not the aspect
15729 if not From_Aspect_Specification
(N
) then
15731 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15734 if Nkind
(P
) = N_Task_Definition
then
15735 Arg
:= Get_Pragma_Arg
(Arg1
);
15736 Ent
:= Defining_Identifier
(Parent
(P
));
15738 -- A pragma that applies to a Ghost entity becomes Ghost for
15739 -- the purposes of legality checks and removal of ignored Ghost
15742 Mark_Ghost_Pragma
(N
, Ent
);
15744 -- The expression must be analyzed in the special manner
15745 -- described in "Handling of Default and Per-Object
15746 -- Expressions" in sem.ads.
15748 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15750 -- Check duplicate pragma before we chain the pragma in the Rep
15751 -- Item chain of Ent.
15753 Check_Duplicate_Pragma
(Ent
);
15754 Record_Rep_Item
(Ent
, N
);
15756 -- Anything else is incorrect
15761 end Dispatching_Domain
;
15767 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15769 when Pragma_Elaborate
=> Elaborate
: declare
15774 -- Pragma must be in context items list of a compilation unit
15776 if not Is_In_Context_Clause
then
15780 -- Must be at least one argument
15782 if Arg_Count
= 0 then
15783 Error_Pragma
("pragma% requires at least one argument");
15786 -- In Ada 83 mode, there can be no items following it in the
15787 -- context list except other pragmas and implicit with clauses
15788 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15789 -- placement rule does not apply.
15791 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15793 while Present
(Citem
) loop
15794 if Nkind
(Citem
) = N_Pragma
15795 or else (Nkind
(Citem
) = N_With_Clause
15796 and then Implicit_With
(Citem
))
15801 ("(Ada 83) pragma% must be at end of context clause");
15808 -- Finally, the arguments must all be units mentioned in a with
15809 -- clause in the same context clause. Note we already checked (in
15810 -- Par.Prag) that the arguments are all identifiers or selected
15814 Outer
: while Present
(Arg
) loop
15815 Citem
:= First
(List_Containing
(N
));
15816 Inner
: while Citem
/= N
loop
15817 if Nkind
(Citem
) = N_With_Clause
15818 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15820 Set_Elaborate_Present
(Citem
, True);
15821 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15823 -- With the pragma present, elaboration calls on
15824 -- subprograms from the named unit need no further
15825 -- checks, as long as the pragma appears in the current
15826 -- compilation unit. If the pragma appears in some unit
15827 -- in the context, there might still be a need for an
15828 -- Elaborate_All_Desirable from the current compilation
15829 -- to the named unit, so we keep the check enabled. This
15830 -- does not apply in SPARK mode, where we allow pragma
15831 -- Elaborate, but we don't trust it to be right so we
15832 -- will still insist on the Elaborate_All.
15834 if Legacy_Elaboration_Checks
15835 and then In_Extended_Main_Source_Unit
(N
)
15836 and then SPARK_Mode
/= On
15838 Set_Suppress_Elaboration_Warnings
15839 (Entity
(Name
(Citem
)));
15850 ("argument of pragma% is not withed unit", Arg
);
15857 -------------------
15858 -- Elaborate_All --
15859 -------------------
15861 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15863 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15868 Check_Ada_83_Warning
;
15870 -- Pragma must be in context items list of a compilation unit
15872 if not Is_In_Context_Clause
then
15876 -- Must be at least one argument
15878 if Arg_Count
= 0 then
15879 Error_Pragma
("pragma% requires at least one argument");
15882 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15883 -- have to appear at the end of the context clause, but may
15884 -- appear mixed in with other items, even in Ada 83 mode.
15886 -- Final check: the arguments must all be units mentioned in
15887 -- a with clause in the same context clause. Note that we
15888 -- already checked (in Par.Prag) that all the arguments are
15889 -- either identifiers or selected components.
15892 Outr
: while Present
(Arg
) loop
15893 Citem
:= First
(List_Containing
(N
));
15894 Innr
: while Citem
/= N
loop
15895 if Nkind
(Citem
) = N_With_Clause
15896 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15898 Set_Elaborate_All_Present
(Citem
, True);
15899 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15901 -- Suppress warnings and elaboration checks on the named
15902 -- unit if the pragma is in the current compilation, as
15903 -- for pragma Elaborate.
15905 if Legacy_Elaboration_Checks
15906 and then In_Extended_Main_Source_Unit
(N
)
15908 Set_Suppress_Elaboration_Warnings
15909 (Entity
(Name
(Citem
)));
15919 Set_Error_Posted
(N
);
15921 ("argument of pragma% is not withed unit", Arg
);
15928 --------------------
15929 -- Elaborate_Body --
15930 --------------------
15932 -- pragma Elaborate_Body [( library_unit_NAME )];
15934 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15935 Cunit_Node
: Node_Id
;
15936 Cunit_Ent
: Entity_Id
;
15939 Check_Ada_83_Warning
;
15940 Check_Valid_Library_Unit_Pragma
;
15942 if Nkind
(N
) = N_Null_Statement
then
15946 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15947 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15949 -- A pragma that applies to a Ghost entity becomes Ghost for the
15950 -- purposes of legality checks and removal of ignored Ghost code.
15952 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15954 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15957 Error_Pragma
("pragma% must refer to a spec, not a body");
15959 Set_Body_Required
(Cunit_Node
);
15960 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15962 -- If we are in dynamic elaboration mode, then we suppress
15963 -- elaboration warnings for the unit, since it is definitely
15964 -- fine NOT to do dynamic checks at the first level (and such
15965 -- checks will be suppressed because no elaboration boolean
15966 -- is created for Elaborate_Body packages).
15968 -- But in the static model of elaboration, Elaborate_Body is
15969 -- definitely NOT good enough to ensure elaboration safety on
15970 -- its own, since the body may WITH other units that are not
15971 -- safe from an elaboration point of view, so a client must
15972 -- still do an Elaborate_All on such units.
15974 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15975 -- Elaborate_Body always suppressed elab warnings.
15977 if Legacy_Elaboration_Checks
15978 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
15980 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
15983 end Elaborate_Body
;
15985 ------------------------
15986 -- Elaboration_Checks --
15987 ------------------------
15989 -- pragma Elaboration_Checks (Static | Dynamic);
15991 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
15992 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
15993 -- Emit an error if the current context list already contains
15994 -- a previous Elaboration_Checks pragma. This routine raises
15995 -- Pragma_Exit if a duplicate is found.
15997 procedure Ignore_Elaboration_Checks_Pragma
;
15998 -- Warn that the effects of the pragma are ignored. This routine
15999 -- raises Pragma_Exit.
16001 -----------------------------------------------
16002 -- Check_Duplicate_Elaboration_Checks_Pragma --
16003 -----------------------------------------------
16005 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16010 while Present
(Item
) loop
16011 if Nkind
(Item
) = N_Pragma
16012 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16022 end Check_Duplicate_Elaboration_Checks_Pragma
;
16024 --------------------------------------
16025 -- Ignore_Elaboration_Checks_Pragma --
16026 --------------------------------------
16028 procedure Ignore_Elaboration_Checks_Pragma
is
16030 Error_Msg_Name_1
:= Pname
;
16031 Error_Msg_N
("??effects of pragma % are ignored", N
);
16033 ("\place pragma on initial declaration of library unit", N
);
16036 end Ignore_Elaboration_Checks_Pragma
;
16040 Context
: constant Node_Id
:= Parent
(N
);
16043 -- Start of processing for Elaboration_Checks
16047 Check_Arg_Count
(1);
16048 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16050 -- The pragma appears in a configuration file
16052 if No
(Context
) then
16053 Check_Valid_Configuration_Pragma
;
16054 Check_Duplicate_Elaboration_Checks_Pragma
;
16056 -- The pragma acts as a configuration pragma in a compilation unit
16058 -- pragma Elaboration_Checks (...);
16059 -- package Pack is ...;
16061 elsif Nkind
(Context
) = N_Compilation_Unit
16062 and then List_Containing
(N
) = Context_Items
(Context
)
16064 Check_Valid_Configuration_Pragma
;
16065 Check_Duplicate_Elaboration_Checks_Pragma
;
16067 Unt
:= Unit
(Context
);
16069 -- The pragma must appear on the initial declaration of a unit.
16070 -- If this is not the case, warn that the effects of the pragma
16073 if Nkind
(Unt
) = N_Package_Body
then
16074 Ignore_Elaboration_Checks_Pragma
;
16076 -- Check the Acts_As_Spec flag of the compilation units itself
16077 -- to determine whether the subprogram body completes since it
16078 -- has not been analyzed yet. This is safe because compilation
16079 -- units are not overloadable.
16081 elsif Nkind
(Unt
) = N_Subprogram_Body
16082 and then not Acts_As_Spec
(Context
)
16084 Ignore_Elaboration_Checks_Pragma
;
16086 elsif Nkind
(Unt
) = N_Subunit
then
16087 Ignore_Elaboration_Checks_Pragma
;
16090 -- Otherwise the pragma does not appear at the configuration level
16097 -- At this point the pragma is not a duplicate, and appears in the
16098 -- proper context. Set the elaboration model in effect.
16100 Dynamic_Elaboration_Checks
:=
16101 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16102 end Elaboration_Checks
;
16108 -- pragma Eliminate (
16109 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16110 -- [Entity =>] IDENTIFIER |
16111 -- SELECTED_COMPONENT |
16113 -- [, Source_Location => SOURCE_TRACE]);
16115 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16116 -- SOURCE_TRACE ::= STRING_LITERAL
16118 when Pragma_Eliminate
=> Eliminate
: declare
16119 Args
: Args_List
(1 .. 5);
16120 Names
: constant Name_List
(1 .. 5) := (
16123 Name_Parameter_Types
,
16125 Name_Source_Location
);
16127 -- Note : Parameter_Types and Result_Type are leftovers from
16128 -- prior implementations of the pragma. They are not generated
16129 -- by the gnatelim tool, and play no role in selecting which
16130 -- of a set of overloaded names is chosen for elimination.
16132 Unit_Name
: Node_Id
renames Args
(1);
16133 Entity
: Node_Id
renames Args
(2);
16134 Parameter_Types
: Node_Id
renames Args
(3);
16135 Result_Type
: Node_Id
renames Args
(4);
16136 Source_Location
: Node_Id
renames Args
(5);
16140 Check_Valid_Configuration_Pragma
;
16141 Gather_Associations
(Names
, Args
);
16143 if No
(Unit_Name
) then
16144 Error_Pragma
("missing Unit_Name argument for pragma%");
16148 and then (Present
(Parameter_Types
)
16150 Present
(Result_Type
)
16152 Present
(Source_Location
))
16154 Error_Pragma
("missing Entity argument for pragma%");
16157 if (Present
(Parameter_Types
)
16159 Present
(Result_Type
))
16161 Present
(Source_Location
)
16164 ("parameter profile and source location cannot be used "
16165 & "together in pragma%");
16168 Process_Eliminate_Pragma
16177 -----------------------------------
16178 -- Enable_Atomic_Synchronization --
16179 -----------------------------------
16181 -- pragma Enable_Atomic_Synchronization [(Entity)];
16183 when Pragma_Enable_Atomic_Synchronization
=>
16185 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16192 -- [ Convention =>] convention_IDENTIFIER,
16193 -- [ Entity =>] LOCAL_NAME
16194 -- [, [External_Name =>] static_string_EXPRESSION ]
16195 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16197 when Pragma_Export
=> Export
: declare
16199 Def_Id
: Entity_Id
;
16201 pragma Warnings
(Off
, C
);
16204 Check_Ada_83_Warning
;
16208 Name_External_Name
,
16211 Check_At_Least_N_Arguments
(2);
16212 Check_At_Most_N_Arguments
(4);
16214 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16215 -- pragma Export (Entity, "external name");
16217 if Relaxed_RM_Semantics
16218 and then Arg_Count
= 2
16219 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
16222 Def_Id
:= Get_Pragma_Arg
(Arg1
);
16225 if not Is_Entity_Name
(Def_Id
) then
16226 Error_Pragma_Arg
("entity name required", Arg1
);
16229 Def_Id
:= Entity
(Def_Id
);
16230 Set_Exported
(Def_Id
, Arg1
);
16233 Process_Convention
(C
, Def_Id
);
16235 -- A pragma that applies to a Ghost entity becomes Ghost for
16236 -- the purposes of legality checks and removal of ignored Ghost
16239 Mark_Ghost_Pragma
(N
, Def_Id
);
16241 if Ekind
(Def_Id
) /= E_Constant
then
16242 Note_Possible_Modification
16243 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16246 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
16247 Set_Exported
(Def_Id
, Arg2
);
16250 -- If the entity is a deferred constant, propagate the information
16251 -- to the full view, because gigi elaborates the full view only.
16253 if Ekind
(Def_Id
) = E_Constant
16254 and then Present
(Full_View
(Def_Id
))
16257 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
16259 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
16260 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
16261 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
16266 ---------------------
16267 -- Export_Function --
16268 ---------------------
16270 -- pragma Export_Function (
16271 -- [Internal =>] LOCAL_NAME
16272 -- [, [External =>] EXTERNAL_SYMBOL]
16273 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16274 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16275 -- [, [Mechanism =>] MECHANISM]
16276 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16278 -- EXTERNAL_SYMBOL ::=
16280 -- | static_string_EXPRESSION
16282 -- PARAMETER_TYPES ::=
16284 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16286 -- TYPE_DESIGNATOR ::=
16288 -- | subtype_Name ' Access
16292 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16294 -- MECHANISM_ASSOCIATION ::=
16295 -- [formal_parameter_NAME =>] MECHANISM_NAME
16297 -- MECHANISM_NAME ::=
16301 when Pragma_Export_Function
=> Export_Function
: declare
16302 Args
: Args_List
(1 .. 6);
16303 Names
: constant Name_List
(1 .. 6) := (
16306 Name_Parameter_Types
,
16309 Name_Result_Mechanism
);
16311 Internal
: Node_Id
renames Args
(1);
16312 External
: Node_Id
renames Args
(2);
16313 Parameter_Types
: Node_Id
renames Args
(3);
16314 Result_Type
: Node_Id
renames Args
(4);
16315 Mechanism
: Node_Id
renames Args
(5);
16316 Result_Mechanism
: Node_Id
renames Args
(6);
16320 Gather_Associations
(Names
, Args
);
16321 Process_Extended_Import_Export_Subprogram_Pragma
(
16322 Arg_Internal
=> Internal
,
16323 Arg_External
=> External
,
16324 Arg_Parameter_Types
=> Parameter_Types
,
16325 Arg_Result_Type
=> Result_Type
,
16326 Arg_Mechanism
=> Mechanism
,
16327 Arg_Result_Mechanism
=> Result_Mechanism
);
16328 end Export_Function
;
16330 -------------------
16331 -- Export_Object --
16332 -------------------
16334 -- pragma Export_Object (
16335 -- [Internal =>] LOCAL_NAME
16336 -- [, [External =>] EXTERNAL_SYMBOL]
16337 -- [, [Size =>] EXTERNAL_SYMBOL]);
16339 -- EXTERNAL_SYMBOL ::=
16341 -- | static_string_EXPRESSION
16343 -- PARAMETER_TYPES ::=
16345 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16347 -- TYPE_DESIGNATOR ::=
16349 -- | subtype_Name ' Access
16353 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16355 -- MECHANISM_ASSOCIATION ::=
16356 -- [formal_parameter_NAME =>] MECHANISM_NAME
16358 -- MECHANISM_NAME ::=
16362 when Pragma_Export_Object
=> Export_Object
: declare
16363 Args
: Args_List
(1 .. 3);
16364 Names
: constant Name_List
(1 .. 3) := (
16369 Internal
: Node_Id
renames Args
(1);
16370 External
: Node_Id
renames Args
(2);
16371 Size
: Node_Id
renames Args
(3);
16375 Gather_Associations
(Names
, Args
);
16376 Process_Extended_Import_Export_Object_Pragma
(
16377 Arg_Internal
=> Internal
,
16378 Arg_External
=> External
,
16382 ----------------------
16383 -- Export_Procedure --
16384 ----------------------
16386 -- pragma Export_Procedure (
16387 -- [Internal =>] LOCAL_NAME
16388 -- [, [External =>] EXTERNAL_SYMBOL]
16389 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16390 -- [, [Mechanism =>] MECHANISM]);
16392 -- EXTERNAL_SYMBOL ::=
16394 -- | static_string_EXPRESSION
16396 -- PARAMETER_TYPES ::=
16398 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16400 -- TYPE_DESIGNATOR ::=
16402 -- | subtype_Name ' Access
16406 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16408 -- MECHANISM_ASSOCIATION ::=
16409 -- [formal_parameter_NAME =>] MECHANISM_NAME
16411 -- MECHANISM_NAME ::=
16415 when Pragma_Export_Procedure
=> Export_Procedure
: declare
16416 Args
: Args_List
(1 .. 4);
16417 Names
: constant Name_List
(1 .. 4) := (
16420 Name_Parameter_Types
,
16423 Internal
: Node_Id
renames Args
(1);
16424 External
: Node_Id
renames Args
(2);
16425 Parameter_Types
: Node_Id
renames Args
(3);
16426 Mechanism
: Node_Id
renames Args
(4);
16430 Gather_Associations
(Names
, Args
);
16431 Process_Extended_Import_Export_Subprogram_Pragma
(
16432 Arg_Internal
=> Internal
,
16433 Arg_External
=> External
,
16434 Arg_Parameter_Types
=> Parameter_Types
,
16435 Arg_Mechanism
=> Mechanism
);
16436 end Export_Procedure
;
16442 -- pragma Export_Value (
16443 -- [Value =>] static_integer_EXPRESSION,
16444 -- [Link_Name =>] static_string_EXPRESSION);
16446 when Pragma_Export_Value
=>
16448 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
16449 Check_Arg_Count
(2);
16451 Check_Optional_Identifier
(Arg1
, Name_Value
);
16452 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16454 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
16455 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16457 -----------------------------
16458 -- Export_Valued_Procedure --
16459 -----------------------------
16461 -- pragma Export_Valued_Procedure (
16462 -- [Internal =>] LOCAL_NAME
16463 -- [, [External =>] EXTERNAL_SYMBOL,]
16464 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16465 -- [, [Mechanism =>] MECHANISM]);
16467 -- EXTERNAL_SYMBOL ::=
16469 -- | static_string_EXPRESSION
16471 -- PARAMETER_TYPES ::=
16473 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16475 -- TYPE_DESIGNATOR ::=
16477 -- | subtype_Name ' Access
16481 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16483 -- MECHANISM_ASSOCIATION ::=
16484 -- [formal_parameter_NAME =>] MECHANISM_NAME
16486 -- MECHANISM_NAME ::=
16490 when Pragma_Export_Valued_Procedure
=>
16491 Export_Valued_Procedure
: declare
16492 Args
: Args_List
(1 .. 4);
16493 Names
: constant Name_List
(1 .. 4) := (
16496 Name_Parameter_Types
,
16499 Internal
: Node_Id
renames Args
(1);
16500 External
: Node_Id
renames Args
(2);
16501 Parameter_Types
: Node_Id
renames Args
(3);
16502 Mechanism
: Node_Id
renames Args
(4);
16506 Gather_Associations
(Names
, Args
);
16507 Process_Extended_Import_Export_Subprogram_Pragma
(
16508 Arg_Internal
=> Internal
,
16509 Arg_External
=> External
,
16510 Arg_Parameter_Types
=> Parameter_Types
,
16511 Arg_Mechanism
=> Mechanism
);
16512 end Export_Valued_Procedure
;
16514 -------------------
16515 -- Extend_System --
16516 -------------------
16518 -- pragma Extend_System ([Name =>] Identifier);
16520 when Pragma_Extend_System
=>
16522 Check_Valid_Configuration_Pragma
;
16523 Check_Arg_Count
(1);
16524 Check_Optional_Identifier
(Arg1
, Name_Name
);
16525 Check_Arg_Is_Identifier
(Arg1
);
16527 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16530 and then Name_Buffer
(1 .. 4) = "aux_"
16532 if Present
(System_Extend_Pragma_Arg
) then
16533 if Chars
(Get_Pragma_Arg
(Arg1
)) =
16534 Chars
(Expression
(System_Extend_Pragma_Arg
))
16538 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
16539 Error_Pragma
("pragma% conflicts with that #");
16543 System_Extend_Pragma_Arg
:= Arg1
;
16545 if not GNAT_Mode
then
16546 System_Extend_Unit
:= Arg1
;
16550 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
16553 ------------------------
16554 -- Extensions_Allowed --
16555 ------------------------
16557 -- pragma Extensions_Allowed (ON | OFF);
16559 when Pragma_Extensions_Allowed
=>
16561 Check_Arg_Count
(1);
16562 Check_No_Identifiers
;
16563 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
16565 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
16566 Extensions_Allowed
:= True;
16567 Ada_Version
:= Ada_Version_Type
'Last;
16570 Extensions_Allowed
:= False;
16571 Ada_Version
:= Ada_Version_Explicit
;
16572 Ada_Version_Pragma
:= Empty
;
16575 ------------------------
16576 -- Extensions_Visible --
16577 ------------------------
16579 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16581 -- Characteristics:
16583 -- * Analysis - The annotation is fully analyzed immediately upon
16584 -- elaboration as its expression must be static.
16586 -- * Expansion - None.
16588 -- * Template - The annotation utilizes the generic template of the
16589 -- related subprogram [body] when it is:
16591 -- aspect on subprogram declaration
16592 -- aspect on stand-alone subprogram body
16593 -- pragma on stand-alone subprogram body
16595 -- The annotation must prepare its own template when it is:
16597 -- pragma on subprogram declaration
16599 -- * Globals - Capture of global references must occur after full
16602 -- * Instance - The annotation is instantiated automatically when
16603 -- the related generic subprogram [body] is instantiated except for
16604 -- the "pragma on subprogram declaration" case. In that scenario
16605 -- the annotation must instantiate itself.
16607 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
16608 Formal
: Entity_Id
;
16609 Has_OK_Formal
: Boolean := False;
16610 Spec_Id
: Entity_Id
;
16611 Subp_Decl
: Node_Id
;
16615 Check_No_Identifiers
;
16616 Check_At_Most_N_Arguments
(1);
16619 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16621 -- Abstract subprogram declaration
16623 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
16626 -- Generic subprogram declaration
16628 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16631 -- Body acts as spec
16633 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16634 and then No
(Corresponding_Spec
(Subp_Decl
))
16638 -- Body stub acts as spec
16640 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16641 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16645 -- Subprogram declaration
16647 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16650 -- Otherwise the pragma is associated with an illegal construct
16653 Error_Pragma
("pragma % must apply to a subprogram");
16657 -- Mark the pragma as Ghost if the related subprogram is also
16658 -- Ghost. This also ensures that any expansion performed further
16659 -- below will produce Ghost nodes.
16661 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16662 Mark_Ghost_Pragma
(N
, Spec_Id
);
16664 -- Chain the pragma on the contract for completeness
16666 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
16668 -- The legality checks of pragma Extension_Visible are affected
16669 -- by the SPARK mode in effect. Analyze all pragmas in specific
16672 Analyze_If_Present
(Pragma_SPARK_Mode
);
16674 -- Examine the formals of the related subprogram
16676 Formal
:= First_Formal
(Spec_Id
);
16677 while Present
(Formal
) loop
16679 -- At least one of the formals is of a specific tagged type,
16680 -- the pragma is legal.
16682 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
16683 Has_OK_Formal
:= True;
16686 -- A generic subprogram with at least one formal of a private
16687 -- type ensures the legality of the pragma because the actual
16688 -- may be specifically tagged. Note that this is verified by
16689 -- the check above at instantiation time.
16691 elsif Is_Private_Type
(Etype
(Formal
))
16692 and then Is_Generic_Type
(Etype
(Formal
))
16694 Has_OK_Formal
:= True;
16698 Next_Formal
(Formal
);
16701 if not Has_OK_Formal
then
16702 Error_Msg_Name_1
:= Pname
;
16703 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
16705 ("\subprogram & lacks parameter of specific tagged or "
16706 & "generic private type", N
, Spec_Id
);
16711 -- Analyze the Boolean expression (if any)
16713 if Present
(Arg1
) then
16714 Check_Static_Boolean_Expression
16715 (Expression
(Get_Argument
(N
, Spec_Id
)));
16717 end Extensions_Visible
;
16723 -- pragma External (
16724 -- [ Convention =>] convention_IDENTIFIER,
16725 -- [ Entity =>] LOCAL_NAME
16726 -- [, [External_Name =>] static_string_EXPRESSION ]
16727 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16729 when Pragma_External
=> External
: declare
16732 pragma Warnings
(Off
, C
);
16739 Name_External_Name
,
16741 Check_At_Least_N_Arguments
(2);
16742 Check_At_Most_N_Arguments
(4);
16743 Process_Convention
(C
, E
);
16745 -- A pragma that applies to a Ghost entity becomes Ghost for the
16746 -- purposes of legality checks and removal of ignored Ghost code.
16748 Mark_Ghost_Pragma
(N
, E
);
16750 Note_Possible_Modification
16751 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16752 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16753 Set_Exported
(E
, Arg2
);
16756 --------------------------
16757 -- External_Name_Casing --
16758 --------------------------
16760 -- pragma External_Name_Casing (
16761 -- UPPERCASE | LOWERCASE
16762 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16764 when Pragma_External_Name_Casing
=>
16766 Check_No_Identifiers
;
16768 if Arg_Count
= 2 then
16769 Check_Arg_Is_One_Of
16770 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16772 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16774 Opt
.External_Name_Exp_Casing
:= As_Is
;
16776 when Name_Uppercase
=>
16777 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16779 when Name_Lowercase
=>
16780 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16787 Check_Arg_Count
(1);
16790 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16792 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16793 when Name_Uppercase
=>
16794 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16796 when Name_Lowercase
=>
16797 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16807 -- pragma Fast_Math;
16809 when Pragma_Fast_Math
=>
16811 Check_No_Identifiers
;
16812 Check_Valid_Configuration_Pragma
;
16815 --------------------------
16816 -- Favor_Top_Level --
16817 --------------------------
16819 -- pragma Favor_Top_Level (type_NAME);
16821 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16826 Check_No_Identifiers
;
16827 Check_Arg_Count
(1);
16828 Check_Arg_Is_Local_Name
(Arg1
);
16829 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16831 -- A pragma that applies to a Ghost entity becomes Ghost for the
16832 -- purposes of legality checks and removal of ignored Ghost code.
16834 Mark_Ghost_Pragma
(N
, Typ
);
16836 -- If it's an access-to-subprogram type (in particular, not a
16837 -- subtype), set the flag on that type.
16839 if Is_Access_Subprogram_Type
(Typ
) then
16840 Set_Can_Use_Internal_Rep
(Typ
, False);
16842 -- Otherwise it's an error (name denotes the wrong sort of entity)
16846 ("access-to-subprogram type expected",
16847 Get_Pragma_Arg
(Arg1
));
16849 end Favor_Top_Level
;
16851 ---------------------------
16852 -- Finalize_Storage_Only --
16853 ---------------------------
16855 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16857 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16858 Assoc
: constant Node_Id
:= Arg1
;
16859 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16864 Check_No_Identifiers
;
16865 Check_Arg_Count
(1);
16866 Check_Arg_Is_Local_Name
(Arg1
);
16868 Find_Type
(Type_Id
);
16869 Typ
:= Entity
(Type_Id
);
16872 or else Rep_Item_Too_Early
(Typ
, N
)
16876 Typ
:= Underlying_Type
(Typ
);
16879 if not Is_Controlled
(Typ
) then
16880 Error_Pragma
("pragma% must specify controlled type");
16883 Check_First_Subtype
(Arg1
);
16885 if Finalize_Storage_Only
(Typ
) then
16886 Error_Pragma
("duplicate pragma%, only one allowed");
16888 elsif not Rep_Item_Too_Late
(Typ
, N
) then
16889 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
16891 end Finalize_Storage
;
16897 -- pragma Ghost [ (boolean_EXPRESSION) ];
16899 when Pragma_Ghost
=> Ghost
: declare
16903 Orig_Stmt
: Node_Id
;
16904 Prev_Id
: Entity_Id
;
16909 Check_No_Identifiers
;
16910 Check_At_Most_N_Arguments
(1);
16914 while Present
(Stmt
) loop
16916 -- Skip prior pragmas, but check for duplicates
16918 if Nkind
(Stmt
) = N_Pragma
then
16919 if Pragma_Name
(Stmt
) = Pname
then
16926 -- Task unit declared without a definition cannot be subject to
16927 -- pragma Ghost (SPARK RM 6.9(19)).
16929 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
16930 N_Task_Type_Declaration
)
16932 Error_Pragma
("pragma % cannot apply to a task type");
16935 -- Skip internally generated code
16937 elsif not Comes_From_Source
(Stmt
) then
16938 Orig_Stmt
:= Original_Node
(Stmt
);
16940 -- When pragma Ghost applies to an untagged derivation, the
16941 -- derivation is transformed into a [sub]type declaration.
16943 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
16944 N_Subtype_Declaration
)
16945 and then Comes_From_Source
(Orig_Stmt
)
16946 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
16947 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
16948 N_Derived_Type_Definition
16950 Id
:= Defining_Entity
(Stmt
);
16953 -- When pragma Ghost applies to an object declaration which
16954 -- is initialized by means of a function call that returns
16955 -- on the secondary stack, the object declaration becomes a
16958 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16959 and then Comes_From_Source
(Orig_Stmt
)
16960 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16962 Id
:= Defining_Entity
(Stmt
);
16965 -- When pragma Ghost applies to an expression function, the
16966 -- expression function is transformed into a subprogram.
16968 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16969 and then Comes_From_Source
(Orig_Stmt
)
16970 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16972 Id
:= Defining_Entity
(Stmt
);
16976 -- The pragma applies to a legal construct, stop the traversal
16978 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16979 N_Full_Type_Declaration
,
16980 N_Generic_Subprogram_Declaration
,
16981 N_Object_Declaration
,
16982 N_Private_Extension_Declaration
,
16983 N_Private_Type_Declaration
,
16984 N_Subprogram_Declaration
,
16985 N_Subtype_Declaration
)
16987 Id
:= Defining_Entity
(Stmt
);
16990 -- The pragma does not apply to a legal construct, issue an
16991 -- error and stop the analysis.
16995 ("pragma % must apply to an object, package, subprogram "
17000 Stmt
:= Prev
(Stmt
);
17003 Context
:= Parent
(N
);
17005 -- Handle compilation units
17007 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17008 Context
:= Unit
(Parent
(Context
));
17011 -- Protected and task types cannot be subject to pragma Ghost
17012 -- (SPARK RM 6.9(19)).
17014 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
17016 Error_Pragma
("pragma % cannot apply to a protected type");
17019 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
17020 Error_Pragma
("pragma % cannot apply to a task type");
17026 -- When pragma Ghost is associated with a [generic] package, it
17027 -- appears in the visible declarations.
17029 if Nkind
(Context
) = N_Package_Specification
17030 and then Present
(Visible_Declarations
(Context
))
17031 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17033 Id
:= Defining_Entity
(Context
);
17035 -- Pragma Ghost applies to a stand-alone subprogram body
17037 elsif Nkind
(Context
) = N_Subprogram_Body
17038 and then No
(Corresponding_Spec
(Context
))
17040 Id
:= Defining_Entity
(Context
);
17042 -- Pragma Ghost applies to a subprogram declaration that acts
17043 -- as a compilation unit.
17045 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17046 Id
:= Defining_Entity
(Context
);
17048 -- Pragma Ghost applies to a generic subprogram
17050 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17051 Id
:= Defining_Entity
(Specification
(Context
));
17057 ("pragma % must apply to an object, package, subprogram or "
17062 -- Handle completions of types and constants that are subject to
17065 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17066 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17068 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17069 Error_Msg_Name_1
:= Pname
;
17071 -- The full declaration of a deferred constant cannot be
17072 -- subject to pragma Ghost unless the deferred declaration
17073 -- is also Ghost (SPARK RM 6.9(9)).
17075 if Ekind
(Prev_Id
) = E_Constant
then
17076 Error_Msg_Name_1
:= Pname
;
17077 Error_Msg_NE
(Fix_Error
17078 ("pragma % must apply to declaration of deferred "
17079 & "constant &"), N
, Id
);
17082 -- Pragma Ghost may appear on the full view of an incomplete
17083 -- type because the incomplete declaration lacks aspects and
17084 -- cannot be subject to pragma Ghost.
17086 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17089 -- The full declaration of a type cannot be subject to
17090 -- pragma Ghost unless the partial view is also Ghost
17091 -- (SPARK RM 6.9(9)).
17094 Error_Msg_NE
(Fix_Error
17095 ("pragma % must apply to partial view of type &"),
17101 -- A synchronized object cannot be subject to pragma Ghost
17102 -- (SPARK RM 6.9(19)).
17104 elsif Ekind
(Id
) = E_Variable
then
17105 if Is_Protected_Type
(Etype
(Id
)) then
17106 Error_Pragma
("pragma % cannot apply to a protected object");
17109 elsif Is_Task_Type
(Etype
(Id
)) then
17110 Error_Pragma
("pragma % cannot apply to a task object");
17115 -- Analyze the Boolean expression (if any)
17117 if Present
(Arg1
) then
17118 Expr
:= Get_Pragma_Arg
(Arg1
);
17120 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17122 if Is_OK_Static_Expression
(Expr
) then
17124 -- "Ghostness" cannot be turned off once enabled within a
17125 -- region (SPARK RM 6.9(6)).
17127 if Is_False
(Expr_Value
(Expr
))
17128 and then Ghost_Mode
> None
17131 ("pragma % with value False cannot appear in enabled "
17136 -- Otherwie the expression is not static
17140 ("expression of pragma % must be static", Expr
);
17145 Set_Is_Ghost_Entity
(Id
);
17152 -- pragma Global (GLOBAL_SPECIFICATION);
17154 -- GLOBAL_SPECIFICATION ::=
17157 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17159 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17161 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17162 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17163 -- GLOBAL_ITEM ::= NAME
17165 -- Characteristics:
17167 -- * Analysis - The annotation undergoes initial checks to verify
17168 -- the legal placement and context. Secondary checks fully analyze
17169 -- the dependency clauses in:
17171 -- Analyze_Global_In_Decl_Part
17173 -- * Expansion - None.
17175 -- * Template - The annotation utilizes the generic template of the
17176 -- related subprogram [body] when it is:
17178 -- aspect on subprogram declaration
17179 -- aspect on stand-alone subprogram body
17180 -- pragma on stand-alone subprogram body
17182 -- The annotation must prepare its own template when it is:
17184 -- pragma on subprogram declaration
17186 -- * Globals - Capture of global references must occur after full
17189 -- * Instance - The annotation is instantiated automatically when
17190 -- the related generic subprogram [body] is instantiated except for
17191 -- the "pragma on subprogram declaration" case. In that scenario
17192 -- the annotation must instantiate itself.
17194 when Pragma_Global
=> Global
: declare
17196 Spec_Id
: Entity_Id
;
17197 Subp_Decl
: Node_Id
;
17200 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
17204 -- Chain the pragma on the contract for further processing by
17205 -- Analyze_Global_In_Decl_Part.
17207 Add_Contract_Item
(N
, Spec_Id
);
17209 -- Fully analyze the pragma when it appears inside an entry
17210 -- or subprogram body because it cannot benefit from forward
17213 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
17215 N_Subprogram_Body_Stub
)
17217 -- The legality checks of pragmas Depends and Global are
17218 -- affected by the SPARK mode in effect and the volatility
17219 -- of the context. In addition these two pragmas are subject
17220 -- to an inherent order:
17225 -- Analyze all these pragmas in the order outlined above
17227 Analyze_If_Present
(Pragma_SPARK_Mode
);
17228 Analyze_If_Present
(Pragma_Volatile_Function
);
17229 Analyze_Global_In_Decl_Part
(N
);
17230 Analyze_If_Present
(Pragma_Depends
);
17239 -- pragma Ident (static_string_EXPRESSION)
17241 -- Note: pragma Comment shares this processing. Pragma Ident is
17242 -- identical in effect to pragma Commment.
17244 when Pragma_Comment
17252 Check_Arg_Count
(1);
17253 Check_No_Identifiers
;
17254 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17257 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
17264 GP
:= Parent
(Parent
(N
));
17266 if Nkind_In
(GP
, N_Package_Declaration
,
17267 N_Generic_Package_Declaration
)
17272 -- If we have a compilation unit, then record the ident value,
17273 -- checking for improper duplication.
17275 if Nkind
(GP
) = N_Compilation_Unit
then
17276 CS
:= Ident_String
(Current_Sem_Unit
);
17278 if Present
(CS
) then
17280 -- If we have multiple instances, concatenate them, but
17281 -- not in ASIS, where we want the original tree.
17283 if not ASIS_Mode
then
17284 Start_String
(Strval
(CS
));
17285 Store_String_Char
(' ');
17286 Store_String_Chars
(Strval
(Str
));
17287 Set_Strval
(CS
, End_String
);
17291 Set_Ident_String
(Current_Sem_Unit
, Str
);
17294 -- For subunits, we just ignore the Ident, since in GNAT these
17295 -- are not separate object files, and hence not separate units
17296 -- in the unit table.
17298 elsif Nkind
(GP
) = N_Subunit
then
17304 -------------------
17305 -- Ignore_Pragma --
17306 -------------------
17308 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17310 -- Entirely handled in the parser, nothing to do here
17312 when Pragma_Ignore_Pragma
=>
17315 ----------------------------
17316 -- Implementation_Defined --
17317 ----------------------------
17319 -- pragma Implementation_Defined (LOCAL_NAME);
17321 -- Marks previously declared entity as implementation defined. For
17322 -- an overloaded entity, applies to the most recent homonym.
17324 -- pragma Implementation_Defined;
17326 -- The form with no arguments appears anywhere within a scope, most
17327 -- typically a package spec, and indicates that all entities that are
17328 -- defined within the package spec are Implementation_Defined.
17330 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
17335 Check_No_Identifiers
;
17337 -- Form with no arguments
17339 if Arg_Count
= 0 then
17340 Set_Is_Implementation_Defined
(Current_Scope
);
17342 -- Form with one argument
17345 Check_Arg_Count
(1);
17346 Check_Arg_Is_Local_Name
(Arg1
);
17347 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17348 Set_Is_Implementation_Defined
(Ent
);
17350 end Implementation_Defined
;
17356 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17358 -- IMPLEMENTATION_KIND ::=
17359 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17361 -- "By_Any" and "Optional" are treated as synonyms in order to
17362 -- support Ada 2012 aspect Synchronization.
17364 when Pragma_Implemented
=> Implemented
: declare
17365 Proc_Id
: Entity_Id
;
17370 Check_Arg_Count
(2);
17371 Check_No_Identifiers
;
17372 Check_Arg_Is_Identifier
(Arg1
);
17373 Check_Arg_Is_Local_Name
(Arg1
);
17374 Check_Arg_Is_One_Of
(Arg2
,
17377 Name_By_Protected_Procedure
,
17380 -- Extract the name of the local procedure
17382 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17384 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17385 -- primitive procedure of a synchronized tagged type.
17387 if Ekind
(Proc_Id
) = E_Procedure
17388 and then Is_Primitive
(Proc_Id
)
17389 and then Present
(First_Formal
(Proc_Id
))
17391 Typ
:= Etype
(First_Formal
(Proc_Id
));
17393 if Is_Tagged_Type
(Typ
)
17396 -- Check for a protected, a synchronized or a task interface
17398 ((Is_Interface
(Typ
)
17399 and then Is_Synchronized_Interface
(Typ
))
17401 -- Check for a protected type or a task type that implements
17405 (Is_Concurrent_Record_Type
(Typ
)
17406 and then Present
(Interfaces
(Typ
)))
17408 -- In analysis-only mode, examine original protected type
17411 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
17412 and then Present
(Interface_List
(Parent
(Typ
))))
17414 -- Check for a private record extension with keyword
17418 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
17419 E_Record_Subtype_With_Private
)
17420 and then Synchronized_Present
(Parent
(Typ
))))
17425 ("controlling formal must be of synchronized tagged type",
17430 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17431 -- By_Protected_Procedure to the primitive procedure of a task
17434 if Chars
(Arg2
) = Name_By_Protected_Procedure
17435 and then Is_Interface
(Typ
)
17436 and then Is_Task_Interface
(Typ
)
17439 ("implementation kind By_Protected_Procedure cannot be "
17440 & "applied to a task interface primitive", Arg2
);
17444 -- Procedures declared inside a protected type must be accepted
17446 elsif Ekind
(Proc_Id
) = E_Procedure
17447 and then Is_Protected_Type
(Scope
(Proc_Id
))
17451 -- The first argument is not a primitive procedure
17455 ("pragma % must be applied to a primitive procedure", Arg1
);
17459 Record_Rep_Item
(Proc_Id
, N
);
17462 ----------------------
17463 -- Implicit_Packing --
17464 ----------------------
17466 -- pragma Implicit_Packing;
17468 when Pragma_Implicit_Packing
=>
17470 Check_Arg_Count
(0);
17471 Implicit_Packing
:= True;
17478 -- [Convention =>] convention_IDENTIFIER,
17479 -- [Entity =>] LOCAL_NAME
17480 -- [, [External_Name =>] static_string_EXPRESSION ]
17481 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17483 when Pragma_Import
=>
17484 Check_Ada_83_Warning
;
17488 Name_External_Name
,
17491 Check_At_Least_N_Arguments
(2);
17492 Check_At_Most_N_Arguments
(4);
17493 Process_Import_Or_Interface
;
17495 ---------------------
17496 -- Import_Function --
17497 ---------------------
17499 -- pragma Import_Function (
17500 -- [Internal =>] LOCAL_NAME,
17501 -- [, [External =>] EXTERNAL_SYMBOL]
17502 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17503 -- [, [Result_Type =>] SUBTYPE_MARK]
17504 -- [, [Mechanism =>] MECHANISM]
17505 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17507 -- EXTERNAL_SYMBOL ::=
17509 -- | static_string_EXPRESSION
17511 -- PARAMETER_TYPES ::=
17513 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17515 -- TYPE_DESIGNATOR ::=
17517 -- | subtype_Name ' Access
17521 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17523 -- MECHANISM_ASSOCIATION ::=
17524 -- [formal_parameter_NAME =>] MECHANISM_NAME
17526 -- MECHANISM_NAME ::=
17530 when Pragma_Import_Function
=> Import_Function
: declare
17531 Args
: Args_List
(1 .. 6);
17532 Names
: constant Name_List
(1 .. 6) := (
17535 Name_Parameter_Types
,
17538 Name_Result_Mechanism
);
17540 Internal
: Node_Id
renames Args
(1);
17541 External
: Node_Id
renames Args
(2);
17542 Parameter_Types
: Node_Id
renames Args
(3);
17543 Result_Type
: Node_Id
renames Args
(4);
17544 Mechanism
: Node_Id
renames Args
(5);
17545 Result_Mechanism
: Node_Id
renames Args
(6);
17549 Gather_Associations
(Names
, Args
);
17550 Process_Extended_Import_Export_Subprogram_Pragma
(
17551 Arg_Internal
=> Internal
,
17552 Arg_External
=> External
,
17553 Arg_Parameter_Types
=> Parameter_Types
,
17554 Arg_Result_Type
=> Result_Type
,
17555 Arg_Mechanism
=> Mechanism
,
17556 Arg_Result_Mechanism
=> Result_Mechanism
);
17557 end Import_Function
;
17559 -------------------
17560 -- Import_Object --
17561 -------------------
17563 -- pragma Import_Object (
17564 -- [Internal =>] LOCAL_NAME
17565 -- [, [External =>] EXTERNAL_SYMBOL]
17566 -- [, [Size =>] EXTERNAL_SYMBOL]);
17568 -- EXTERNAL_SYMBOL ::=
17570 -- | static_string_EXPRESSION
17572 when Pragma_Import_Object
=> Import_Object
: declare
17573 Args
: Args_List
(1 .. 3);
17574 Names
: constant Name_List
(1 .. 3) := (
17579 Internal
: Node_Id
renames Args
(1);
17580 External
: Node_Id
renames Args
(2);
17581 Size
: Node_Id
renames Args
(3);
17585 Gather_Associations
(Names
, Args
);
17586 Process_Extended_Import_Export_Object_Pragma
(
17587 Arg_Internal
=> Internal
,
17588 Arg_External
=> External
,
17592 ----------------------
17593 -- Import_Procedure --
17594 ----------------------
17596 -- pragma Import_Procedure (
17597 -- [Internal =>] LOCAL_NAME
17598 -- [, [External =>] EXTERNAL_SYMBOL]
17599 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17600 -- [, [Mechanism =>] MECHANISM]);
17602 -- EXTERNAL_SYMBOL ::=
17604 -- | static_string_EXPRESSION
17606 -- PARAMETER_TYPES ::=
17608 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17610 -- TYPE_DESIGNATOR ::=
17612 -- | subtype_Name ' Access
17616 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17618 -- MECHANISM_ASSOCIATION ::=
17619 -- [formal_parameter_NAME =>] MECHANISM_NAME
17621 -- MECHANISM_NAME ::=
17625 when Pragma_Import_Procedure
=> Import_Procedure
: declare
17626 Args
: Args_List
(1 .. 4);
17627 Names
: constant Name_List
(1 .. 4) := (
17630 Name_Parameter_Types
,
17633 Internal
: Node_Id
renames Args
(1);
17634 External
: Node_Id
renames Args
(2);
17635 Parameter_Types
: Node_Id
renames Args
(3);
17636 Mechanism
: Node_Id
renames Args
(4);
17640 Gather_Associations
(Names
, Args
);
17641 Process_Extended_Import_Export_Subprogram_Pragma
(
17642 Arg_Internal
=> Internal
,
17643 Arg_External
=> External
,
17644 Arg_Parameter_Types
=> Parameter_Types
,
17645 Arg_Mechanism
=> Mechanism
);
17646 end Import_Procedure
;
17648 -----------------------------
17649 -- Import_Valued_Procedure --
17650 -----------------------------
17652 -- pragma Import_Valued_Procedure (
17653 -- [Internal =>] LOCAL_NAME
17654 -- [, [External =>] EXTERNAL_SYMBOL]
17655 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17656 -- [, [Mechanism =>] MECHANISM]);
17658 -- EXTERNAL_SYMBOL ::=
17660 -- | static_string_EXPRESSION
17662 -- PARAMETER_TYPES ::=
17664 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17666 -- TYPE_DESIGNATOR ::=
17668 -- | subtype_Name ' Access
17672 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17674 -- MECHANISM_ASSOCIATION ::=
17675 -- [formal_parameter_NAME =>] MECHANISM_NAME
17677 -- MECHANISM_NAME ::=
17681 when Pragma_Import_Valued_Procedure
=>
17682 Import_Valued_Procedure
: declare
17683 Args
: Args_List
(1 .. 4);
17684 Names
: constant Name_List
(1 .. 4) := (
17687 Name_Parameter_Types
,
17690 Internal
: Node_Id
renames Args
(1);
17691 External
: Node_Id
renames Args
(2);
17692 Parameter_Types
: Node_Id
renames Args
(3);
17693 Mechanism
: Node_Id
renames Args
(4);
17697 Gather_Associations
(Names
, Args
);
17698 Process_Extended_Import_Export_Subprogram_Pragma
(
17699 Arg_Internal
=> Internal
,
17700 Arg_External
=> External
,
17701 Arg_Parameter_Types
=> Parameter_Types
,
17702 Arg_Mechanism
=> Mechanism
);
17703 end Import_Valued_Procedure
;
17709 -- pragma Independent (LOCAL_NAME);
17711 when Pragma_Independent
=>
17712 Process_Atomic_Independent_Shared_Volatile
;
17714 ----------------------------
17715 -- Independent_Components --
17716 ----------------------------
17718 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17720 when Pragma_Independent_Components
=> Independent_Components
: declare
17728 Check_Ada_83_Warning
;
17730 Check_No_Identifiers
;
17731 Check_Arg_Count
(1);
17732 Check_Arg_Is_Local_Name
(Arg1
);
17733 E_Id
:= Get_Pragma_Arg
(Arg1
);
17735 if Etype
(E_Id
) = Any_Type
then
17739 E
:= Entity
(E_Id
);
17741 -- A record type with a self-referential component of anonymous
17742 -- access type is given an incomplete view in order to handle the
17745 -- type Rec is record
17746 -- Self : access Rec;
17752 -- type Ptr is access Rec;
17753 -- type Rec is record
17757 -- Since the incomplete view is now the initial view of the type,
17758 -- the argument of the pragma will reference the incomplete view,
17759 -- but this view is illegal according to the semantics of the
17762 -- Obtain the full view of an internally-generated incomplete type
17763 -- only. This way an attempt to associate the pragma with a source
17764 -- incomplete type is still caught.
17766 if Ekind
(E
) = E_Incomplete_Type
17767 and then not Comes_From_Source
(E
)
17768 and then Present
(Full_View
(E
))
17770 E
:= Full_View
(E
);
17773 -- A pragma that applies to a Ghost entity becomes Ghost for the
17774 -- purposes of legality checks and removal of ignored Ghost code.
17776 Mark_Ghost_Pragma
(N
, E
);
17778 -- Check duplicate before we chain ourselves
17780 Check_Duplicate_Pragma
(E
);
17782 -- Check appropriate entity
17784 if Rep_Item_Too_Early
(E
, N
)
17786 Rep_Item_Too_Late
(E
, N
)
17791 D
:= Declaration_Node
(E
);
17794 -- The flag is set on the base type, or on the object
17796 if K
= N_Full_Type_Declaration
17797 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17799 Set_Has_Independent_Components
(Base_Type
(E
));
17800 Record_Independence_Check
(N
, Base_Type
(E
));
17802 -- For record type, set all components independent
17804 if Is_Record_Type
(E
) then
17805 C
:= First_Component
(E
);
17806 while Present
(C
) loop
17807 Set_Is_Independent
(C
);
17808 Next_Component
(C
);
17812 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17813 and then Nkind
(D
) = N_Object_Declaration
17814 and then Nkind
(Object_Definition
(D
)) =
17815 N_Constrained_Array_Definition
17817 Set_Has_Independent_Components
(E
);
17818 Record_Independence_Check
(N
, E
);
17821 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17823 end Independent_Components
;
17825 -----------------------
17826 -- Initial_Condition --
17827 -----------------------
17829 -- pragma Initial_Condition (boolean_EXPRESSION);
17831 -- Characteristics:
17833 -- * Analysis - The annotation undergoes initial checks to verify
17834 -- the legal placement and context. Secondary checks preanalyze the
17837 -- Analyze_Initial_Condition_In_Decl_Part
17839 -- * Expansion - The annotation is expanded during the expansion of
17840 -- the package body whose declaration is subject to the annotation
17843 -- Expand_Pragma_Initial_Condition
17845 -- * Template - The annotation utilizes the generic template of the
17846 -- related package declaration.
17848 -- * Globals - Capture of global references must occur after full
17851 -- * Instance - The annotation is instantiated automatically when
17852 -- the related generic package is instantiated.
17854 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17855 Pack_Decl
: Node_Id
;
17856 Pack_Id
: Entity_Id
;
17860 Check_No_Identifiers
;
17861 Check_Arg_Count
(1);
17863 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17865 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17866 N_Package_Declaration
)
17872 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17874 -- A pragma that applies to a Ghost entity becomes Ghost for the
17875 -- purposes of legality checks and removal of ignored Ghost code.
17877 Mark_Ghost_Pragma
(N
, Pack_Id
);
17879 -- Chain the pragma on the contract for further processing by
17880 -- Analyze_Initial_Condition_In_Decl_Part.
17882 Add_Contract_Item
(N
, Pack_Id
);
17884 -- The legality checks of pragmas Abstract_State, Initializes, and
17885 -- Initial_Condition are affected by the SPARK mode in effect. In
17886 -- addition, these three pragmas are subject to an inherent order:
17888 -- 1) Abstract_State
17890 -- 3) Initial_Condition
17892 -- Analyze all these pragmas in the order outlined above
17894 Analyze_If_Present
(Pragma_SPARK_Mode
);
17895 Analyze_If_Present
(Pragma_Abstract_State
);
17896 Analyze_If_Present
(Pragma_Initializes
);
17897 end Initial_Condition
;
17899 ------------------------
17900 -- Initialize_Scalars --
17901 ------------------------
17903 -- pragma Initialize_Scalars
17904 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17906 -- TYPE_VALUE_PAIR ::=
17907 -- SCALAR_TYPE => static_EXPRESSION
17913 -- | Long_Long_Flat
17923 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
17924 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
17925 -- This collection holds the individual pairs which specify the
17926 -- invalid values of their respective scalar types.
17928 procedure Analyze_Float_Value
17929 (Scal_Typ
: Float_Scalar_Id
;
17930 Val_Expr
: Node_Id
);
17931 -- Analyze a type value pair associated with float type Scal_Typ
17932 -- and expression Val_Expr.
17934 procedure Analyze_Integer_Value
17935 (Scal_Typ
: Integer_Scalar_Id
;
17936 Val_Expr
: Node_Id
);
17937 -- Analyze a type value pair associated with integer type Scal_Typ
17938 -- and expression Val_Expr.
17940 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
17941 -- Analyze type value pair Pair
17943 -------------------------
17944 -- Analyze_Float_Value --
17945 -------------------------
17947 procedure Analyze_Float_Value
17948 (Scal_Typ
: Float_Scalar_Id
;
17949 Val_Expr
: Node_Id
)
17952 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
17954 if Is_OK_Static_Expression
(Val_Expr
) then
17955 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
17958 Error_Msg_Name_1
:= Scal_Typ
;
17959 Error_Msg_N
("value for type % must be static", Val_Expr
);
17961 end Analyze_Float_Value
;
17963 ---------------------------
17964 -- Analyze_Integer_Value --
17965 ---------------------------
17967 procedure Analyze_Integer_Value
17968 (Scal_Typ
: Integer_Scalar_Id
;
17969 Val_Expr
: Node_Id
)
17972 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
17974 if Is_OK_Static_Expression
(Val_Expr
) then
17975 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
17978 Error_Msg_Name_1
:= Scal_Typ
;
17979 Error_Msg_N
("value for type % must be static", Val_Expr
);
17981 end Analyze_Integer_Value
;
17983 -----------------------------
17984 -- Analyze_Type_Value_Pair --
17985 -----------------------------
17987 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
17988 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
17989 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
17990 Prev_Pair
: Node_Id
;
17993 if Scal_Typ
in Scalar_Id
then
17994 Prev_Pair
:= Seen
(Scal_Typ
);
17996 -- Prevent multiple attempts to set a value for a scalar
17999 if Present
(Prev_Pair
) then
18000 Error_Msg_Name_1
:= Scal_Typ
;
18002 ("cannot specify multiple invalid values for type %",
18005 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
18006 Error_Msg_N
("previous value set #", Pair
);
18008 -- Ignore the effects of the pair, but do not halt the
18009 -- analysis of the pragma altogether.
18013 -- Otherwise capture the first pair for this scalar type
18016 Seen
(Scal_Typ
) := Pair
;
18019 if Scal_Typ
in Float_Scalar_Id
then
18020 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18022 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18023 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18026 -- Otherwise the scalar family is illegal
18029 Error_Msg_Name_1
:= Pname
;
18031 ("argument of pragma % must denote valid scalar family",
18034 end Analyze_Type_Value_Pair
;
18038 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18041 -- Start of processing for Do_Initialize_Scalars
18045 Check_Valid_Configuration_Pragma
;
18046 Check_Restriction
(No_Initialize_Scalars
, N
);
18048 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18051 if Restriction_Active
(No_Initialize_Scalars
) then
18054 -- Initialize_Scalars creates false positives in CodePeer, and
18055 -- incorrect negative results in GNATprove mode, so ignore this
18056 -- pragma in these modes.
18058 elsif CodePeer_Mode
or GNATprove_Mode
then
18061 -- Otherwise analyze the pragma
18064 if Present
(Pairs
) then
18066 -- Install Standard in order to provide access to primitive
18067 -- types in case the expressions contain attributes such as
18070 Push_Scope
(Standard_Standard
);
18072 Pair
:= First
(Pairs
);
18073 while Present
(Pair
) loop
18074 Analyze_Type_Value_Pair
(Pair
);
18083 Init_Or_Norm_Scalars
:= True;
18084 Initialize_Scalars
:= True;
18086 end Do_Initialize_Scalars
;
18092 -- pragma Initializes (INITIALIZATION_LIST);
18094 -- INITIALIZATION_LIST ::=
18096 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18098 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18103 -- | (INPUT {, INPUT})
18107 -- Characteristics:
18109 -- * Analysis - The annotation undergoes initial checks to verify
18110 -- the legal placement and context. Secondary checks preanalyze the
18113 -- Analyze_Initializes_In_Decl_Part
18115 -- * Expansion - None.
18117 -- * Template - The annotation utilizes the generic template of the
18118 -- related package declaration.
18120 -- * Globals - Capture of global references must occur after full
18123 -- * Instance - The annotation is instantiated automatically when
18124 -- the related generic package is instantiated.
18126 when Pragma_Initializes
=> Initializes
: declare
18127 Pack_Decl
: Node_Id
;
18128 Pack_Id
: Entity_Id
;
18132 Check_No_Identifiers
;
18133 Check_Arg_Count
(1);
18135 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18137 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
18138 N_Package_Declaration
)
18144 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18146 -- A pragma that applies to a Ghost entity becomes Ghost for the
18147 -- purposes of legality checks and removal of ignored Ghost code.
18149 Mark_Ghost_Pragma
(N
, Pack_Id
);
18150 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18152 -- Chain the pragma on the contract for further processing by
18153 -- Analyze_Initializes_In_Decl_Part.
18155 Add_Contract_Item
(N
, Pack_Id
);
18157 -- The legality checks of pragmas Abstract_State, Initializes, and
18158 -- Initial_Condition are affected by the SPARK mode in effect. In
18159 -- addition, these three pragmas are subject to an inherent order:
18161 -- 1) Abstract_State
18163 -- 3) Initial_Condition
18165 -- Analyze all these pragmas in the order outlined above
18167 Analyze_If_Present
(Pragma_SPARK_Mode
);
18168 Analyze_If_Present
(Pragma_Abstract_State
);
18169 Analyze_If_Present
(Pragma_Initial_Condition
);
18176 -- pragma Inline ( NAME {, NAME} );
18178 when Pragma_Inline
=>
18180 -- Pragma always active unless in GNATprove mode. It is disabled
18181 -- in GNATprove mode because frontend inlining is applied
18182 -- independently of pragmas Inline and Inline_Always for
18183 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18186 if not GNATprove_Mode
then
18188 -- Inline status is Enabled if option -gnatn is specified.
18189 -- However this status determines only the value of the
18190 -- Is_Inlined flag on the subprogram and does not prevent
18191 -- the pragma itself from being recorded for later use,
18192 -- in particular for a later modification of Is_Inlined
18193 -- independently of the -gnatn option.
18195 -- In other words, if -gnatn is specified for a unit, then
18196 -- all Inline pragmas processed for the compilation of this
18197 -- unit, including those in the spec of other units, are
18198 -- activated, so subprograms will be inlined across units.
18200 -- If -gnatn is not specified, no Inline pragma is activated
18201 -- here, which means that subprograms will not be inlined
18202 -- across units. The Is_Inlined flag will nevertheless be
18203 -- set later when bodies are analyzed, so subprograms will
18204 -- be inlined within the unit.
18206 if Inline_Active
then
18207 Process_Inline
(Enabled
);
18209 Process_Inline
(Disabled
);
18213 -------------------
18214 -- Inline_Always --
18215 -------------------
18217 -- pragma Inline_Always ( NAME {, NAME} );
18219 when Pragma_Inline_Always
=>
18222 -- Pragma always active unless in CodePeer mode or GNATprove
18223 -- mode. It is disabled in CodePeer mode because inlining is
18224 -- not helpful, and enabling it caused walk order issues. It
18225 -- is disabled in GNATprove mode because frontend inlining is
18226 -- applied independently of pragmas Inline and Inline_Always for
18227 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18230 if not CodePeer_Mode
and not GNATprove_Mode
then
18231 Process_Inline
(Enabled
);
18234 --------------------
18235 -- Inline_Generic --
18236 --------------------
18238 -- pragma Inline_Generic (NAME {, NAME});
18240 when Pragma_Inline_Generic
=>
18242 Process_Generic_List
;
18244 ----------------------
18245 -- Inspection_Point --
18246 ----------------------
18248 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18250 when Pragma_Inspection_Point
=> Inspection_Point
: declare
18257 if Arg_Count
> 0 then
18260 Exp
:= Get_Pragma_Arg
(Arg
);
18263 if not Is_Entity_Name
(Exp
)
18264 or else not Is_Object
(Entity
(Exp
))
18266 Error_Pragma_Arg
("object name required", Arg
);
18270 exit when No
(Arg
);
18273 end Inspection_Point
;
18279 -- pragma Interface (
18280 -- [ Convention =>] convention_IDENTIFIER,
18281 -- [ Entity =>] LOCAL_NAME
18282 -- [, [External_Name =>] static_string_EXPRESSION ]
18283 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18285 when Pragma_Interface
=>
18290 Name_External_Name
,
18292 Check_At_Least_N_Arguments
(2);
18293 Check_At_Most_N_Arguments
(4);
18294 Process_Import_Or_Interface
;
18296 -- In Ada 2005, the permission to use Interface (a reserved word)
18297 -- as a pragma name is considered an obsolescent feature, and this
18298 -- pragma was already obsolescent in Ada 95.
18300 if Ada_Version
>= Ada_95
then
18302 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
18304 if Warn_On_Obsolescent_Feature
then
18306 ("pragma Interface is an obsolescent feature?j?", N
);
18308 ("|use pragma Import instead?j?", N
);
18312 --------------------
18313 -- Interface_Name --
18314 --------------------
18316 -- pragma Interface_Name (
18317 -- [ Entity =>] LOCAL_NAME
18318 -- [,[External_Name =>] static_string_EXPRESSION ]
18319 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18321 when Pragma_Interface_Name
=> Interface_Name
: declare
18323 Def_Id
: Entity_Id
;
18324 Hom_Id
: Entity_Id
;
18330 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
18331 Check_At_Least_N_Arguments
(2);
18332 Check_At_Most_N_Arguments
(3);
18333 Id
:= Get_Pragma_Arg
(Arg1
);
18336 -- This is obsolete from Ada 95 on, but it is an implementation
18337 -- defined pragma, so we do not consider that it violates the
18338 -- restriction (No_Obsolescent_Features).
18340 if Ada_Version
>= Ada_95
then
18341 if Warn_On_Obsolescent_Feature
then
18343 ("pragma Interface_Name is an obsolescent feature?j?", N
);
18345 ("|use pragma Import instead?j?", N
);
18349 if not Is_Entity_Name
(Id
) then
18351 ("first argument for pragma% must be entity name", Arg1
);
18352 elsif Etype
(Id
) = Any_Type
then
18355 Def_Id
:= Entity
(Id
);
18358 -- Special DEC-compatible processing for the object case, forces
18359 -- object to be imported.
18361 if Ekind
(Def_Id
) = E_Variable
then
18362 Kill_Size_Check_Code
(Def_Id
);
18363 Note_Possible_Modification
(Id
, Sure
=> False);
18365 -- Initialization is not allowed for imported variable
18367 if Present
(Expression
(Parent
(Def_Id
)))
18368 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
18370 Error_Msg_Sloc
:= Sloc
(Def_Id
);
18372 ("no initialization allowed for declaration of& #",
18376 -- For compatibility, support VADS usage of providing both
18377 -- pragmas Interface and Interface_Name to obtain the effect
18378 -- of a single Import pragma.
18380 if Is_Imported
(Def_Id
)
18381 and then Present
(First_Rep_Item
(Def_Id
))
18382 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
18383 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
18388 Set_Imported
(Def_Id
);
18391 Set_Is_Public
(Def_Id
);
18392 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18395 -- Otherwise must be subprogram
18397 elsif not Is_Subprogram
(Def_Id
) then
18399 ("argument of pragma% is not subprogram", Arg1
);
18402 Check_At_Most_N_Arguments
(3);
18406 -- Loop through homonyms
18409 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
18411 if Is_Imported
(Def_Id
) then
18412 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18416 exit when From_Aspect_Specification
(N
);
18417 Hom_Id
:= Homonym
(Hom_Id
);
18419 exit when No
(Hom_Id
)
18420 or else Scope
(Hom_Id
) /= Current_Scope
;
18425 ("argument of pragma% is not imported subprogram",
18429 end Interface_Name
;
18431 -----------------------
18432 -- Interrupt_Handler --
18433 -----------------------
18435 -- pragma Interrupt_Handler (handler_NAME);
18437 when Pragma_Interrupt_Handler
=>
18438 Check_Ada_83_Warning
;
18439 Check_Arg_Count
(1);
18440 Check_No_Identifiers
;
18442 if No_Run_Time_Mode
then
18443 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
18445 Check_Interrupt_Or_Attach_Handler
;
18446 Process_Interrupt_Or_Attach_Handler
;
18449 ------------------------
18450 -- Interrupt_Priority --
18451 ------------------------
18453 -- pragma Interrupt_Priority [(EXPRESSION)];
18455 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
18456 P
: constant Node_Id
:= Parent
(N
);
18461 Check_Ada_83_Warning
;
18463 if Arg_Count
/= 0 then
18464 Arg
:= Get_Pragma_Arg
(Arg1
);
18465 Check_Arg_Count
(1);
18466 Check_No_Identifiers
;
18468 -- The expression must be analyzed in the special manner
18469 -- described in "Handling of Default and Per-Object
18470 -- Expressions" in sem.ads.
18472 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
18475 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
18480 Ent
:= Defining_Identifier
(Parent
(P
));
18482 -- Check duplicate pragma before we chain the pragma in the Rep
18483 -- Item chain of Ent.
18485 Check_Duplicate_Pragma
(Ent
);
18486 Record_Rep_Item
(Ent
, N
);
18488 -- Check the No_Task_At_Interrupt_Priority restriction
18490 if Nkind
(P
) = N_Task_Definition
then
18491 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
18494 end Interrupt_Priority
;
18496 ---------------------
18497 -- Interrupt_State --
18498 ---------------------
18500 -- pragma Interrupt_State (
18501 -- [Name =>] INTERRUPT_ID,
18502 -- [State =>] INTERRUPT_STATE);
18504 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18505 -- INTERRUPT_STATE => System | Runtime | User
18507 -- Note: if the interrupt id is given as an identifier, then it must
18508 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18509 -- given as a static integer expression which must be in the range of
18510 -- Ada.Interrupts.Interrupt_ID.
18512 when Pragma_Interrupt_State
=> Interrupt_State
: declare
18513 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
18514 -- This is the entity Ada.Interrupts.Interrupt_ID;
18516 State_Type
: Character;
18517 -- Set to 's'/'r'/'u' for System/Runtime/User
18520 -- Index to entry in Interrupt_States table
18523 -- Value of interrupt
18525 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18526 -- The first argument to the pragma
18528 Int_Ent
: Entity_Id
;
18529 -- Interrupt entity in Ada.Interrupts.Names
18533 Check_Arg_Order
((Name_Name
, Name_State
));
18534 Check_Arg_Count
(2);
18536 Check_Optional_Identifier
(Arg1
, Name_Name
);
18537 Check_Optional_Identifier
(Arg2
, Name_State
);
18538 Check_Arg_Is_Identifier
(Arg2
);
18540 -- First argument is identifier
18542 if Nkind
(Arg1X
) = N_Identifier
then
18544 -- Search list of names in Ada.Interrupts.Names
18546 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
18548 if No
(Int_Ent
) then
18549 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
18551 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
18552 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
18556 Next_Entity
(Int_Ent
);
18559 -- First argument is not an identifier, so it must be a static
18560 -- expression of type Ada.Interrupts.Interrupt_ID.
18563 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
18564 Int_Val
:= Expr_Value
(Arg1X
);
18566 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
18568 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
18571 ("value not in range of type "
18572 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
18578 case Chars
(Get_Pragma_Arg
(Arg2
)) is
18579 when Name_Runtime
=> State_Type
:= 'r';
18580 when Name_System
=> State_Type
:= 's';
18581 when Name_User
=> State_Type
:= 'u';
18584 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
18587 -- Check if entry is already stored
18589 IST_Num
:= Interrupt_States
.First
;
18591 -- If entry not found, add it
18593 if IST_Num
> Interrupt_States
.Last
then
18594 Interrupt_States
.Append
18595 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
18596 Interrupt_State
=> State_Type
,
18597 Pragma_Loc
=> Loc
));
18600 -- Case of entry for the same entry
18602 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
18605 -- If state matches, done, no need to make redundant entry
18608 State_Type
= Interrupt_States
.Table
(IST_Num
).
18611 -- Otherwise if state does not match, error
18614 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
18616 ("state conflicts with that given #", Arg2
);
18620 IST_Num
:= IST_Num
+ 1;
18622 end Interrupt_State
;
18628 -- pragma Invariant
18629 -- ([Entity =>] type_LOCAL_NAME,
18630 -- [Check =>] EXPRESSION
18631 -- [,[Message =>] String_Expression]);
18633 when Pragma_Invariant
=> Invariant
: declare
18640 Check_At_Least_N_Arguments
(2);
18641 Check_At_Most_N_Arguments
(3);
18642 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18643 Check_Optional_Identifier
(Arg2
, Name_Check
);
18645 if Arg_Count
= 3 then
18646 Check_Optional_Identifier
(Arg3
, Name_Message
);
18647 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
18650 Check_Arg_Is_Local_Name
(Arg1
);
18652 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
18653 Find_Type
(Typ_Arg
);
18654 Typ
:= Entity
(Typ_Arg
);
18656 -- Nothing to do of the related type is erroneous in some way
18658 if Typ
= Any_Type
then
18661 -- AI12-0041: Invariants are allowed in interface types
18663 elsif Is_Interface
(Typ
) then
18666 -- An invariant must apply to a private type, or appear in the
18667 -- private part of a package spec and apply to a completion.
18668 -- a class-wide invariant can only appear on a private declaration
18669 -- or private extension, not a completion.
18671 -- A [class-wide] invariant may be associated a [limited] private
18672 -- type or a private extension.
18674 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
18676 E_Record_Type_With_Private
)
18680 -- A non-class-wide invariant may be associated with the full view
18681 -- of a [limited] private type or a private extension.
18683 elsif Has_Private_Declaration
(Typ
)
18684 and then not Class_Present
(N
)
18688 -- A class-wide invariant may appear on the partial view only
18690 elsif Class_Present
(N
) then
18692 ("pragma % only allowed for private type", Arg1
);
18695 -- A regular invariant may appear on both views
18699 ("pragma % only allowed for private type or corresponding "
18700 & "full view", Arg1
);
18704 -- An invariant associated with an abstract type (this includes
18705 -- interfaces) must be class-wide.
18707 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
18709 ("pragma % not allowed for abstract type", Arg1
);
18713 -- A pragma that applies to a Ghost entity becomes Ghost for the
18714 -- purposes of legality checks and removal of ignored Ghost code.
18716 Mark_Ghost_Pragma
(N
, Typ
);
18718 -- The pragma defines a type-specific invariant, the type is said
18719 -- to have invariants of its "own".
18721 Set_Has_Own_Invariants
(Typ
);
18723 -- If the invariant is class-wide, then it can be inherited by
18724 -- derived or interface implementing types. The type is said to
18725 -- have "inheritable" invariants.
18727 if Class_Present
(N
) then
18728 Set_Has_Inheritable_Invariants
(Typ
);
18731 -- Chain the pragma on to the rep item chain, for processing when
18732 -- the type is frozen.
18734 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18736 -- Create the declaration of the invariant procedure that will
18737 -- verify the invariant at run time. Interfaces are treated as the
18738 -- partial view of a private type in order to achieve uniformity
18739 -- with the general case. As a result, an interface receives only
18740 -- a "partial" invariant procedure, which is never called.
18742 Build_Invariant_Procedure_Declaration
18744 Partial_Invariant
=> Is_Interface
(Typ
));
18751 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18753 when Pragma_Keep_Names
=> Keep_Names
: declare
18758 Check_Arg_Count
(1);
18759 Check_Optional_Identifier
(Arg1
, Name_On
);
18760 Check_Arg_Is_Local_Name
(Arg1
);
18762 Arg
:= Get_Pragma_Arg
(Arg1
);
18765 if Etype
(Arg
) = Any_Type
then
18769 if not Is_Entity_Name
(Arg
)
18770 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18773 ("pragma% requires a local enumeration type", Arg1
);
18776 Set_Discard_Names
(Entity
(Arg
), False);
18783 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18785 when Pragma_License
=>
18788 -- Do not analyze pragma any further in CodePeer mode, to avoid
18789 -- extraneous errors in this implementation-dependent pragma,
18790 -- which has a different profile on other compilers.
18792 if CodePeer_Mode
then
18796 Check_Arg_Count
(1);
18797 Check_No_Identifiers
;
18798 Check_Valid_Configuration_Pragma
;
18799 Check_Arg_Is_Identifier
(Arg1
);
18802 Sind
: constant Source_File_Index
:=
18803 Source_Index
(Current_Sem_Unit
);
18806 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18808 Set_License
(Sind
, GPL
);
18810 when Name_Modified_GPL
=>
18811 Set_License
(Sind
, Modified_GPL
);
18813 when Name_Restricted
=>
18814 Set_License
(Sind
, Restricted
);
18816 when Name_Unrestricted
=>
18817 Set_License
(Sind
, Unrestricted
);
18820 Error_Pragma_Arg
("invalid license name", Arg1
);
18828 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18830 when Pragma_Link_With
=> Link_With
: declare
18836 if Operating_Mode
= Generate_Code
18837 and then In_Extended_Main_Source_Unit
(N
)
18839 Check_At_Least_N_Arguments
(1);
18840 Check_No_Identifiers
;
18841 Check_Is_In_Decl_Part_Or_Package_Spec
;
18842 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18846 while Present
(Arg
) loop
18847 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18849 -- Store argument, converting sequences of spaces to a
18850 -- single null character (this is one of the differences
18851 -- in processing between Link_With and Linker_Options).
18853 Arg_Store
: declare
18854 C
: constant Char_Code
:= Get_Char_Code
(' ');
18855 S
: constant String_Id
:=
18856 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
18857 L
: constant Nat
:= String_Length
(S
);
18860 procedure Skip_Spaces
;
18861 -- Advance F past any spaces
18867 procedure Skip_Spaces
is
18869 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
18874 -- Start of processing for Arg_Store
18877 Skip_Spaces
; -- skip leading spaces
18879 -- Loop through characters, changing any embedded
18880 -- sequence of spaces to a single null character (this
18881 -- is how Link_With/Linker_Options differ)
18884 if Get_String_Char
(S
, F
) = C
then
18887 Store_String_Char
(ASCII
.NUL
);
18890 Store_String_Char
(Get_String_Char
(S
, F
));
18898 if Present
(Arg
) then
18899 Store_String_Char
(ASCII
.NUL
);
18903 Store_Linker_Option_String
(End_String
);
18911 -- pragma Linker_Alias (
18912 -- [Entity =>] LOCAL_NAME
18913 -- [Target =>] static_string_EXPRESSION);
18915 when Pragma_Linker_Alias
=>
18917 Check_Arg_Order
((Name_Entity
, Name_Target
));
18918 Check_Arg_Count
(2);
18919 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18920 Check_Optional_Identifier
(Arg2
, Name_Target
);
18921 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18922 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18924 -- The only processing required is to link this item on to the
18925 -- list of rep items for the given entity. This is accomplished
18926 -- by the call to Rep_Item_Too_Late (when no error is detected
18927 -- and False is returned).
18929 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
18932 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18935 ------------------------
18936 -- Linker_Constructor --
18937 ------------------------
18939 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18941 -- Code is shared with Linker_Destructor
18943 -----------------------
18944 -- Linker_Destructor --
18945 -----------------------
18947 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18949 when Pragma_Linker_Constructor
18950 | Pragma_Linker_Destructor
18952 Linker_Constructor
: declare
18958 Check_Arg_Count
(1);
18959 Check_No_Identifiers
;
18960 Check_Arg_Is_Local_Name
(Arg1
);
18961 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
18963 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
18965 if not Is_Library_Level_Entity
(Proc
) then
18967 ("argument for pragma% must be library level entity", Arg1
);
18970 -- The only processing required is to link this item on to the
18971 -- list of rep items for the given entity. This is accomplished
18972 -- by the call to Rep_Item_Too_Late (when no error is detected
18973 -- and False is returned).
18975 if Rep_Item_Too_Late
(Proc
, N
) then
18978 Set_Has_Gigi_Rep_Item
(Proc
);
18980 end Linker_Constructor
;
18982 --------------------
18983 -- Linker_Options --
18984 --------------------
18986 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18988 when Pragma_Linker_Options
=> Linker_Options
: declare
18992 Check_Ada_83_Warning
;
18993 Check_No_Identifiers
;
18994 Check_Arg_Count
(1);
18995 Check_Is_In_Decl_Part_Or_Package_Spec
;
18996 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18997 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
19000 while Present
(Arg
) loop
19001 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
19002 Store_String_Char
(ASCII
.NUL
);
19004 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19008 if Operating_Mode
= Generate_Code
19009 and then In_Extended_Main_Source_Unit
(N
)
19011 Store_Linker_Option_String
(End_String
);
19013 end Linker_Options
;
19015 --------------------
19016 -- Linker_Section --
19017 --------------------
19019 -- pragma Linker_Section (
19020 -- [Entity =>] LOCAL_NAME
19021 -- [Section =>] static_string_EXPRESSION);
19023 when Pragma_Linker_Section
=> Linker_Section
: declare
19028 Ghost_Error_Posted
: Boolean := False;
19029 -- Flag set when an error concerning the illegal mix of Ghost and
19030 -- non-Ghost subprograms is emitted.
19032 Ghost_Id
: Entity_Id
:= Empty
;
19033 -- The entity of the first Ghost subprogram encountered while
19034 -- processing the arguments of the pragma.
19038 Check_Arg_Order
((Name_Entity
, Name_Section
));
19039 Check_Arg_Count
(2);
19040 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19041 Check_Optional_Identifier
(Arg2
, Name_Section
);
19042 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19043 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19045 -- Check kind of entity
19047 Arg
:= Get_Pragma_Arg
(Arg1
);
19048 Ent
:= Entity
(Arg
);
19050 case Ekind
(Ent
) is
19052 -- Objects (constants and variables) and types. For these cases
19053 -- all we need to do is to set the Linker_Section_pragma field,
19054 -- checking that we do not have a duplicate.
19060 LPE
:= Linker_Section_Pragma
(Ent
);
19062 if Present
(LPE
) then
19063 Error_Msg_Sloc
:= Sloc
(LPE
);
19065 ("Linker_Section already specified for &#", Arg1
, Ent
);
19068 Set_Linker_Section_Pragma
(Ent
, N
);
19070 -- A pragma that applies to a Ghost entity becomes Ghost for
19071 -- the purposes of legality checks and removal of ignored
19074 Mark_Ghost_Pragma
(N
, Ent
);
19078 when Subprogram_Kind
=>
19080 -- Aspect case, entity already set
19082 if From_Aspect_Specification
(N
) then
19083 Set_Linker_Section_Pragma
19084 (Entity
(Corresponding_Aspect
(N
)), N
);
19086 -- Pragma case, we must climb the homonym chain, but skip
19087 -- any for which the linker section is already set.
19091 if No
(Linker_Section_Pragma
(Ent
)) then
19092 Set_Linker_Section_Pragma
(Ent
, N
);
19094 -- A pragma that applies to a Ghost entity becomes
19095 -- Ghost for the purposes of legality checks and
19096 -- removal of ignored Ghost code.
19098 Mark_Ghost_Pragma
(N
, Ent
);
19100 -- Capture the entity of the first Ghost subprogram
19101 -- being processed for error detection purposes.
19103 if Is_Ghost_Entity
(Ent
) then
19104 if No
(Ghost_Id
) then
19108 -- Otherwise the subprogram is non-Ghost. It is
19109 -- illegal to mix references to Ghost and non-Ghost
19110 -- entities (SPARK RM 6.9).
19112 elsif Present
(Ghost_Id
)
19113 and then not Ghost_Error_Posted
19115 Ghost_Error_Posted
:= True;
19117 Error_Msg_Name_1
:= Pname
;
19119 ("pragma % cannot mention ghost and "
19120 & "non-ghost subprograms", N
);
19122 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19124 ("\& # declared as ghost", N
, Ghost_Id
);
19126 Error_Msg_Sloc
:= Sloc
(Ent
);
19128 ("\& # declared as non-ghost", N
, Ent
);
19132 Ent
:= Homonym
(Ent
);
19134 or else Scope
(Ent
) /= Current_Scope
;
19138 -- All other cases are illegal
19142 ("pragma% applies only to objects, subprograms, and types",
19145 end Linker_Section
;
19151 -- pragma List (On | Off)
19153 -- There is nothing to do here, since we did all the processing for
19154 -- this pragma in Par.Prag (so that it works properly even in syntax
19157 when Pragma_List
=>
19164 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19166 when Pragma_Lock_Free
=> Lock_Free
: declare
19167 P
: constant Node_Id
:= Parent
(N
);
19173 Check_No_Identifiers
;
19174 Check_At_Most_N_Arguments
(1);
19176 -- Protected definition case
19178 if Nkind
(P
) = N_Protected_Definition
then
19179 Ent
:= Defining_Identifier
(Parent
(P
));
19183 if Arg_Count
= 1 then
19184 Arg
:= Get_Pragma_Arg
(Arg1
);
19185 Val
:= Is_True
(Static_Boolean
(Arg
));
19187 -- No arguments (expression is considered to be True)
19193 -- Check duplicate pragma before we chain the pragma in the Rep
19194 -- Item chain of Ent.
19196 Check_Duplicate_Pragma
(Ent
);
19197 Record_Rep_Item
(Ent
, N
);
19198 Set_Uses_Lock_Free
(Ent
, Val
);
19200 -- Anything else is incorrect placement
19207 --------------------
19208 -- Locking_Policy --
19209 --------------------
19211 -- pragma Locking_Policy (policy_IDENTIFIER);
19213 when Pragma_Locking_Policy
=> declare
19214 subtype LP_Range
is Name_Id
19215 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
19220 Check_Ada_83_Warning
;
19221 Check_Arg_Count
(1);
19222 Check_No_Identifiers
;
19223 Check_Arg_Is_Locking_Policy
(Arg1
);
19224 Check_Valid_Configuration_Pragma
;
19225 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19228 when Name_Ceiling_Locking
=> LP
:= 'C';
19229 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
19230 when Name_Inheritance_Locking
=> LP
:= 'I';
19233 if Locking_Policy
/= ' '
19234 and then Locking_Policy
/= LP
19236 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19237 Error_Pragma
("locking policy incompatible with policy#");
19239 -- Set new policy, but always preserve System_Location since we
19240 -- like the error message with the run time name.
19243 Locking_Policy
:= LP
;
19245 if Locking_Policy_Sloc
/= System_Location
then
19246 Locking_Policy_Sloc
:= Loc
;
19251 -------------------
19252 -- Loop_Optimize --
19253 -------------------
19255 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19257 -- OPTIMIZATION_HINT ::=
19258 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19260 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
19265 Check_At_Least_N_Arguments
(1);
19266 Check_No_Identifiers
;
19268 Hint
:= First
(Pragma_Argument_Associations
(N
));
19269 while Present
(Hint
) loop
19270 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
19278 Check_Loop_Pragma_Placement
;
19285 -- pragma Loop_Variant
19286 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19288 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19290 -- CHANGE_DIRECTION ::= Increases | Decreases
19292 when Pragma_Loop_Variant
=> Loop_Variant
: declare
19297 Check_At_Least_N_Arguments
(1);
19298 Check_Loop_Pragma_Placement
;
19300 -- Process all increasing / decreasing expressions
19302 Variant
:= First
(Pragma_Argument_Associations
(N
));
19303 while Present
(Variant
) loop
19304 if Chars
(Variant
) = No_Name
then
19305 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
19307 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
19311 Name
: String := Get_Name_String
(Chars
(Variant
));
19314 -- It is a common mistake to write "Increasing" for
19315 -- "Increases" or "Decreasing" for "Decreases". Recognize
19316 -- specially names starting with "incr" or "decr" to
19317 -- suggest the corresponding name.
19319 System
.Case_Util
.To_Lower
(Name
);
19321 if Name
'Length >= 4
19322 and then Name
(1 .. 4) = "incr"
19324 Error_Pragma_Arg_Ident
19325 ("expect name `Increases`", Variant
);
19327 elsif Name
'Length >= 4
19328 and then Name
(1 .. 4) = "decr"
19330 Error_Pragma_Arg_Ident
19331 ("expect name `Decreases`", Variant
);
19334 Error_Pragma_Arg_Ident
19335 ("expect name `Increases` or `Decreases`", Variant
);
19340 Preanalyze_Assert_Expression
19341 (Expression
(Variant
), Any_Discrete
);
19347 -----------------------
19348 -- Machine_Attribute --
19349 -----------------------
19351 -- pragma Machine_Attribute (
19352 -- [Entity =>] LOCAL_NAME,
19353 -- [Attribute_Name =>] static_string_EXPRESSION
19354 -- [, [Info =>] static_EXPRESSION] );
19356 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
19357 Def_Id
: Entity_Id
;
19361 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
19363 if Arg_Count
= 3 then
19364 Check_Optional_Identifier
(Arg3
, Name_Info
);
19365 Check_Arg_Is_OK_Static_Expression
(Arg3
);
19367 Check_Arg_Count
(2);
19370 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19371 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
19372 Check_Arg_Is_Local_Name
(Arg1
);
19373 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19374 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
19376 if Is_Access_Type
(Def_Id
) then
19377 Def_Id
:= Designated_Type
(Def_Id
);
19380 if Rep_Item_Too_Early
(Def_Id
, N
) then
19384 Def_Id
:= Underlying_Type
(Def_Id
);
19386 -- The only processing required is to link this item on to the
19387 -- list of rep items for the given entity. This is accomplished
19388 -- by the call to Rep_Item_Too_Late (when no error is detected
19389 -- and False is returned).
19391 if Rep_Item_Too_Late
(Def_Id
, N
) then
19394 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19396 end Machine_Attribute
;
19403 -- (MAIN_OPTION [, MAIN_OPTION]);
19406 -- [STACK_SIZE =>] static_integer_EXPRESSION
19407 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19408 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19410 when Pragma_Main
=> Main
: declare
19411 Args
: Args_List
(1 .. 3);
19412 Names
: constant Name_List
(1 .. 3) := (
19414 Name_Task_Stack_Size_Default
,
19415 Name_Time_Slicing_Enabled
);
19421 Gather_Associations
(Names
, Args
);
19423 for J
in 1 .. 2 loop
19424 if Present
(Args
(J
)) then
19425 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19429 if Present
(Args
(3)) then
19430 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
19434 while Present
(Nod
) loop
19435 if Nkind
(Nod
) = N_Pragma
19436 and then Pragma_Name
(Nod
) = Name_Main
19438 Error_Msg_Name_1
:= Pname
;
19439 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19450 -- pragma Main_Storage
19451 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19453 -- MAIN_STORAGE_OPTION ::=
19454 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19455 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19457 when Pragma_Main_Storage
=> Main_Storage
: declare
19458 Args
: Args_List
(1 .. 2);
19459 Names
: constant Name_List
(1 .. 2) := (
19460 Name_Working_Storage
,
19467 Gather_Associations
(Names
, Args
);
19469 for J
in 1 .. 2 loop
19470 if Present
(Args
(J
)) then
19471 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19475 Check_In_Main_Program
;
19478 while Present
(Nod
) loop
19479 if Nkind
(Nod
) = N_Pragma
19480 and then Pragma_Name
(Nod
) = Name_Main_Storage
19482 Error_Msg_Name_1
:= Pname
;
19483 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19490 ----------------------
19491 -- Max_Queue_Length --
19492 ----------------------
19494 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
19496 -- This processing is shared by Pragma_Max_Entry_Queue_Depth
19498 when Pragma_Max_Queue_Length
19499 | Pragma_Max_Entry_Queue_Depth
19501 Max_Queue_Length
: declare
19503 Entry_Decl
: Node_Id
;
19504 Entry_Id
: Entity_Id
;
19508 if Prag_Id
= Pragma_Max_Queue_Length
then
19512 Check_Arg_Count
(1);
19515 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
19517 -- Entry declaration
19519 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
19521 -- Entry illegally within a task
19523 if Nkind
(Parent
(N
)) = N_Task_Definition
then
19524 Error_Pragma
("pragma % cannot apply to task entries");
19528 Entry_Id
:= Defining_Entity
(Entry_Decl
);
19530 -- Otherwise the pragma is associated with an illegal construct
19533 Error_Pragma
("pragma % must apply to a protected entry");
19537 -- Mark the pragma as Ghost if the related subprogram is also
19538 -- Ghost. This also ensures that any expansion performed further
19539 -- below will produce Ghost nodes.
19541 Mark_Ghost_Pragma
(N
, Entry_Id
);
19543 -- Analyze the Integer expression
19545 Arg
:= Get_Pragma_Arg
(Arg1
);
19546 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
19548 Val
:= Expr_Value
(Arg
);
19552 ("argument for pragma% must be positive", Arg1
);
19554 elsif not UI_Is_In_Int_Range
(Val
) then
19556 ("argument for pragma% out of range of Integer", Arg1
);
19560 -- Manually substitute the expression value of the pragma argument
19561 -- if it's not an integer literal because this is not taken care
19562 -- of automatically elsewhere.
19564 if Nkind
(Arg
) /= N_Integer_Literal
then
19565 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
19566 Set_Etype
(Arg
, Etype
(Original_Node
(Arg
)));
19569 Record_Rep_Item
(Entry_Id
, N
);
19570 end Max_Queue_Length
;
19576 -- pragma Memory_Size (NUMERIC_LITERAL)
19578 when Pragma_Memory_Size
=>
19581 -- Memory size is simply ignored
19583 Check_No_Identifiers
;
19584 Check_Arg_Count
(1);
19585 Check_Arg_Is_Integer_Literal
(Arg1
);
19593 -- The only correct use of this pragma is on its own in a file, in
19594 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19595 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19596 -- check for a file containing nothing but a No_Body pragma). If we
19597 -- attempt to process it during normal semantics processing, it means
19598 -- it was misplaced.
19600 when Pragma_No_Body
=>
19604 -----------------------------
19605 -- No_Elaboration_Code_All --
19606 -----------------------------
19608 -- pragma No_Elaboration_Code_All;
19610 when Pragma_No_Elaboration_Code_All
=>
19612 Check_Valid_Library_Unit_Pragma
;
19614 if Nkind
(N
) = N_Null_Statement
then
19618 -- Must appear for a spec or generic spec
19620 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
19621 N_Generic_Package_Declaration
,
19622 N_Generic_Subprogram_Declaration
,
19623 N_Package_Declaration
,
19624 N_Subprogram_Declaration
)
19628 ("pragma% can only occur for package "
19629 & "or subprogram spec"));
19632 -- Set flag in unit table
19634 Set_No_Elab_Code_All
(Current_Sem_Unit
);
19636 -- Set restriction No_Elaboration_Code if this is the main unit
19638 if Current_Sem_Unit
= Main_Unit
then
19639 Set_Restriction
(No_Elaboration_Code
, N
);
19642 -- If we are in the main unit or in an extended main source unit,
19643 -- then we also add it to the configuration restrictions so that
19644 -- it will apply to all units in the extended main source.
19646 if Current_Sem_Unit
= Main_Unit
19647 or else In_Extended_Main_Source_Unit
(N
)
19649 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
19652 -- If in main extended unit, activate transitive with test
19654 if In_Extended_Main_Source_Unit
(N
) then
19655 Opt
.No_Elab_Code_All_Pragma
:= N
;
19658 -----------------------------
19659 -- No_Component_Reordering --
19660 -----------------------------
19662 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19664 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
19670 Check_At_Most_N_Arguments
(1);
19672 if Arg_Count
= 0 then
19673 Check_Valid_Configuration_Pragma
;
19674 Opt
.No_Component_Reordering
:= True;
19677 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19678 Check_Arg_Is_Local_Name
(Arg1
);
19679 E_Id
:= Get_Pragma_Arg
(Arg1
);
19681 if Etype
(E_Id
) = Any_Type
then
19685 E
:= Entity
(E_Id
);
19687 if not Is_Record_Type
(E
) then
19688 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
19691 Set_No_Reordering
(Base_Type
(E
));
19693 end No_Comp_Reordering
;
19695 --------------------------
19696 -- No_Heap_Finalization --
19697 --------------------------
19699 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19701 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
19702 Context
: constant Node_Id
:= Parent
(N
);
19703 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19709 Check_No_Identifiers
;
19711 -- The pragma appears in a configuration file
19713 if No
(Context
) then
19714 Check_Arg_Count
(0);
19715 Check_Valid_Configuration_Pragma
;
19717 -- Detect a duplicate pragma
19719 if Present
(No_Heap_Finalization_Pragma
) then
19722 Prev
=> No_Heap_Finalization_Pragma
);
19726 No_Heap_Finalization_Pragma
:= N
;
19728 -- Otherwise the pragma should be associated with a library-level
19729 -- named access-to-object type.
19732 Check_Arg_Count
(1);
19733 Check_Arg_Is_Local_Name
(Arg1
);
19735 Find_Type
(Typ_Arg
);
19736 Typ
:= Entity
(Typ_Arg
);
19738 -- The type being subjected to the pragma is erroneous
19740 if Typ
= Any_Type
then
19741 Error_Pragma
("cannot find type referenced by pragma %");
19743 -- The pragma is applied to an incomplete or generic formal
19744 -- type way too early.
19746 elsif Rep_Item_Too_Early
(Typ
, N
) then
19750 Typ
:= Underlying_Type
(Typ
);
19753 -- The pragma must apply to an access-to-object type
19755 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
19758 -- Give a detailed error message on all other access type kinds
19760 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19762 ("pragma % cannot apply to access protected subprogram "
19765 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19767 ("pragma % cannot apply to access subprogram type");
19769 elsif Is_Anonymous_Access_Type
(Typ
) then
19771 ("pragma % cannot apply to anonymous access type");
19773 -- Give a general error message in case the pragma applies to a
19774 -- non-access type.
19778 ("pragma % must apply to library level access type");
19781 -- At this point the argument denotes an access-to-object type.
19782 -- Ensure that the type is declared at the library level.
19784 if Is_Library_Level_Entity
(Typ
) then
19787 -- Quietly ignore an access-to-object type originally declared
19788 -- at the library level within a generic, but instantiated at
19789 -- a non-library level. As a result the access-to-object type
19790 -- "loses" its No_Heap_Finalization property.
19792 elsif In_Instance
then
19797 ("pragma % must apply to library level access type");
19800 -- Detect a duplicate pragma
19802 if Present
(No_Heap_Finalization_Pragma
) then
19805 Prev
=> No_Heap_Finalization_Pragma
);
19809 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
19811 if Present
(Prev
) then
19819 Record_Rep_Item
(Typ
, N
);
19821 end No_Heap_Finalization
;
19827 -- pragma No_Inline ( NAME {, NAME} );
19829 when Pragma_No_Inline
=>
19831 Process_Inline
(Suppressed
);
19837 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19839 when Pragma_No_Return
=> No_Return
: declare
19845 Ghost_Error_Posted
: Boolean := False;
19846 -- Flag set when an error concerning the illegal mix of Ghost and
19847 -- non-Ghost subprograms is emitted.
19849 Ghost_Id
: Entity_Id
:= Empty
;
19850 -- The entity of the first Ghost procedure encountered while
19851 -- processing the arguments of the pragma.
19855 Check_At_Least_N_Arguments
(1);
19857 -- Loop through arguments of pragma
19860 while Present
(Arg
) loop
19861 Check_Arg_Is_Local_Name
(Arg
);
19862 Id
:= Get_Pragma_Arg
(Arg
);
19865 if not Is_Entity_Name
(Id
) then
19866 Error_Pragma_Arg
("entity name required", Arg
);
19869 if Etype
(Id
) = Any_Type
then
19873 -- Loop to find matching procedures
19879 and then Scope
(E
) = Current_Scope
19881 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
19883 -- Check that the pragma is not applied to a body.
19884 -- First check the specless body case, to give a
19885 -- different error message. These checks do not apply
19886 -- if Relaxed_RM_Semantics, to accommodate other Ada
19887 -- compilers. Disable these checks under -gnatd.J.
19889 if not Debug_Flag_Dot_JJ
then
19890 if Nkind
(Parent
(Declaration_Node
(E
))) =
19892 and then not Relaxed_RM_Semantics
19895 ("pragma% requires separate spec and must come "
19899 -- Now the "specful" body case
19901 if Rep_Item_Too_Late
(E
, N
) then
19908 -- A pragma that applies to a Ghost entity becomes Ghost
19909 -- for the purposes of legality checks and removal of
19910 -- ignored Ghost code.
19912 Mark_Ghost_Pragma
(N
, E
);
19914 -- Capture the entity of the first Ghost procedure being
19915 -- processed for error detection purposes.
19917 if Is_Ghost_Entity
(E
) then
19918 if No
(Ghost_Id
) then
19922 -- Otherwise the subprogram is non-Ghost. It is illegal
19923 -- to mix references to Ghost and non-Ghost entities
19926 elsif Present
(Ghost_Id
)
19927 and then not Ghost_Error_Posted
19929 Ghost_Error_Posted
:= True;
19931 Error_Msg_Name_1
:= Pname
;
19933 ("pragma % cannot mention ghost and non-ghost "
19934 & "procedures", N
);
19936 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19937 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
19939 Error_Msg_Sloc
:= Sloc
(E
);
19940 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
19943 -- Set flag on any alias as well
19945 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
19946 Set_No_Return
(Alias
(E
));
19952 exit when From_Aspect_Specification
(N
);
19956 -- If entity in not in current scope it may be the enclosing
19957 -- suprogram body to which the aspect applies.
19960 if Entity
(Id
) = Current_Scope
19961 and then From_Aspect_Specification
(N
)
19963 Set_No_Return
(Entity
(Id
));
19965 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
19977 -- pragma No_Run_Time;
19979 -- Note: this pragma is retained for backwards compatibility. See
19980 -- body of Rtsfind for full details on its handling.
19982 when Pragma_No_Run_Time
=>
19984 Check_Valid_Configuration_Pragma
;
19985 Check_Arg_Count
(0);
19987 -- Remove backward compatibility if Build_Type is FSF or GPL and
19988 -- generate a warning.
19991 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
19994 Error_Pragma
("pragma% is ignored, has no effect??");
19996 No_Run_Time_Mode
:= True;
19997 Configurable_Run_Time_Mode
:= True;
19999 -- Set Duration to 32 bits if word size is 32
20001 if Ttypes
.System_Word_Size
= 32 then
20002 Duration_32_Bits_On_Target
:= True;
20005 -- Set appropriate restrictions
20007 Set_Restriction
(No_Finalization
, N
);
20008 Set_Restriction
(No_Exception_Handlers
, N
);
20009 Set_Restriction
(Max_Tasks
, N
, 0);
20010 Set_Restriction
(No_Tasking
, N
);
20014 -----------------------
20015 -- No_Tagged_Streams --
20016 -----------------------
20018 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20020 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
20026 Check_At_Most_N_Arguments
(1);
20028 -- One argument case
20030 if Arg_Count
= 1 then
20031 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20032 Check_Arg_Is_Local_Name
(Arg1
);
20033 E_Id
:= Get_Pragma_Arg
(Arg1
);
20035 if Etype
(E_Id
) = Any_Type
then
20039 E
:= Entity
(E_Id
);
20041 Check_Duplicate_Pragma
(E
);
20043 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
20045 ("argument for pragma% must be root tagged type", Arg1
);
20048 if Rep_Item_Too_Early
(E
, N
)
20050 Rep_Item_Too_Late
(E
, N
)
20054 Set_No_Tagged_Streams_Pragma
(E
, N
);
20057 -- Zero argument case
20060 Check_Is_In_Decl_Part_Or_Package_Spec
;
20061 No_Tagged_Streams
:= N
;
20063 end No_Tagged_Strms
;
20065 ------------------------
20066 -- No_Strict_Aliasing --
20067 ------------------------
20069 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20071 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
20077 Check_At_Most_N_Arguments
(1);
20079 if Arg_Count
= 0 then
20080 Check_Valid_Configuration_Pragma
;
20081 Opt
.No_Strict_Aliasing
:= True;
20084 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20085 Check_Arg_Is_Local_Name
(Arg1
);
20086 E_Id
:= Get_Pragma_Arg
(Arg1
);
20088 if Etype
(E_Id
) = Any_Type
then
20092 E
:= Entity
(E_Id
);
20094 if not Is_Access_Type
(E
) then
20095 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
20098 Set_No_Strict_Aliasing
(Base_Type
(E
));
20100 end No_Strict_Aliasing
;
20102 -----------------------
20103 -- Normalize_Scalars --
20104 -----------------------
20106 -- pragma Normalize_Scalars;
20108 when Pragma_Normalize_Scalars
=>
20109 Check_Ada_83_Warning
;
20110 Check_Arg_Count
(0);
20111 Check_Valid_Configuration_Pragma
;
20113 -- Normalize_Scalars creates false positives in CodePeer, and
20114 -- incorrect negative results in GNATprove mode, so ignore this
20115 -- pragma in these modes.
20117 if not (CodePeer_Mode
or GNATprove_Mode
) then
20118 Normalize_Scalars
:= True;
20119 Init_Or_Norm_Scalars
:= True;
20126 -- pragma Obsolescent;
20128 -- pragma Obsolescent (
20129 -- [Message =>] static_string_EXPRESSION
20130 -- [,[Version =>] Ada_05]]);
20132 -- pragma Obsolescent (
20133 -- [Entity =>] NAME
20134 -- [,[Message =>] static_string_EXPRESSION
20135 -- [,[Version =>] Ada_05]] );
20137 when Pragma_Obsolescent
=> Obsolescent
: declare
20141 procedure Set_Obsolescent
(E
: Entity_Id
);
20142 -- Given an entity Ent, mark it as obsolescent if appropriate
20144 ---------------------
20145 -- Set_Obsolescent --
20146 ---------------------
20148 procedure Set_Obsolescent
(E
: Entity_Id
) is
20157 -- A pragma that applies to a Ghost entity becomes Ghost for
20158 -- the purposes of legality checks and removal of ignored Ghost
20161 Mark_Ghost_Pragma
(N
, E
);
20163 -- Entity name was given
20165 if Present
(Ename
) then
20167 -- If entity name matches, we are fine. Save entity in
20168 -- pragma argument, for ASIS use.
20170 if Chars
(Ename
) = Chars
(Ent
) then
20171 Set_Entity
(Ename
, Ent
);
20172 Generate_Reference
(Ent
, Ename
);
20174 -- If entity name does not match, only possibility is an
20175 -- enumeration literal from an enumeration type declaration.
20177 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
20179 ("pragma % entity name does not match declaration");
20182 Ent
:= First_Literal
(E
);
20186 ("pragma % entity name does not match any "
20187 & "enumeration literal");
20189 elsif Chars
(Ent
) = Chars
(Ename
) then
20190 Set_Entity
(Ename
, Ent
);
20191 Generate_Reference
(Ent
, Ename
);
20195 Ent
:= Next_Literal
(Ent
);
20201 -- Ent points to entity to be marked
20203 if Arg_Count
>= 1 then
20205 -- Deal with static string argument
20207 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20208 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
20210 for J
in 1 .. String_Length
(S
) loop
20211 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
20213 ("pragma% argument does not allow wide characters",
20218 Obsolescent_Warnings
.Append
20219 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
20221 -- Check for Ada_05 parameter
20223 if Arg_Count
/= 1 then
20224 Check_Arg_Count
(2);
20227 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20230 Check_Arg_Is_Identifier
(Argx
);
20232 if Chars
(Argx
) /= Name_Ada_05
then
20233 Error_Msg_Name_2
:= Name_Ada_05
;
20235 ("only allowed argument for pragma% is %", Argx
);
20238 if Ada_Version_Explicit
< Ada_2005
20239 or else not Warn_On_Ada_2005_Compatibility
20247 -- Set flag if pragma active
20250 Set_Is_Obsolescent
(Ent
);
20254 end Set_Obsolescent
;
20256 -- Start of processing for pragma Obsolescent
20261 Check_At_Most_N_Arguments
(3);
20263 -- See if first argument specifies an entity name
20267 (Chars
(Arg1
) = Name_Entity
20269 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
20271 N_Operator_Symbol
))
20273 Ename
:= Get_Pragma_Arg
(Arg1
);
20275 -- Eliminate first argument, so we can share processing
20279 Arg_Count
:= Arg_Count
- 1;
20281 -- No Entity name argument given
20287 if Arg_Count
>= 1 then
20288 Check_Optional_Identifier
(Arg1
, Name_Message
);
20290 if Arg_Count
= 2 then
20291 Check_Optional_Identifier
(Arg2
, Name_Version
);
20295 -- Get immediately preceding declaration
20298 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
20302 -- Cases where we do not follow anything other than another pragma
20306 -- First case: library level compilation unit declaration with
20307 -- the pragma immediately following the declaration.
20309 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
20311 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
20314 -- Case 2: library unit placement for package
20318 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
20320 if Is_Package_Or_Generic_Package
(Ent
) then
20321 Set_Obsolescent
(Ent
);
20327 -- Cases where we must follow a declaration, including an
20328 -- abstract subprogram declaration, which is not in the
20329 -- other node subtypes.
20332 if Nkind
(Decl
) not in N_Declaration
20333 and then Nkind
(Decl
) not in N_Later_Decl_Item
20334 and then Nkind
(Decl
) not in N_Generic_Declaration
20335 and then Nkind
(Decl
) not in N_Renaming_Declaration
20336 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
20339 ("pragma% misplaced, "
20340 & "must immediately follow a declaration");
20343 Set_Obsolescent
(Defining_Entity
(Decl
));
20353 -- pragma Optimize (Time | Space | Off);
20355 -- The actual check for optimize is done in Gigi. Note that this
20356 -- pragma does not actually change the optimization setting, it
20357 -- simply checks that it is consistent with the pragma.
20359 when Pragma_Optimize
=>
20360 Check_No_Identifiers
;
20361 Check_Arg_Count
(1);
20362 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
20364 ------------------------
20365 -- Optimize_Alignment --
20366 ------------------------
20368 -- pragma Optimize_Alignment (Time | Space | Off);
20370 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
20372 Check_No_Identifiers
;
20373 Check_Arg_Count
(1);
20374 Check_Valid_Configuration_Pragma
;
20377 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
20380 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
20381 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
20382 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
20385 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
20389 -- Set indication that mode is set locally. If we are in fact in a
20390 -- configuration pragma file, this setting is harmless since the
20391 -- switch will get reset anyway at the start of each unit.
20393 Optimize_Alignment_Local
:= True;
20394 end Optimize_Alignment
;
20400 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20402 when Pragma_Ordered
=> Ordered
: declare
20403 Assoc
: constant Node_Id
:= Arg1
;
20409 Check_No_Identifiers
;
20410 Check_Arg_Count
(1);
20411 Check_Arg_Is_Local_Name
(Arg1
);
20413 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20414 Find_Type
(Type_Id
);
20415 Typ
:= Entity
(Type_Id
);
20417 if Typ
= Any_Type
then
20420 Typ
:= Underlying_Type
(Typ
);
20423 if not Is_Enumeration_Type
(Typ
) then
20424 Error_Pragma
("pragma% must specify enumeration type");
20427 Check_First_Subtype
(Arg1
);
20428 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
20431 -------------------
20432 -- Overflow_Mode --
20433 -------------------
20435 -- pragma Overflow_Mode
20436 -- ([General => ] MODE [, [Assertions => ] MODE]);
20438 -- MODE := STRICT | MINIMIZED | ELIMINATED
20440 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20441 -- since System.Bignums makes this assumption. This is true of nearly
20442 -- all (all?) targets.
20444 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
20445 function Get_Overflow_Mode
20447 Arg
: Node_Id
) return Overflow_Mode_Type
;
20448 -- Function to process one pragma argument, Arg. If an identifier
20449 -- is present, it must be Name. Mode type is returned if a valid
20450 -- argument exists, otherwise an error is signalled.
20452 -----------------------
20453 -- Get_Overflow_Mode --
20454 -----------------------
20456 function Get_Overflow_Mode
20458 Arg
: Node_Id
) return Overflow_Mode_Type
20460 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
20463 Check_Optional_Identifier
(Arg
, Name
);
20464 Check_Arg_Is_Identifier
(Argx
);
20466 if Chars
(Argx
) = Name_Strict
then
20469 elsif Chars
(Argx
) = Name_Minimized
then
20472 elsif Chars
(Argx
) = Name_Eliminated
then
20473 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
20475 ("Eliminated not implemented on this target", Argx
);
20481 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
20483 end Get_Overflow_Mode
;
20485 -- Start of processing for Overflow_Mode
20489 Check_At_Least_N_Arguments
(1);
20490 Check_At_Most_N_Arguments
(2);
20492 -- Process first argument
20494 Scope_Suppress
.Overflow_Mode_General
:=
20495 Get_Overflow_Mode
(Name_General
, Arg1
);
20497 -- Case of only one argument
20499 if Arg_Count
= 1 then
20500 Scope_Suppress
.Overflow_Mode_Assertions
:=
20501 Scope_Suppress
.Overflow_Mode_General
;
20503 -- Case of two arguments present
20506 Scope_Suppress
.Overflow_Mode_Assertions
:=
20507 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
20511 --------------------------
20512 -- Overriding Renamings --
20513 --------------------------
20515 -- pragma Overriding_Renamings;
20517 when Pragma_Overriding_Renamings
=>
20519 Check_Arg_Count
(0);
20520 Check_Valid_Configuration_Pragma
;
20521 Overriding_Renamings
:= True;
20527 -- pragma Pack (first_subtype_LOCAL_NAME);
20529 when Pragma_Pack
=> Pack
: declare
20530 Assoc
: constant Node_Id
:= Arg1
;
20532 Ignore
: Boolean := False;
20537 Check_No_Identifiers
;
20538 Check_Arg_Count
(1);
20539 Check_Arg_Is_Local_Name
(Arg1
);
20540 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20542 if not Is_Entity_Name
(Type_Id
)
20543 or else not Is_Type
(Entity
(Type_Id
))
20546 ("argument for pragma% must be type or subtype", Arg1
);
20549 Find_Type
(Type_Id
);
20550 Typ
:= Entity
(Type_Id
);
20553 or else Rep_Item_Too_Early
(Typ
, N
)
20557 Typ
:= Underlying_Type
(Typ
);
20560 -- A pragma that applies to a Ghost entity becomes Ghost for the
20561 -- purposes of legality checks and removal of ignored Ghost code.
20563 Mark_Ghost_Pragma
(N
, Typ
);
20565 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
20566 Error_Pragma
("pragma% must specify array or record type");
20569 Check_First_Subtype
(Arg1
);
20570 Check_Duplicate_Pragma
(Typ
);
20574 if Is_Array_Type
(Typ
) then
20575 Ctyp
:= Component_Type
(Typ
);
20577 -- Ignore pack that does nothing
20579 if Known_Static_Esize
(Ctyp
)
20580 and then Known_Static_RM_Size
(Ctyp
)
20581 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
20582 and then Addressable
(Esize
(Ctyp
))
20587 -- Process OK pragma Pack. Note that if there is a separate
20588 -- component clause present, the Pack will be cancelled. This
20589 -- processing is in Freeze.
20591 if not Rep_Item_Too_Late
(Typ
, N
) then
20593 -- In CodePeer mode, we do not need complex front-end
20594 -- expansions related to pragma Pack, so disable handling
20597 if CodePeer_Mode
then
20600 -- Normal case where we do the pack action
20604 Set_Is_Packed
(Base_Type
(Typ
));
20605 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20608 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20612 -- For record types, the pack is always effective
20614 else pragma Assert
(Is_Record_Type
(Typ
));
20615 if not Rep_Item_Too_Late
(Typ
, N
) then
20616 Set_Is_Packed
(Base_Type
(Typ
));
20617 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20618 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20629 -- There is nothing to do here, since we did all the processing for
20630 -- this pragma in Par.Prag (so that it works properly even in syntax
20633 when Pragma_Page
=>
20640 -- pragma Part_Of (ABSTRACT_STATE);
20642 -- ABSTRACT_STATE ::= NAME
20644 when Pragma_Part_Of
=> Part_Of
: declare
20645 procedure Propagate_Part_Of
20646 (Pack_Id
: Entity_Id
;
20647 State_Id
: Entity_Id
;
20648 Instance
: Node_Id
);
20649 -- Propagate the Part_Of indicator to all abstract states and
20650 -- objects declared in the visible state space of a package
20651 -- denoted by Pack_Id. State_Id is the encapsulating state.
20652 -- Instance is the package instantiation node.
20654 -----------------------
20655 -- Propagate_Part_Of --
20656 -----------------------
20658 procedure Propagate_Part_Of
20659 (Pack_Id
: Entity_Id
;
20660 State_Id
: Entity_Id
;
20661 Instance
: Node_Id
)
20663 Has_Item
: Boolean := False;
20664 -- Flag set when the visible state space contains at least one
20665 -- abstract state or variable.
20667 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
20668 -- Propagate the Part_Of indicator to all abstract states and
20669 -- objects declared in the visible state space of a package
20670 -- denoted by Pack_Id.
20672 -----------------------
20673 -- Propagate_Part_Of --
20674 -----------------------
20676 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
20677 Constits
: Elist_Id
;
20678 Item_Id
: Entity_Id
;
20681 -- Traverse the entity chain of the package and set relevant
20682 -- attributes of abstract states and objects declared in the
20683 -- visible state space of the package.
20685 Item_Id
:= First_Entity
(Pack_Id
);
20686 while Present
(Item_Id
)
20687 and then not In_Private_Part
(Item_Id
)
20689 -- Do not consider internally generated items
20691 if not Comes_From_Source
(Item_Id
) then
20694 -- Do not consider generic formals or their corresponding
20695 -- actuals because they are not part of a visible state.
20696 -- Note that both entities are marked as hidden.
20698 elsif Is_Hidden
(Item_Id
) then
20701 -- The Part_Of indicator turns an abstract state or an
20702 -- object into a constituent of the encapsulating state.
20703 -- Note that constants are considered here even though
20704 -- they may not depend on variable input. This check is
20705 -- left to the SPARK prover.
20707 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
20712 Constits
:= Part_Of_Constituents
(State_Id
);
20714 if No
(Constits
) then
20715 Constits
:= New_Elmt_List
;
20716 Set_Part_Of_Constituents
(State_Id
, Constits
);
20719 Append_Elmt
(Item_Id
, Constits
);
20720 Set_Encapsulating_State
(Item_Id
, State_Id
);
20722 -- Recursively handle nested packages and instantiations
20724 elsif Ekind
(Item_Id
) = E_Package
then
20725 Propagate_Part_Of
(Item_Id
);
20728 Next_Entity
(Item_Id
);
20730 end Propagate_Part_Of
;
20732 -- Start of processing for Propagate_Part_Of
20735 Propagate_Part_Of
(Pack_Id
);
20737 -- Detect a package instantiation that is subject to a Part_Of
20738 -- indicator, but has no visible state.
20740 if not Has_Item
then
20742 ("package instantiation & has Part_Of indicator but "
20743 & "lacks visible state", Instance
, Pack_Id
);
20745 end Propagate_Part_Of
;
20749 Constits
: Elist_Id
;
20751 Encap_Id
: Entity_Id
;
20752 Item_Id
: Entity_Id
;
20756 -- Start of processing for Part_Of
20760 Check_No_Identifiers
;
20761 Check_Arg_Count
(1);
20763 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
20765 -- Object declaration
20767 if Nkind
(Stmt
) = N_Object_Declaration
then
20770 -- Package instantiation
20772 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
20775 -- Single concurrent type declaration
20777 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
20780 -- Otherwise the pragma is associated with an illegal construct
20787 -- Extract the entity of the related object declaration or package
20788 -- instantiation. In the case of the instantiation, use the entity
20789 -- of the instance spec.
20791 if Nkind
(Stmt
) = N_Package_Instantiation
then
20792 Stmt
:= Instance_Spec
(Stmt
);
20795 Item_Id
:= Defining_Entity
(Stmt
);
20797 -- A pragma that applies to a Ghost entity becomes Ghost for the
20798 -- purposes of legality checks and removal of ignored Ghost code.
20800 Mark_Ghost_Pragma
(N
, Item_Id
);
20802 -- Chain the pragma on the contract for further processing by
20803 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20805 Add_Contract_Item
(N
, Item_Id
);
20807 -- A variable may act as constituent of a single concurrent type
20808 -- which in turn could be declared after the variable. Due to this
20809 -- discrepancy, the full analysis of indicator Part_Of is delayed
20810 -- until the end of the enclosing declarative region (see routine
20811 -- Analyze_Part_Of_In_Decl_Part).
20813 if Ekind
(Item_Id
) = E_Variable
then
20816 -- Otherwise indicator Part_Of applies to a constant or a package
20820 Encap
:= Get_Pragma_Arg
(Arg1
);
20822 -- Detect any discrepancies between the placement of the
20823 -- constant or package instantiation with respect to state
20824 -- space and the encapsulating state.
20828 Item_Id
=> Item_Id
,
20830 Encap_Id
=> Encap_Id
,
20834 pragma Assert
(Present
(Encap_Id
));
20836 if Ekind
(Item_Id
) = E_Constant
then
20837 Constits
:= Part_Of_Constituents
(Encap_Id
);
20839 if No
(Constits
) then
20840 Constits
:= New_Elmt_List
;
20841 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
20844 Append_Elmt
(Item_Id
, Constits
);
20845 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
20847 -- Propagate the Part_Of indicator to the visible state
20848 -- space of the package instantiation.
20852 (Pack_Id
=> Item_Id
,
20853 State_Id
=> Encap_Id
,
20860 ----------------------------------
20861 -- Partition_Elaboration_Policy --
20862 ----------------------------------
20864 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20866 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
20867 subtype PEP_Range
is Name_Id
20868 range First_Partition_Elaboration_Policy_Name
20869 .. Last_Partition_Elaboration_Policy_Name
;
20870 PEP_Val
: PEP_Range
;
20875 Check_Arg_Count
(1);
20876 Check_No_Identifiers
;
20877 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
20878 Check_Valid_Configuration_Pragma
;
20879 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20882 when Name_Concurrent
=> PEP
:= 'C';
20883 when Name_Sequential
=> PEP
:= 'S';
20886 if Partition_Elaboration_Policy
/= ' '
20887 and then Partition_Elaboration_Policy
/= PEP
20889 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
20891 ("partition elaboration policy incompatible with policy#");
20893 -- Set new policy, but always preserve System_Location since we
20894 -- like the error message with the run time name.
20897 Partition_Elaboration_Policy
:= PEP
;
20899 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
20900 Partition_Elaboration_Policy_Sloc
:= Loc
;
20909 -- pragma Passive [(PASSIVE_FORM)];
20911 -- PASSIVE_FORM ::= Semaphore | No
20913 when Pragma_Passive
=>
20916 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
20917 Error_Pragma
("pragma% must be within task definition");
20920 if Arg_Count
/= 0 then
20921 Check_Arg_Count
(1);
20922 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
20925 ----------------------------------
20926 -- Preelaborable_Initialization --
20927 ----------------------------------
20929 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20931 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
20936 Check_Arg_Count
(1);
20937 Check_No_Identifiers
;
20938 Check_Arg_Is_Identifier
(Arg1
);
20939 Check_Arg_Is_Local_Name
(Arg1
);
20940 Check_First_Subtype
(Arg1
);
20941 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20943 -- A pragma that applies to a Ghost entity becomes Ghost for the
20944 -- purposes of legality checks and removal of ignored Ghost code.
20946 Mark_Ghost_Pragma
(N
, Ent
);
20948 -- The pragma may come from an aspect on a private declaration,
20949 -- even if the freeze point at which this is analyzed in the
20950 -- private part after the full view.
20952 if Has_Private_Declaration
(Ent
)
20953 and then From_Aspect_Specification
(N
)
20957 -- Check appropriate type argument
20959 elsif Is_Private_Type
(Ent
)
20960 or else Is_Protected_Type
(Ent
)
20961 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
20963 -- AI05-0028: The pragma applies to all composite types. Note
20964 -- that we apply this binding interpretation to earlier versions
20965 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20966 -- choice since there are other compilers that do the same.
20968 or else Is_Composite_Type
(Ent
)
20974 ("pragma % can only be applied to private, formal derived, "
20975 & "protected, or composite type", Arg1
);
20978 -- Give an error if the pragma is applied to a protected type that
20979 -- does not qualify (due to having entries, or due to components
20980 -- that do not qualify).
20982 if Is_Protected_Type
(Ent
)
20983 and then not Has_Preelaborable_Initialization
(Ent
)
20986 ("protected type & does not have preelaborable "
20987 & "initialization", Ent
);
20989 -- Otherwise mark the type as definitely having preelaborable
20993 Set_Known_To_Have_Preelab_Init
(Ent
);
20996 if Has_Pragma_Preelab_Init
(Ent
)
20997 and then Warn_On_Redundant_Constructs
20999 Error_Pragma
("?r?duplicate pragma%!");
21001 Set_Has_Pragma_Preelab_Init
(Ent
);
21005 --------------------
21006 -- Persistent_BSS --
21007 --------------------
21009 -- pragma Persistent_BSS [(object_NAME)];
21011 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
21018 Check_At_Most_N_Arguments
(1);
21020 -- Case of application to specific object (one argument)
21022 if Arg_Count
= 1 then
21023 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21025 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
21027 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
21030 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
21033 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21035 -- A pragma that applies to a Ghost entity becomes Ghost for
21036 -- the purposes of legality checks and removal of ignored Ghost
21039 Mark_Ghost_Pragma
(N
, Ent
);
21041 -- Check for duplication before inserting in list of
21042 -- representation items.
21044 Check_Duplicate_Pragma
(Ent
);
21046 if Rep_Item_Too_Late
(Ent
, N
) then
21050 Decl
:= Parent
(Ent
);
21052 if Present
(Expression
(Decl
)) then
21054 ("object for pragma% cannot have initialization", Arg1
);
21057 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
21059 ("object type for pragma% is not potentially persistent",
21064 Make_Linker_Section_Pragma
21065 (Ent
, Sloc
(N
), ".persistent.bss");
21066 Insert_After
(N
, Prag
);
21069 -- Case of use as configuration pragma with no arguments
21072 Check_Valid_Configuration_Pragma
;
21073 Persistent_BSS_Mode
:= True;
21075 end Persistent_BSS
;
21077 --------------------
21078 -- Rename_Pragma --
21079 --------------------
21081 -- pragma Rename_Pragma (
21082 -- [New_Name =>] IDENTIFIER,
21083 -- [Renamed =>] pragma_IDENTIFIER);
21085 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
21086 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21087 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21091 Check_Valid_Configuration_Pragma
;
21092 Check_Arg_Count
(2);
21093 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
21094 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
21096 if Nkind
(New_Name
) /= N_Identifier
then
21097 Error_Pragma_Arg
("identifier expected", Arg1
);
21100 if Nkind
(Old_Name
) /= N_Identifier
then
21101 Error_Pragma_Arg
("identifier expected", Arg2
);
21104 -- The New_Name arg should not be an existing pragma (but we allow
21105 -- it; it's just a warning). The Old_Name arg must be an existing
21108 if Is_Pragma_Name
(Chars
(New_Name
)) then
21109 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
21112 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
21113 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
21116 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
21123 -- pragma Polling (ON | OFF);
21125 when Pragma_Polling
=>
21127 Check_Arg_Count
(1);
21128 Check_No_Identifiers
;
21129 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21130 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
21132 -----------------------------------
21133 -- Post/Post_Class/Postcondition --
21134 -----------------------------------
21136 -- pragma Post (Boolean_EXPRESSION);
21137 -- pragma Post_Class (Boolean_EXPRESSION);
21138 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21139 -- [,[Message =>] String_EXPRESSION]);
21141 -- Characteristics:
21143 -- * Analysis - The annotation undergoes initial checks to verify
21144 -- the legal placement and context. Secondary checks preanalyze the
21147 -- Analyze_Pre_Post_Condition_In_Decl_Part
21149 -- * Expansion - The annotation is expanded during the expansion of
21150 -- the related subprogram [body] contract as performed in:
21152 -- Expand_Subprogram_Contract
21154 -- * Template - The annotation utilizes the generic template of the
21155 -- related subprogram [body] when it is:
21157 -- aspect on subprogram declaration
21158 -- aspect on stand-alone subprogram body
21159 -- pragma on stand-alone subprogram body
21161 -- The annotation must prepare its own template when it is:
21163 -- pragma on subprogram declaration
21165 -- * Globals - Capture of global references must occur after full
21168 -- * Instance - The annotation is instantiated automatically when
21169 -- the related generic subprogram [body] is instantiated except for
21170 -- the "pragma on subprogram declaration" case. In that scenario
21171 -- the annotation must instantiate itself.
21174 | Pragma_Post_Class
21175 | Pragma_Postcondition
21177 Analyze_Pre_Post_Condition
;
21179 --------------------------------
21180 -- Pre/Pre_Class/Precondition --
21181 --------------------------------
21183 -- pragma Pre (Boolean_EXPRESSION);
21184 -- pragma Pre_Class (Boolean_EXPRESSION);
21185 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21186 -- [,[Message =>] String_EXPRESSION]);
21188 -- Characteristics:
21190 -- * Analysis - The annotation undergoes initial checks to verify
21191 -- the legal placement and context. Secondary checks preanalyze the
21194 -- Analyze_Pre_Post_Condition_In_Decl_Part
21196 -- * Expansion - The annotation is expanded during the expansion of
21197 -- the related subprogram [body] contract as performed in:
21199 -- Expand_Subprogram_Contract
21201 -- * Template - The annotation utilizes the generic template of the
21202 -- related subprogram [body] when it is:
21204 -- aspect on subprogram declaration
21205 -- aspect on stand-alone subprogram body
21206 -- pragma on stand-alone subprogram body
21208 -- The annotation must prepare its own template when it is:
21210 -- pragma on subprogram declaration
21212 -- * Globals - Capture of global references must occur after full
21215 -- * Instance - The annotation is instantiated automatically when
21216 -- the related generic subprogram [body] is instantiated except for
21217 -- the "pragma on subprogram declaration" case. In that scenario
21218 -- the annotation must instantiate itself.
21222 | Pragma_Precondition
21224 Analyze_Pre_Post_Condition
;
21230 -- pragma Predicate
21231 -- ([Entity =>] type_LOCAL_NAME,
21232 -- [Check =>] boolean_EXPRESSION);
21234 when Pragma_Predicate
=> Predicate
: declare
21241 Check_Arg_Count
(2);
21242 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21243 Check_Optional_Identifier
(Arg2
, Name_Check
);
21245 Check_Arg_Is_Local_Name
(Arg1
);
21247 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21248 Find_Type
(Type_Id
);
21249 Typ
:= Entity
(Type_Id
);
21251 if Typ
= Any_Type
then
21255 -- A pragma that applies to a Ghost entity becomes Ghost for the
21256 -- purposes of legality checks and removal of ignored Ghost code.
21258 Mark_Ghost_Pragma
(N
, Typ
);
21260 -- The remaining processing is simply to link the pragma on to
21261 -- the rep item chain, for processing when the type is frozen.
21262 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21263 -- mark the type as having predicates.
21265 -- If the current policy for predicate checking is Ignore mark the
21266 -- subtype accordingly. In the case of predicates we consider them
21267 -- enabled unless Ignore is specified (either directly or with a
21268 -- general Assertion_Policy pragma) to preserve existing warnings.
21270 Set_Has_Predicates
(Typ
);
21272 -- Indicate that the pragma must be processed at the point the
21273 -- type is frozen, as is done for the corresponding aspect.
21275 Set_Has_Delayed_Aspects
(Typ
);
21276 Set_Has_Delayed_Freeze
(Typ
);
21278 Set_Predicates_Ignored
(Typ
,
21279 Present
(Check_Policy_List
)
21281 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
21282 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21285 -----------------------
21286 -- Predicate_Failure --
21287 -----------------------
21289 -- pragma Predicate_Failure
21290 -- ([Entity =>] type_LOCAL_NAME,
21291 -- [Message =>] string_EXPRESSION);
21293 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
21300 Check_Arg_Count
(2);
21301 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21302 Check_Optional_Identifier
(Arg2
, Name_Message
);
21304 Check_Arg_Is_Local_Name
(Arg1
);
21306 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21307 Find_Type
(Type_Id
);
21308 Typ
:= Entity
(Type_Id
);
21310 if Typ
= Any_Type
then
21314 -- A pragma that applies to a Ghost entity becomes Ghost for the
21315 -- purposes of legality checks and removal of ignored Ghost code.
21317 Mark_Ghost_Pragma
(N
, Typ
);
21319 -- The remaining processing is simply to link the pragma on to
21320 -- the rep item chain, for processing when the type is frozen.
21321 -- This is accomplished by a call to Rep_Item_Too_Late.
21323 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21324 end Predicate_Failure
;
21330 -- pragma Preelaborate [(library_unit_NAME)];
21332 -- Set the flag Is_Preelaborated of program unit name entity
21334 when Pragma_Preelaborate
=> Preelaborate
: declare
21335 Pa
: constant Node_Id
:= Parent
(N
);
21336 Pk
: constant Node_Kind
:= Nkind
(Pa
);
21340 Check_Ada_83_Warning
;
21341 Check_Valid_Library_Unit_Pragma
;
21343 if Nkind
(N
) = N_Null_Statement
then
21347 Ent
:= Find_Lib_Unit_Name
;
21349 -- A pragma that applies to a Ghost entity becomes Ghost for the
21350 -- purposes of legality checks and removal of ignored Ghost code.
21352 Mark_Ghost_Pragma
(N
, Ent
);
21353 Check_Duplicate_Pragma
(Ent
);
21355 -- This filters out pragmas inside generic parents that show up
21356 -- inside instantiations. Pragmas that come from aspects in the
21357 -- unit are not ignored.
21359 if Present
(Ent
) then
21360 if Pk
= N_Package_Specification
21361 and then Present
(Generic_Parent
(Pa
))
21362 and then not From_Aspect_Specification
(N
)
21367 if not Debug_Flag_U
then
21368 Set_Is_Preelaborated
(Ent
);
21370 if Legacy_Elaboration_Checks
then
21371 Set_Suppress_Elaboration_Warnings
(Ent
);
21378 -------------------------------
21379 -- Prefix_Exception_Messages --
21380 -------------------------------
21382 -- pragma Prefix_Exception_Messages;
21384 when Pragma_Prefix_Exception_Messages
=>
21386 Check_Valid_Configuration_Pragma
;
21387 Check_Arg_Count
(0);
21388 Prefix_Exception_Messages
:= True;
21394 -- pragma Priority (EXPRESSION);
21396 when Pragma_Priority
=> Priority
: declare
21397 P
: constant Node_Id
:= Parent
(N
);
21402 Check_No_Identifiers
;
21403 Check_Arg_Count
(1);
21407 if Nkind
(P
) = N_Subprogram_Body
then
21408 Check_In_Main_Program
;
21410 Ent
:= Defining_Unit_Name
(Specification
(P
));
21412 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
21413 Ent
:= Defining_Identifier
(Ent
);
21416 Arg
:= Get_Pragma_Arg
(Arg1
);
21417 Analyze_And_Resolve
(Arg
, Standard_Integer
);
21421 if not Is_OK_Static_Expression
(Arg
) then
21422 Flag_Non_Static_Expr
21423 ("main subprogram priority is not static!", Arg
);
21426 -- If constraint error, then we already signalled an error
21428 elsif Raises_Constraint_Error
(Arg
) then
21431 -- Otherwise check in range except if Relaxed_RM_Semantics
21432 -- where we ignore the value if out of range.
21435 if not Relaxed_RM_Semantics
21436 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
21439 ("main subprogram priority is out of range", Arg1
);
21442 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
21446 -- Load an arbitrary entity from System.Tasking.Stages or
21447 -- System.Tasking.Restricted.Stages (depending on the
21448 -- supported profile) to make sure that one of these packages
21449 -- is implicitly with'ed, since we need to have the tasking
21450 -- run time active for the pragma Priority to have any effect.
21451 -- Previously we with'ed the package System.Tasking, but this
21452 -- package does not trigger the required initialization of the
21453 -- run-time library.
21456 Discard
: Entity_Id
;
21457 pragma Warnings
(Off
, Discard
);
21459 if Restricted_Profile
then
21460 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
21462 Discard
:= RTE
(RE_Activate_Tasks
);
21466 -- Task or Protected, must be of type Integer
21468 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
21469 Arg
:= Get_Pragma_Arg
(Arg1
);
21470 Ent
:= Defining_Identifier
(Parent
(P
));
21472 -- The expression must be analyzed in the special manner
21473 -- described in "Handling of Default and Per-Object
21474 -- Expressions" in sem.ads.
21476 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
21478 if not Is_OK_Static_Expression
(Arg
) then
21479 Check_Restriction
(Static_Priorities
, Arg
);
21482 -- Anything else is incorrect
21488 -- Check duplicate pragma before we chain the pragma in the Rep
21489 -- Item chain of Ent.
21491 Check_Duplicate_Pragma
(Ent
);
21492 Record_Rep_Item
(Ent
, N
);
21495 -----------------------------------
21496 -- Priority_Specific_Dispatching --
21497 -----------------------------------
21499 -- pragma Priority_Specific_Dispatching (
21500 -- policy_IDENTIFIER,
21501 -- first_priority_EXPRESSION,
21502 -- last_priority_EXPRESSION);
21504 when Pragma_Priority_Specific_Dispatching
=>
21505 Priority_Specific_Dispatching
: declare
21506 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
21507 -- This is the entity System.Any_Priority;
21510 Lower_Bound
: Node_Id
;
21511 Upper_Bound
: Node_Id
;
21517 Check_Arg_Count
(3);
21518 Check_No_Identifiers
;
21519 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21520 Check_Valid_Configuration_Pragma
;
21521 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21522 DP
:= Fold_Upper
(Name_Buffer
(1));
21524 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
21525 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
21526 Lower_Val
:= Expr_Value
(Lower_Bound
);
21528 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
21529 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
21530 Upper_Val
:= Expr_Value
(Upper_Bound
);
21532 -- It is not allowed to use Task_Dispatching_Policy and
21533 -- Priority_Specific_Dispatching in the same partition.
21535 if Task_Dispatching_Policy
/= ' ' then
21536 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21538 ("pragma% incompatible with Task_Dispatching_Policy#");
21540 -- Check lower bound in range
21542 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21544 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21547 ("first_priority is out of range", Arg2
);
21549 -- Check upper bound in range
21551 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21553 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21556 ("last_priority is out of range", Arg3
);
21558 -- Check that the priority range is valid
21560 elsif Lower_Val
> Upper_Val
then
21562 ("last_priority_expression must be greater than or equal to "
21563 & "first_priority_expression");
21565 -- Store the new policy, but always preserve System_Location since
21566 -- we like the error message with the run-time name.
21569 -- Check overlapping in the priority ranges specified in other
21570 -- Priority_Specific_Dispatching pragmas within the same
21571 -- partition. We can only check those we know about.
21574 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
21576 if Specific_Dispatching
.Table
(J
).First_Priority
in
21577 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21578 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
21579 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21582 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
21584 ("priority range overlaps with "
21585 & "Priority_Specific_Dispatching#");
21589 -- The use of Priority_Specific_Dispatching is incompatible
21590 -- with Task_Dispatching_Policy.
21592 if Task_Dispatching_Policy
/= ' ' then
21593 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21595 ("Priority_Specific_Dispatching incompatible "
21596 & "with Task_Dispatching_Policy#");
21599 -- The use of Priority_Specific_Dispatching forces ceiling
21602 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
21603 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
21605 ("Priority_Specific_Dispatching incompatible "
21606 & "with Locking_Policy#");
21608 -- Set the Ceiling_Locking policy, but preserve System_Location
21609 -- since we like the error message with the run time name.
21612 Locking_Policy
:= 'C';
21614 if Locking_Policy_Sloc
/= System_Location
then
21615 Locking_Policy_Sloc
:= Loc
;
21619 -- Add entry in the table
21621 Specific_Dispatching
.Append
21622 ((Dispatching_Policy
=> DP
,
21623 First_Priority
=> UI_To_Int
(Lower_Val
),
21624 Last_Priority
=> UI_To_Int
(Upper_Val
),
21625 Pragma_Loc
=> Loc
));
21627 end Priority_Specific_Dispatching
;
21633 -- pragma Profile (profile_IDENTIFIER);
21635 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21637 when Pragma_Profile
=>
21639 Check_Arg_Count
(1);
21640 Check_Valid_Configuration_Pragma
;
21641 Check_No_Identifiers
;
21644 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21647 if Chars
(Argx
) = Name_Ravenscar
then
21648 Set_Ravenscar_Profile
(Ravenscar
, N
);
21650 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
21651 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
21653 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
21654 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
21656 elsif Chars
(Argx
) = Name_Restricted
then
21657 Set_Profile_Restrictions
21659 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21661 elsif Chars
(Argx
) = Name_Rational
then
21662 Set_Rational_Profile
;
21664 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21665 Set_Profile_Restrictions
21666 (No_Implementation_Extensions
,
21667 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21670 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21674 ----------------------
21675 -- Profile_Warnings --
21676 ----------------------
21678 -- pragma Profile_Warnings (profile_IDENTIFIER);
21680 -- profile_IDENTIFIER => Restricted | Ravenscar
21682 when Pragma_Profile_Warnings
=>
21684 Check_Arg_Count
(1);
21685 Check_Valid_Configuration_Pragma
;
21686 Check_No_Identifiers
;
21689 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21692 if Chars
(Argx
) = Name_Ravenscar
then
21693 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
21695 elsif Chars
(Argx
) = Name_Restricted
then
21696 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
21698 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21699 Set_Profile_Restrictions
21700 (No_Implementation_Extensions
, N
, Warn
=> True);
21703 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21707 --------------------------
21708 -- Propagate_Exceptions --
21709 --------------------------
21711 -- pragma Propagate_Exceptions;
21713 -- Note: this pragma is obsolete and has no effect
21715 when Pragma_Propagate_Exceptions
=>
21717 Check_Arg_Count
(0);
21719 if Warn_On_Obsolescent_Feature
then
21721 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21722 "and has no effect?j?", N
);
21725 -----------------------------
21726 -- Provide_Shift_Operators --
21727 -----------------------------
21729 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21731 when Pragma_Provide_Shift_Operators
=>
21732 Provide_Shift_Operators
: declare
21735 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
21736 -- Insert declaration and pragma Instrinsic for named shift op
21738 ----------------------------
21739 -- Declare_Shift_Operator --
21740 ----------------------------
21742 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
21748 Make_Subprogram_Declaration
(Loc
,
21749 Make_Function_Specification
(Loc
,
21750 Defining_Unit_Name
=>
21751 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
21753 Result_Definition
=>
21754 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
21756 Parameter_Specifications
=> New_List
(
21757 Make_Parameter_Specification
(Loc
,
21758 Defining_Identifier
=>
21759 Make_Defining_Identifier
(Loc
, Name_Value
),
21761 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
21763 Make_Parameter_Specification
(Loc
,
21764 Defining_Identifier
=>
21765 Make_Defining_Identifier
(Loc
, Name_Amount
),
21767 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
21771 Chars
=> Name_Import
,
21772 Pragma_Argument_Associations
=> New_List
(
21773 Make_Pragma_Argument_Association
(Loc
,
21774 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
21775 Make_Pragma_Argument_Association
(Loc
,
21776 Expression
=> Make_Identifier
(Loc
, Nam
))));
21778 Insert_After
(N
, Import
);
21779 Insert_After
(N
, Func
);
21780 end Declare_Shift_Operator
;
21782 -- Start of processing for Provide_Shift_Operators
21786 Check_Arg_Count
(1);
21787 Check_Arg_Is_Local_Name
(Arg1
);
21789 Arg1
:= Get_Pragma_Arg
(Arg1
);
21791 -- We must have an entity name
21793 if not Is_Entity_Name
(Arg1
) then
21795 ("pragma % must apply to integer first subtype", Arg1
);
21798 -- If no Entity, means there was a prior error so ignore
21800 if Present
(Entity
(Arg1
)) then
21801 Ent
:= Entity
(Arg1
);
21803 -- Apply error checks
21805 if not Is_First_Subtype
(Ent
) then
21807 ("cannot apply pragma %",
21808 "\& is not a first subtype",
21811 elsif not Is_Integer_Type
(Ent
) then
21813 ("cannot apply pragma %",
21814 "\& is not an integer type",
21817 elsif Has_Shift_Operator
(Ent
) then
21819 ("cannot apply pragma %",
21820 "\& already has declared shift operators",
21823 elsif Is_Frozen
(Ent
) then
21825 ("pragma % appears too late",
21826 "\& is already frozen",
21830 -- Now declare the operators. We do this during analysis rather
21831 -- than expansion, since we want the operators available if we
21832 -- are operating in -gnatc or ASIS mode.
21834 Declare_Shift_Operator
(Name_Rotate_Left
);
21835 Declare_Shift_Operator
(Name_Rotate_Right
);
21836 Declare_Shift_Operator
(Name_Shift_Left
);
21837 Declare_Shift_Operator
(Name_Shift_Right
);
21838 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
21840 end Provide_Shift_Operators
;
21846 -- pragma Psect_Object (
21847 -- [Internal =>] LOCAL_NAME,
21848 -- [, [External =>] EXTERNAL_SYMBOL]
21849 -- [, [Size =>] EXTERNAL_SYMBOL]);
21851 when Pragma_Common_Object
21852 | Pragma_Psect_Object
21854 Psect_Object
: declare
21855 Args
: Args_List
(1 .. 3);
21856 Names
: constant Name_List
(1 .. 3) := (
21861 Internal
: Node_Id
renames Args
(1);
21862 External
: Node_Id
renames Args
(2);
21863 Size
: Node_Id
renames Args
(3);
21865 Def_Id
: Entity_Id
;
21867 procedure Check_Arg
(Arg
: Node_Id
);
21868 -- Checks that argument is either a string literal or an
21869 -- identifier, and posts error message if not.
21875 procedure Check_Arg
(Arg
: Node_Id
) is
21877 if not Nkind_In
(Original_Node
(Arg
),
21882 ("inappropriate argument for pragma %", Arg
);
21886 -- Start of processing for Common_Object/Psect_Object
21890 Gather_Associations
(Names
, Args
);
21891 Process_Extended_Import_Export_Internal_Arg
(Internal
);
21893 Def_Id
:= Entity
(Internal
);
21895 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
21897 ("pragma% must designate an object", Internal
);
21900 Check_Arg
(Internal
);
21902 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
21904 ("cannot use pragma% for imported/exported object",
21908 if Is_Concurrent_Type
(Etype
(Internal
)) then
21910 ("cannot specify pragma % for task/protected object",
21914 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
21916 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
21918 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
21921 if Ekind
(Def_Id
) = E_Constant
then
21923 ("cannot specify pragma % for a constant", Internal
);
21926 if Is_Record_Type
(Etype
(Internal
)) then
21932 Ent
:= First_Entity
(Etype
(Internal
));
21933 while Present
(Ent
) loop
21934 Decl
:= Declaration_Node
(Ent
);
21936 if Ekind
(Ent
) = E_Component
21937 and then Nkind
(Decl
) = N_Component_Declaration
21938 and then Present
(Expression
(Decl
))
21939 and then Warn_On_Export_Import
21942 ("?x?object for pragma % has defaults", Internal
);
21952 if Present
(Size
) then
21956 if Present
(External
) then
21957 Check_Arg_Is_External_Name
(External
);
21960 -- If all error tests pass, link pragma on to the rep item chain
21962 Record_Rep_Item
(Def_Id
, N
);
21969 -- pragma Pure [(library_unit_NAME)];
21971 when Pragma_Pure
=> Pure
: declare
21975 Check_Ada_83_Warning
;
21977 -- If the pragma comes from a subprogram instantiation, nothing to
21978 -- check, this can happen at any level of nesting.
21980 if Is_Wrapper_Package
(Current_Scope
) then
21983 Check_Valid_Library_Unit_Pragma
;
21986 if Nkind
(N
) = N_Null_Statement
then
21990 Ent
:= Find_Lib_Unit_Name
;
21992 -- A pragma that applies to a Ghost entity becomes Ghost for the
21993 -- purposes of legality checks and removal of ignored Ghost code.
21995 Mark_Ghost_Pragma
(N
, Ent
);
21997 if not Debug_Flag_U
then
21999 Set_Has_Pragma_Pure
(Ent
);
22001 if Legacy_Elaboration_Checks
then
22002 Set_Suppress_Elaboration_Warnings
(Ent
);
22007 -------------------
22008 -- Pure_Function --
22009 -------------------
22011 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22013 when Pragma_Pure_Function
=> Pure_Function
: declare
22014 Def_Id
: Entity_Id
;
22017 Effective
: Boolean := False;
22018 Orig_Def
: Entity_Id
;
22019 Same_Decl
: Boolean := False;
22023 Check_Arg_Count
(1);
22024 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22025 Check_Arg_Is_Local_Name
(Arg1
);
22026 E_Id
:= Get_Pragma_Arg
(Arg1
);
22028 if Etype
(E_Id
) = Any_Type
then
22032 -- Loop through homonyms (overloadings) of referenced entity
22034 E
:= Entity
(E_Id
);
22036 -- A pragma that applies to a Ghost entity becomes Ghost for the
22037 -- purposes of legality checks and removal of ignored Ghost code.
22039 Mark_Ghost_Pragma
(N
, E
);
22041 if Present
(E
) then
22043 Def_Id
:= Get_Base_Subprogram
(E
);
22045 if not Ekind_In
(Def_Id
, E_Function
,
22046 E_Generic_Function
,
22050 ("pragma% requires a function name", Arg1
);
22053 -- When we have a generic function we must jump up a level
22054 -- to the declaration of the wrapper package itself.
22056 Orig_Def
:= Def_Id
;
22058 if Is_Generic_Instance
(Def_Id
) then
22059 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
22060 Orig_Def
:= Parent
(Orig_Def
);
22064 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
22066 Set_Is_Pure
(Def_Id
);
22068 if not Has_Pragma_Pure_Function
(Def_Id
) then
22069 Set_Has_Pragma_Pure_Function
(Def_Id
);
22074 exit when From_Aspect_Specification
(N
);
22076 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
22080 and then Warn_On_Redundant_Constructs
22083 ("pragma Pure_Function on& is redundant?r?",
22086 elsif not Same_Decl
then
22088 ("pragma% argument must be in same declarative part",
22094 --------------------
22095 -- Queuing_Policy --
22096 --------------------
22098 -- pragma Queuing_Policy (policy_IDENTIFIER);
22100 when Pragma_Queuing_Policy
=> declare
22104 Check_Ada_83_Warning
;
22105 Check_Arg_Count
(1);
22106 Check_No_Identifiers
;
22107 Check_Arg_Is_Queuing_Policy
(Arg1
);
22108 Check_Valid_Configuration_Pragma
;
22109 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22110 QP
:= Fold_Upper
(Name_Buffer
(1));
22112 if Queuing_Policy
/= ' '
22113 and then Queuing_Policy
/= QP
22115 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
22116 Error_Pragma
("queuing policy incompatible with policy#");
22118 -- Set new policy, but always preserve System_Location since we
22119 -- like the error message with the run time name.
22122 Queuing_Policy
:= QP
;
22124 if Queuing_Policy_Sloc
/= System_Location
then
22125 Queuing_Policy_Sloc
:= Loc
;
22134 -- pragma Rational, for compatibility with foreign compiler
22136 when Pragma_Rational
=>
22137 Set_Rational_Profile
;
22139 ---------------------
22140 -- Refined_Depends --
22141 ---------------------
22143 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22145 -- DEPENDENCY_RELATION ::=
22147 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22149 -- DEPENDENCY_CLAUSE ::=
22150 -- OUTPUT_LIST =>[+] INPUT_LIST
22151 -- | NULL_DEPENDENCY_CLAUSE
22153 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22155 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22157 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22159 -- OUTPUT ::= NAME | FUNCTION_RESULT
22162 -- where FUNCTION_RESULT is a function Result attribute_reference
22164 -- Characteristics:
22166 -- * Analysis - The annotation undergoes initial checks to verify
22167 -- the legal placement and context. Secondary checks fully analyze
22168 -- the dependency clauses/global list in:
22170 -- Analyze_Refined_Depends_In_Decl_Part
22172 -- * Expansion - None.
22174 -- * Template - The annotation utilizes the generic template of the
22175 -- related subprogram body.
22177 -- * Globals - Capture of global references must occur after full
22180 -- * Instance - The annotation is instantiated automatically when
22181 -- the related generic subprogram body is instantiated.
22183 when Pragma_Refined_Depends
=> Refined_Depends
: declare
22184 Body_Id
: Entity_Id
;
22186 Spec_Id
: Entity_Id
;
22189 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22193 -- Chain the pragma on the contract for further processing by
22194 -- Analyze_Refined_Depends_In_Decl_Part.
22196 Add_Contract_Item
(N
, Body_Id
);
22198 -- The legality checks of pragmas Refined_Depends and
22199 -- Refined_Global are affected by the SPARK mode in effect and
22200 -- the volatility of the context. In addition these two pragmas
22201 -- are subject to an inherent order:
22203 -- 1) Refined_Global
22204 -- 2) Refined_Depends
22206 -- Analyze all these pragmas in the order outlined above
22208 Analyze_If_Present
(Pragma_SPARK_Mode
);
22209 Analyze_If_Present
(Pragma_Volatile_Function
);
22210 Analyze_If_Present
(Pragma_Refined_Global
);
22211 Analyze_Refined_Depends_In_Decl_Part
(N
);
22213 end Refined_Depends
;
22215 --------------------
22216 -- Refined_Global --
22217 --------------------
22219 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22221 -- GLOBAL_SPECIFICATION ::=
22224 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22226 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22228 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22229 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22230 -- GLOBAL_ITEM ::= NAME
22232 -- Characteristics:
22234 -- * Analysis - The annotation undergoes initial checks to verify
22235 -- the legal placement and context. Secondary checks fully analyze
22236 -- the dependency clauses/global list in:
22238 -- Analyze_Refined_Global_In_Decl_Part
22240 -- * Expansion - None.
22242 -- * Template - The annotation utilizes the generic template of the
22243 -- related subprogram body.
22245 -- * Globals - Capture of global references must occur after full
22248 -- * Instance - The annotation is instantiated automatically when
22249 -- the related generic subprogram body is instantiated.
22251 when Pragma_Refined_Global
=> Refined_Global
: declare
22252 Body_Id
: Entity_Id
;
22254 Spec_Id
: Entity_Id
;
22257 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22261 -- Chain the pragma on the contract for further processing by
22262 -- Analyze_Refined_Global_In_Decl_Part.
22264 Add_Contract_Item
(N
, Body_Id
);
22266 -- The legality checks of pragmas Refined_Depends and
22267 -- Refined_Global are affected by the SPARK mode in effect and
22268 -- the volatility of the context. In addition these two pragmas
22269 -- are subject to an inherent order:
22271 -- 1) Refined_Global
22272 -- 2) Refined_Depends
22274 -- Analyze all these pragmas in the order outlined above
22276 Analyze_If_Present
(Pragma_SPARK_Mode
);
22277 Analyze_If_Present
(Pragma_Volatile_Function
);
22278 Analyze_Refined_Global_In_Decl_Part
(N
);
22279 Analyze_If_Present
(Pragma_Refined_Depends
);
22281 end Refined_Global
;
22287 -- pragma Refined_Post (boolean_EXPRESSION);
22289 -- Characteristics:
22291 -- * Analysis - The annotation is fully analyzed immediately upon
22292 -- elaboration as it cannot forward reference entities.
22294 -- * Expansion - The annotation is expanded during the expansion of
22295 -- the related subprogram body contract as performed in:
22297 -- Expand_Subprogram_Contract
22299 -- * Template - The annotation utilizes the generic template of the
22300 -- related subprogram body.
22302 -- * Globals - Capture of global references must occur after full
22305 -- * Instance - The annotation is instantiated automatically when
22306 -- the related generic subprogram body is instantiated.
22308 when Pragma_Refined_Post
=> Refined_Post
: declare
22309 Body_Id
: Entity_Id
;
22311 Spec_Id
: Entity_Id
;
22314 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22316 -- Fully analyze the pragma when it appears inside a subprogram
22317 -- body because it cannot benefit from forward references.
22321 -- Chain the pragma on the contract for completeness
22323 Add_Contract_Item
(N
, Body_Id
);
22325 -- The legality checks of pragma Refined_Post are affected by
22326 -- the SPARK mode in effect and the volatility of the context.
22327 -- Analyze all pragmas in a specific order.
22329 Analyze_If_Present
(Pragma_SPARK_Mode
);
22330 Analyze_If_Present
(Pragma_Volatile_Function
);
22331 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
22333 -- Currently it is not possible to inline pre/postconditions on
22334 -- a subprogram subject to pragma Inline_Always.
22336 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
22340 -------------------
22341 -- Refined_State --
22342 -------------------
22344 -- pragma Refined_State (REFINEMENT_LIST);
22346 -- REFINEMENT_LIST ::=
22347 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22349 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22351 -- CONSTITUENT_LIST ::=
22354 -- | (CONSTITUENT {, CONSTITUENT})
22356 -- CONSTITUENT ::= object_NAME | state_NAME
22358 -- Characteristics:
22360 -- * Analysis - The annotation undergoes initial checks to verify
22361 -- the legal placement and context. Secondary checks preanalyze the
22362 -- refinement clauses in:
22364 -- Analyze_Refined_State_In_Decl_Part
22366 -- * Expansion - None.
22368 -- * Template - The annotation utilizes the template of the related
22371 -- * Globals - Capture of global references must occur after full
22374 -- * Instance - The annotation is instantiated automatically when
22375 -- the related generic package body is instantiated.
22377 when Pragma_Refined_State
=> Refined_State
: declare
22378 Pack_Decl
: Node_Id
;
22379 Spec_Id
: Entity_Id
;
22383 Check_No_Identifiers
;
22384 Check_Arg_Count
(1);
22386 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
22388 if Nkind
(Pack_Decl
) /= N_Package_Body
then
22393 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
22395 -- A pragma that applies to a Ghost entity becomes Ghost for the
22396 -- purposes of legality checks and removal of ignored Ghost code.
22398 Mark_Ghost_Pragma
(N
, Spec_Id
);
22400 -- Chain the pragma on the contract for further processing by
22401 -- Analyze_Refined_State_In_Decl_Part.
22403 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
22405 -- The legality checks of pragma Refined_State are affected by the
22406 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22408 Analyze_If_Present
(Pragma_SPARK_Mode
);
22410 -- State refinement is allowed only when the corresponding package
22411 -- declaration has non-null pragma Abstract_State. Refinement not
22412 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22414 if SPARK_Mode
/= Off
22416 (No
(Abstract_States
(Spec_Id
))
22417 or else Has_Null_Abstract_State
(Spec_Id
))
22420 ("useless refinement, package & does not define abstract "
22421 & "states", N
, Spec_Id
);
22426 -----------------------
22427 -- Relative_Deadline --
22428 -----------------------
22430 -- pragma Relative_Deadline (time_span_EXPRESSION);
22432 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
22433 P
: constant Node_Id
:= Parent
(N
);
22438 Check_No_Identifiers
;
22439 Check_Arg_Count
(1);
22441 Arg
:= Get_Pragma_Arg
(Arg1
);
22443 -- The expression must be analyzed in the special manner described
22444 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22446 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
22450 if Nkind
(P
) = N_Subprogram_Body
then
22451 Check_In_Main_Program
;
22453 -- Only Task and subprogram cases allowed
22455 elsif Nkind
(P
) /= N_Task_Definition
then
22459 -- Check duplicate pragma before we set the corresponding flag
22461 if Has_Relative_Deadline_Pragma
(P
) then
22462 Error_Pragma
("duplicate pragma% not allowed");
22465 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22466 -- Relative_Deadline pragma node cannot be inserted in the Rep
22467 -- Item chain of Ent since it is rewritten by the expander as a
22468 -- procedure call statement that will break the chain.
22470 Set_Has_Relative_Deadline_Pragma
(P
);
22471 end Relative_Deadline
;
22473 ------------------------
22474 -- Remote_Access_Type --
22475 ------------------------
22477 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22479 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
22484 Check_Arg_Count
(1);
22485 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22486 Check_Arg_Is_Local_Name
(Arg1
);
22488 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
22490 -- A pragma that applies to a Ghost entity becomes Ghost for the
22491 -- purposes of legality checks and removal of ignored Ghost code.
22493 Mark_Ghost_Pragma
(N
, E
);
22495 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
22496 and then Ekind
(E
) = E_General_Access_Type
22497 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
22498 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
22500 and then Is_Valid_Remote_Object_Type
22501 (Root_Type
(Directly_Designated_Type
(E
)))
22503 Set_Is_Remote_Types
(E
);
22507 ("pragma% applies only to formal access-to-class-wide types",
22510 end Remote_Access_Type
;
22512 ---------------------------
22513 -- Remote_Call_Interface --
22514 ---------------------------
22516 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22518 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
22519 Cunit_Node
: Node_Id
;
22520 Cunit_Ent
: Entity_Id
;
22524 Check_Ada_83_Warning
;
22525 Check_Valid_Library_Unit_Pragma
;
22527 if Nkind
(N
) = N_Null_Statement
then
22531 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22532 K
:= Nkind
(Unit
(Cunit_Node
));
22533 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22535 -- A pragma that applies to a Ghost entity becomes Ghost for the
22536 -- purposes of legality checks and removal of ignored Ghost code.
22538 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22540 if K
= N_Package_Declaration
22541 or else K
= N_Generic_Package_Declaration
22542 or else K
= N_Subprogram_Declaration
22543 or else K
= N_Generic_Subprogram_Declaration
22544 or else (K
= N_Subprogram_Body
22545 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
22550 "pragma% must apply to package or subprogram declaration");
22553 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
22554 end Remote_Call_Interface
;
22560 -- pragma Remote_Types [(library_unit_NAME)];
22562 when Pragma_Remote_Types
=> Remote_Types
: declare
22563 Cunit_Node
: Node_Id
;
22564 Cunit_Ent
: Entity_Id
;
22567 Check_Ada_83_Warning
;
22568 Check_Valid_Library_Unit_Pragma
;
22570 if Nkind
(N
) = N_Null_Statement
then
22574 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22575 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22577 -- A pragma that applies to a Ghost entity becomes Ghost for the
22578 -- purposes of legality checks and removal of ignored Ghost code.
22580 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22582 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22583 N_Generic_Package_Declaration
)
22586 ("pragma% can only apply to a package declaration");
22589 Set_Is_Remote_Types
(Cunit_Ent
);
22596 -- pragma Ravenscar;
22598 when Pragma_Ravenscar
=>
22600 Check_Arg_Count
(0);
22601 Check_Valid_Configuration_Pragma
;
22602 Set_Ravenscar_Profile
(Ravenscar
, N
);
22604 if Warn_On_Obsolescent_Feature
then
22606 ("pragma Ravenscar is an obsolescent feature?j?", N
);
22608 ("|use pragma Profile (Ravenscar) instead?j?", N
);
22611 -------------------------
22612 -- Restricted_Run_Time --
22613 -------------------------
22615 -- pragma Restricted_Run_Time;
22617 when Pragma_Restricted_Run_Time
=>
22619 Check_Arg_Count
(0);
22620 Check_Valid_Configuration_Pragma
;
22621 Set_Profile_Restrictions
22622 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
22624 if Warn_On_Obsolescent_Feature
then
22626 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22629 ("|use pragma Profile (Restricted) instead?j?", N
);
22636 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22639 -- restriction_IDENTIFIER
22640 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22642 when Pragma_Restrictions
=>
22643 Process_Restrictions_Or_Restriction_Warnings
22644 (Warn
=> Treat_Restrictions_As_Warnings
);
22646 --------------------------
22647 -- Restriction_Warnings --
22648 --------------------------
22650 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22653 -- restriction_IDENTIFIER
22654 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22656 when Pragma_Restriction_Warnings
=>
22658 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
22664 -- pragma Reviewable;
22666 when Pragma_Reviewable
=>
22667 Check_Ada_83_Warning
;
22668 Check_Arg_Count
(0);
22670 -- Call dummy debugging function rv. This is done to assist front
22671 -- end debugging. By placing a Reviewable pragma in the source
22672 -- program, a breakpoint on rv catches this place in the source,
22673 -- allowing convenient stepping to the point of interest.
22677 --------------------------
22678 -- Secondary_Stack_Size --
22679 --------------------------
22681 -- pragma Secondary_Stack_Size (EXPRESSION);
22683 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
22684 P
: constant Node_Id
:= Parent
(N
);
22690 Check_No_Identifiers
;
22691 Check_Arg_Count
(1);
22693 if Nkind
(P
) = N_Task_Definition
then
22694 Arg
:= Get_Pragma_Arg
(Arg1
);
22695 Ent
:= Defining_Identifier
(Parent
(P
));
22697 -- The expression must be analyzed in the special manner
22698 -- described in "Handling of Default Expressions" in sem.ads.
22700 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22702 -- The pragma cannot appear if the No_Secondary_Stack
22703 -- restriction is in effect.
22705 Check_Restriction
(No_Secondary_Stack
, Arg
);
22707 -- Anything else is incorrect
22713 -- Check duplicate pragma before we chain the pragma in the Rep
22714 -- Item chain of Ent.
22716 Check_Duplicate_Pragma
(Ent
);
22717 Record_Rep_Item
(Ent
, N
);
22718 end Secondary_Stack_Size
;
22720 --------------------------
22721 -- Short_Circuit_And_Or --
22722 --------------------------
22724 -- pragma Short_Circuit_And_Or;
22726 when Pragma_Short_Circuit_And_Or
=>
22728 Check_Arg_Count
(0);
22729 Check_Valid_Configuration_Pragma
;
22730 Short_Circuit_And_Or
:= True;
22732 -------------------
22733 -- Share_Generic --
22734 -------------------
22736 -- pragma Share_Generic (GNAME {, GNAME});
22738 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22740 when Pragma_Share_Generic
=>
22742 Process_Generic_List
;
22748 -- pragma Shared (LOCAL_NAME);
22750 when Pragma_Shared
=>
22752 Process_Atomic_Independent_Shared_Volatile
;
22754 --------------------
22755 -- Shared_Passive --
22756 --------------------
22758 -- pragma Shared_Passive [(library_unit_NAME)];
22760 -- Set the flag Is_Shared_Passive of program unit name entity
22762 when Pragma_Shared_Passive
=> Shared_Passive
: declare
22763 Cunit_Node
: Node_Id
;
22764 Cunit_Ent
: Entity_Id
;
22767 Check_Ada_83_Warning
;
22768 Check_Valid_Library_Unit_Pragma
;
22770 if Nkind
(N
) = N_Null_Statement
then
22774 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22775 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22777 -- A pragma that applies to a Ghost entity becomes Ghost for the
22778 -- purposes of legality checks and removal of ignored Ghost code.
22780 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22782 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22783 N_Generic_Package_Declaration
)
22786 ("pragma% can only apply to a package declaration");
22789 Set_Is_Shared_Passive
(Cunit_Ent
);
22790 end Shared_Passive
;
22792 -----------------------
22793 -- Short_Descriptors --
22794 -----------------------
22796 -- pragma Short_Descriptors;
22798 -- Recognize and validate, but otherwise ignore
22800 when Pragma_Short_Descriptors
=>
22802 Check_Arg_Count
(0);
22803 Check_Valid_Configuration_Pragma
;
22805 ------------------------------
22806 -- Simple_Storage_Pool_Type --
22807 ------------------------------
22809 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22811 when Pragma_Simple_Storage_Pool_Type
=>
22812 Simple_Storage_Pool_Type
: declare
22818 Check_Arg_Count
(1);
22819 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22821 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22822 Find_Type
(Type_Id
);
22823 Typ
:= Entity
(Type_Id
);
22825 if Typ
= Any_Type
then
22829 -- A pragma that applies to a Ghost entity becomes Ghost for the
22830 -- purposes of legality checks and removal of ignored Ghost code.
22832 Mark_Ghost_Pragma
(N
, Typ
);
22834 -- We require the pragma to apply to a type declared in a package
22835 -- declaration, but not (immediately) within a package body.
22837 if Ekind
(Current_Scope
) /= E_Package
22838 or else In_Package_Body
(Current_Scope
)
22841 ("pragma% can only apply to type declared immediately "
22842 & "within a package declaration");
22845 -- A simple storage pool type must be an immutably limited record
22846 -- or private type. If the pragma is given for a private type,
22847 -- the full type is similarly restricted (which is checked later
22848 -- in Freeze_Entity).
22850 if Is_Record_Type
(Typ
)
22851 and then not Is_Limited_View
(Typ
)
22854 ("pragma% can only apply to explicitly limited record type");
22856 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
22858 ("pragma% can only apply to a private type that is limited");
22860 elsif not Is_Record_Type
(Typ
)
22861 and then not Is_Private_Type
(Typ
)
22864 ("pragma% can only apply to limited record or private type");
22867 Record_Rep_Item
(Typ
, N
);
22868 end Simple_Storage_Pool_Type
;
22870 ----------------------
22871 -- Source_File_Name --
22872 ----------------------
22874 -- There are five forms for this pragma:
22876 -- pragma Source_File_Name (
22877 -- [UNIT_NAME =>] unit_NAME,
22878 -- BODY_FILE_NAME => STRING_LITERAL
22879 -- [, [INDEX =>] INTEGER_LITERAL]);
22881 -- pragma Source_File_Name (
22882 -- [UNIT_NAME =>] unit_NAME,
22883 -- SPEC_FILE_NAME => STRING_LITERAL
22884 -- [, [INDEX =>] INTEGER_LITERAL]);
22886 -- pragma Source_File_Name (
22887 -- BODY_FILE_NAME => STRING_LITERAL
22888 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22889 -- [, CASING => CASING_SPEC]);
22891 -- pragma Source_File_Name (
22892 -- SPEC_FILE_NAME => STRING_LITERAL
22893 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22894 -- [, CASING => CASING_SPEC]);
22896 -- pragma Source_File_Name (
22897 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22898 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22899 -- [, CASING => CASING_SPEC]);
22901 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22903 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22904 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22905 -- only be used when no project file is used, while SFNP can only be
22906 -- used when a project file is used.
22908 -- No processing here. Processing was completed during parsing, since
22909 -- we need to have file names set as early as possible. Units are
22910 -- loaded well before semantic processing starts.
22912 -- The only processing we defer to this point is the check for
22913 -- correct placement.
22915 when Pragma_Source_File_Name
=>
22917 Check_Valid_Configuration_Pragma
;
22919 ------------------------------
22920 -- Source_File_Name_Project --
22921 ------------------------------
22923 -- See Source_File_Name for syntax
22925 -- No processing here. Processing was completed during parsing, since
22926 -- we need to have file names set as early as possible. Units are
22927 -- loaded well before semantic processing starts.
22929 -- The only processing we defer to this point is the check for
22930 -- correct placement.
22932 when Pragma_Source_File_Name_Project
=>
22934 Check_Valid_Configuration_Pragma
;
22936 -- Check that a pragma Source_File_Name_Project is used only in a
22937 -- configuration pragmas file.
22939 -- Pragmas Source_File_Name_Project should only be generated by
22940 -- the Project Manager in configuration pragmas files.
22942 -- This is really an ugly test. It seems to depend on some
22943 -- accidental and undocumented property. At the very least it
22944 -- needs to be documented, but it would be better to have a
22945 -- clean way of testing if we are in a configuration file???
22947 if Present
(Parent
(N
)) then
22949 ("pragma% can only appear in a configuration pragmas file");
22952 ----------------------
22953 -- Source_Reference --
22954 ----------------------
22956 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22958 -- Nothing to do, all processing completed in Par.Prag, since we need
22959 -- the information for possible parser messages that are output.
22961 when Pragma_Source_Reference
=>
22968 -- pragma SPARK_Mode [(On | Off)];
22970 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
22971 Mode_Id
: SPARK_Mode_Type
;
22973 procedure Check_Pragma_Conformance
22974 (Context_Pragma
: Node_Id
;
22975 Entity
: Entity_Id
;
22976 Entity_Pragma
: Node_Id
);
22977 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22978 -- conformance of pragma N depending the following scenarios:
22980 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22981 -- compatible with the pragma Context_Pragma that was inherited
22982 -- from the context:
22983 -- * If the mode of Context_Pragma is ON, then the new mode can
22985 -- * If the mode of Context_Pragma is OFF, then the only allowed
22986 -- new mode is also OFF. Emit error if this is not the case.
22988 -- If Entity is not Empty, verify that pragma N is compatible with
22989 -- pragma Entity_Pragma that belongs to Entity.
22990 -- * If Entity_Pragma is Empty, always issue an error as this
22991 -- corresponds to the case where a previous section of Entity
22992 -- has no SPARK_Mode set.
22993 -- * If the mode of Entity_Pragma is ON, then the new mode can
22995 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22996 -- new mode is also OFF. Emit error if this is not the case.
22998 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
22999 -- Subsidiary to routines Process_xxx. Verify that the related
23000 -- entity E subject to pragma SPARK_Mode is library-level.
23002 procedure Process_Body
(Decl
: Node_Id
);
23003 -- Verify the legality of pragma SPARK_Mode when it appears as the
23004 -- top of the body declarations of entry, package, protected unit,
23005 -- subprogram or task unit body denoted by Decl.
23007 procedure Process_Overloadable
(Decl
: Node_Id
);
23008 -- Verify the legality of pragma SPARK_Mode when it applies to an
23009 -- entry or [generic] subprogram declaration denoted by Decl.
23011 procedure Process_Private_Part
(Decl
: Node_Id
);
23012 -- Verify the legality of pragma SPARK_Mode when it appears at the
23013 -- top of the private declarations of a package spec, protected or
23014 -- task unit declaration denoted by Decl.
23016 procedure Process_Statement_Part
(Decl
: Node_Id
);
23017 -- Verify the legality of pragma SPARK_Mode when it appears at the
23018 -- top of the statement sequence of a package body denoted by node
23021 procedure Process_Visible_Part
(Decl
: Node_Id
);
23022 -- Verify the legality of pragma SPARK_Mode when it appears at the
23023 -- top of the visible declarations of a package spec, protected or
23024 -- task unit declaration denoted by Decl. The routine is also used
23025 -- on protected or task units declared without a definition.
23027 procedure Set_SPARK_Context
;
23028 -- Subsidiary to routines Process_xxx. Set the global variables
23029 -- which represent the mode of the context from pragma N. Ensure
23030 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23032 ------------------------------
23033 -- Check_Pragma_Conformance --
23034 ------------------------------
23036 procedure Check_Pragma_Conformance
23037 (Context_Pragma
: Node_Id
;
23038 Entity
: Entity_Id
;
23039 Entity_Pragma
: Node_Id
)
23041 Err_Id
: Entity_Id
;
23045 -- The current pragma may appear without an argument. If this
23046 -- is the case, associate all error messages with the pragma
23049 if Present
(Arg1
) then
23055 -- The mode of the current pragma is compared against that of
23056 -- an enclosing context.
23058 if Present
(Context_Pragma
) then
23059 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
23061 -- Issue an error if the new mode is less restrictive than
23062 -- that of the context.
23064 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
23065 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23068 ("cannot change SPARK_Mode from Off to On", Err_N
);
23069 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
23070 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
23075 -- The mode of the current pragma is compared against that of
23076 -- an initial package, protected type, subprogram or task type
23079 if Present
(Entity
) then
23081 -- A simple protected or task type is transformed into an
23082 -- anonymous type whose name cannot be used to issue error
23083 -- messages. Recover the original entity of the type.
23085 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
23088 (Original_Node
(Unit_Declaration_Node
(Entity
)));
23093 -- Both the initial declaration and the completion carry
23094 -- SPARK_Mode pragmas.
23096 if Present
(Entity_Pragma
) then
23097 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
23099 -- Issue an error if the new mode is less restrictive
23100 -- than that of the initial declaration.
23102 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
23103 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23105 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23106 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
23108 ("\value Off was set for SPARK_Mode on&#",
23113 -- Otherwise the initial declaration lacks a SPARK_Mode
23114 -- pragma in which case the current pragma is illegal as
23115 -- it cannot "complete".
23118 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23119 Error_Msg_Sloc
:= Sloc
(Err_Id
);
23121 ("\no value was set for SPARK_Mode on&#",
23126 end Check_Pragma_Conformance
;
23128 --------------------------------
23129 -- Check_Library_Level_Entity --
23130 --------------------------------
23132 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
23133 procedure Add_Entity_To_Name_Buffer
;
23134 -- Add the E_Kind of entity E to the name buffer
23136 -------------------------------
23137 -- Add_Entity_To_Name_Buffer --
23138 -------------------------------
23140 procedure Add_Entity_To_Name_Buffer
is
23142 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
23143 Add_Str_To_Name_Buffer
("entry");
23145 elsif Ekind_In
(E
, E_Generic_Package
,
23149 Add_Str_To_Name_Buffer
("package");
23151 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
23152 Add_Str_To_Name_Buffer
("protected type");
23154 elsif Ekind_In
(E
, E_Function
,
23155 E_Generic_Function
,
23156 E_Generic_Procedure
,
23160 Add_Str_To_Name_Buffer
("subprogram");
23163 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
23164 Add_Str_To_Name_Buffer
("task type");
23166 end Add_Entity_To_Name_Buffer
;
23170 Msg_1
: constant String := "incorrect placement of pragma%";
23173 -- Start of processing for Check_Library_Level_Entity
23176 if not Is_Library_Level_Entity
(E
) then
23177 Error_Msg_Name_1
:= Pname
;
23178 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
23181 Add_Str_To_Name_Buffer
("\& is not a library-level ");
23182 Add_Entity_To_Name_Buffer
;
23184 Msg_2
:= Name_Find
;
23185 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
23189 end Check_Library_Level_Entity
;
23195 procedure Process_Body
(Decl
: Node_Id
) is
23196 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23197 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
23200 -- Ignore pragma when applied to the special body created for
23201 -- inlining, recognized by its internal name _Parent.
23203 if Chars
(Body_Id
) = Name_uParent
then
23207 Check_Library_Level_Entity
(Body_Id
);
23209 -- For entry bodies, verify the legality against:
23210 -- * The mode of the context
23211 -- * The mode of the spec (if any)
23213 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
23215 -- A stand-alone subprogram body
23217 if Body_Id
= Spec_Id
then
23218 Check_Pragma_Conformance
23219 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23221 Entity_Pragma
=> Empty
);
23223 -- An entry or subprogram body that completes a previous
23227 Check_Pragma_Conformance
23228 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23230 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23234 Set_SPARK_Pragma
(Body_Id
, N
);
23235 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23237 -- For package bodies, verify the legality against:
23238 -- * The mode of the context
23239 -- * The mode of the private part
23241 -- This case is separated from protected and task bodies
23242 -- because the statement part of the package body inherits
23243 -- the mode of the body declarations.
23245 elsif Nkind
(Decl
) = N_Package_Body
then
23246 Check_Pragma_Conformance
23247 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23249 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23252 Set_SPARK_Pragma
(Body_Id
, N
);
23253 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23254 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23255 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
23257 -- For protected and task bodies, verify the legality against:
23258 -- * The mode of the context
23259 -- * The mode of the private part
23263 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
23265 Check_Pragma_Conformance
23266 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23268 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23271 Set_SPARK_Pragma
(Body_Id
, N
);
23272 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23276 --------------------------
23277 -- Process_Overloadable --
23278 --------------------------
23280 procedure Process_Overloadable
(Decl
: Node_Id
) is
23281 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23282 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
23285 Check_Library_Level_Entity
(Spec_Id
);
23287 -- Verify the legality against:
23288 -- * The mode of the context
23290 Check_Pragma_Conformance
23291 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23293 Entity_Pragma
=> Empty
);
23295 Set_SPARK_Pragma
(Spec_Id
, N
);
23296 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23298 -- When the pragma applies to the anonymous object created for
23299 -- a single task type, decorate the type as well. This scenario
23300 -- arises when the single task type lacks a task definition,
23301 -- therefore there is no issue with respect to a potential
23302 -- pragma SPARK_Mode in the private part.
23304 -- task type Anon_Task_Typ;
23305 -- Obj : Anon_Task_Typ;
23306 -- pragma SPARK_Mode ...;
23308 if Is_Single_Task_Object
(Spec_Id
) then
23309 Set_SPARK_Pragma
(Spec_Typ
, N
);
23310 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
23311 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
23312 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
23314 end Process_Overloadable
;
23316 --------------------------
23317 -- Process_Private_Part --
23318 --------------------------
23320 procedure Process_Private_Part
(Decl
: Node_Id
) is
23321 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23324 Check_Library_Level_Entity
(Spec_Id
);
23326 -- Verify the legality against:
23327 -- * The mode of the visible declarations
23329 Check_Pragma_Conformance
23330 (Context_Pragma
=> Empty
,
23332 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23335 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23336 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
23337 end Process_Private_Part
;
23339 ----------------------------
23340 -- Process_Statement_Part --
23341 ----------------------------
23343 procedure Process_Statement_Part
(Decl
: Node_Id
) is
23344 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23347 Check_Library_Level_Entity
(Body_Id
);
23349 -- Verify the legality against:
23350 -- * The mode of the body declarations
23352 Check_Pragma_Conformance
23353 (Context_Pragma
=> Empty
,
23355 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
23358 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23359 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
23360 end Process_Statement_Part
;
23362 --------------------------
23363 -- Process_Visible_Part --
23364 --------------------------
23366 procedure Process_Visible_Part
(Decl
: Node_Id
) is
23367 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23368 Obj_Id
: Entity_Id
;
23371 Check_Library_Level_Entity
(Spec_Id
);
23373 -- Verify the legality against:
23374 -- * The mode of the context
23376 Check_Pragma_Conformance
23377 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23379 Entity_Pragma
=> Empty
);
23381 -- A task unit declared without a definition does not set the
23382 -- SPARK_Mode of the context because the task does not have any
23383 -- entries that could inherit the mode.
23385 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
23386 N_Task_Type_Declaration
)
23391 Set_SPARK_Pragma
(Spec_Id
, N
);
23392 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23393 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23394 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
23396 -- When the pragma applies to a single protected or task type,
23397 -- decorate the corresponding anonymous object as well.
23399 -- protected Anon_Prot_Typ is
23400 -- pragma SPARK_Mode ...;
23402 -- end Anon_Prot_Typ;
23404 -- Obj : Anon_Prot_Typ;
23406 if Is_Single_Concurrent_Type
(Spec_Id
) then
23407 Obj_Id
:= Anonymous_Object
(Spec_Id
);
23409 Set_SPARK_Pragma
(Obj_Id
, N
);
23410 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
23412 end Process_Visible_Part
;
23414 -----------------------
23415 -- Set_SPARK_Context --
23416 -----------------------
23418 procedure Set_SPARK_Context
is
23420 SPARK_Mode
:= Mode_Id
;
23421 SPARK_Mode_Pragma
:= N
;
23422 end Set_SPARK_Context
;
23430 -- Start of processing for Do_SPARK_Mode
23433 -- When a SPARK_Mode pragma appears inside an instantiation whose
23434 -- enclosing context has SPARK_Mode set to "off", the pragma has
23435 -- no semantic effect.
23437 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
23438 Rewrite
(N
, Make_Null_Statement
(Loc
));
23444 Check_No_Identifiers
;
23445 Check_At_Most_N_Arguments
(1);
23447 -- Check the legality of the mode (no argument = ON)
23449 if Arg_Count
= 1 then
23450 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23451 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
23456 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
23457 Context
:= Parent
(N
);
23459 -- The pragma appears in a configuration file
23461 if No
(Context
) then
23462 Check_Valid_Configuration_Pragma
;
23464 if Present
(SPARK_Mode_Pragma
) then
23467 Prev
=> SPARK_Mode_Pragma
);
23473 -- The pragma acts as a configuration pragma in a compilation unit
23475 -- pragma SPARK_Mode ...;
23476 -- package Pack is ...;
23478 elsif Nkind
(Context
) = N_Compilation_Unit
23479 and then List_Containing
(N
) = Context_Items
(Context
)
23481 Check_Valid_Configuration_Pragma
;
23484 -- Otherwise the placement of the pragma within the tree dictates
23485 -- its associated construct. Inspect the declarative list where
23486 -- the pragma resides to find a potential construct.
23490 while Present
(Stmt
) loop
23492 -- Skip prior pragmas, but check for duplicates. Note that
23493 -- this also takes care of pragmas generated for aspects.
23495 if Nkind
(Stmt
) = N_Pragma
then
23496 if Pragma_Name
(Stmt
) = Pname
then
23503 -- The pragma applies to an expression function that has
23504 -- already been rewritten into a subprogram declaration.
23506 -- function Expr_Func return ... is (...);
23507 -- pragma SPARK_Mode ...;
23509 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
23510 and then Nkind
(Original_Node
(Stmt
)) =
23511 N_Expression_Function
23513 Process_Overloadable
(Stmt
);
23516 -- The pragma applies to the anonymous object created for a
23517 -- single concurrent type.
23519 -- protected type Anon_Prot_Typ ...;
23520 -- Obj : Anon_Prot_Typ;
23521 -- pragma SPARK_Mode ...;
23523 elsif Nkind
(Stmt
) = N_Object_Declaration
23524 and then Is_Single_Concurrent_Object
23525 (Defining_Entity
(Stmt
))
23527 Process_Overloadable
(Stmt
);
23530 -- Skip internally generated code
23532 elsif not Comes_From_Source
(Stmt
) then
23535 -- The pragma applies to an entry or [generic] subprogram
23539 -- pragma SPARK_Mode ...;
23542 -- procedure Proc ...;
23543 -- pragma SPARK_Mode ...;
23545 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
23546 N_Subprogram_Declaration
)
23547 or else (Nkind
(Stmt
) = N_Entry_Declaration
23548 and then Is_Protected_Type
23549 (Scope
(Defining_Entity
(Stmt
))))
23551 Process_Overloadable
(Stmt
);
23554 -- Otherwise the pragma does not apply to a legal construct
23555 -- or it does not appear at the top of a declarative or a
23556 -- statement list. Issue an error and stop the analysis.
23566 -- The pragma applies to a package or a subprogram that acts as
23567 -- a compilation unit.
23569 -- procedure Proc ...;
23570 -- pragma SPARK_Mode ...;
23572 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
23573 Context
:= Unit
(Parent
(Context
));
23576 -- The pragma appears at the top of entry, package, protected
23577 -- unit, subprogram or task unit body declarations.
23579 -- entry Ent when ... is
23580 -- pragma SPARK_Mode ...;
23582 -- package body Pack is
23583 -- pragma SPARK_Mode ...;
23585 -- procedure Proc ... is
23586 -- pragma SPARK_Mode;
23588 -- protected body Prot is
23589 -- pragma SPARK_Mode ...;
23591 if Nkind_In
(Context
, N_Entry_Body
,
23597 Process_Body
(Context
);
23599 -- The pragma appears at the top of the visible or private
23600 -- declaration of a package spec, protected or task unit.
23603 -- pragma SPARK_Mode ...;
23605 -- pragma SPARK_Mode ...;
23607 -- protected [type] Prot is
23608 -- pragma SPARK_Mode ...;
23610 -- pragma SPARK_Mode ...;
23612 elsif Nkind_In
(Context
, N_Package_Specification
,
23613 N_Protected_Definition
,
23616 if List_Containing
(N
) = Visible_Declarations
(Context
) then
23617 Process_Visible_Part
(Parent
(Context
));
23619 Process_Private_Part
(Parent
(Context
));
23622 -- The pragma appears at the top of package body statements
23624 -- package body Pack is
23626 -- pragma SPARK_Mode;
23628 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
23629 and then Nkind
(Parent
(Context
)) = N_Package_Body
23631 Process_Statement_Part
(Parent
(Context
));
23633 -- The pragma appeared as an aspect of a [generic] subprogram
23634 -- declaration that acts as a compilation unit.
23637 -- procedure Proc ...;
23638 -- pragma SPARK_Mode ...;
23640 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
23641 N_Subprogram_Declaration
)
23643 Process_Overloadable
(Context
);
23645 -- The pragma does not apply to a legal construct, issue error
23653 --------------------------------
23654 -- Static_Elaboration_Desired --
23655 --------------------------------
23657 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23659 when Pragma_Static_Elaboration_Desired
=>
23661 Check_At_Most_N_Arguments
(1);
23663 if Is_Compilation_Unit
(Current_Scope
)
23664 and then Ekind
(Current_Scope
) = E_Package
23666 Set_Static_Elaboration_Desired
(Current_Scope
, True);
23668 Error_Pragma
("pragma% must apply to a library-level package");
23675 -- pragma Storage_Size (EXPRESSION);
23677 when Pragma_Storage_Size
=> Storage_Size
: declare
23678 P
: constant Node_Id
:= Parent
(N
);
23682 Check_No_Identifiers
;
23683 Check_Arg_Count
(1);
23685 -- The expression must be analyzed in the special manner described
23686 -- in "Handling of Default Expressions" in sem.ads.
23688 Arg
:= Get_Pragma_Arg
(Arg1
);
23689 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23691 if not Is_OK_Static_Expression
(Arg
) then
23692 Check_Restriction
(Static_Storage_Size
, Arg
);
23695 if Nkind
(P
) /= N_Task_Definition
then
23700 if Has_Storage_Size_Pragma
(P
) then
23701 Error_Pragma
("duplicate pragma% not allowed");
23703 Set_Has_Storage_Size_Pragma
(P
, True);
23706 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
23714 -- pragma Storage_Unit (NUMERIC_LITERAL);
23716 -- Only permitted argument is System'Storage_Unit value
23718 when Pragma_Storage_Unit
=>
23719 Check_No_Identifiers
;
23720 Check_Arg_Count
(1);
23721 Check_Arg_Is_Integer_Literal
(Arg1
);
23723 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
23724 UI_From_Int
(Ttypes
.System_Storage_Unit
)
23726 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
23728 ("the only allowed argument for pragma% is ^", Arg1
);
23731 --------------------
23732 -- Stream_Convert --
23733 --------------------
23735 -- pragma Stream_Convert (
23736 -- [Entity =>] type_LOCAL_NAME,
23737 -- [Read =>] function_NAME,
23738 -- [Write =>] function NAME);
23740 when Pragma_Stream_Convert
=> Stream_Convert
: declare
23741 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
23742 -- Check that the given argument is the name of a local function
23743 -- of one argument that is not overloaded earlier in the current
23744 -- local scope. A check is also made that the argument is a
23745 -- function with one parameter.
23747 --------------------------------------
23748 -- Check_OK_Stream_Convert_Function --
23749 --------------------------------------
23751 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
23755 Check_Arg_Is_Local_Name
(Arg
);
23756 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
23758 if Has_Homonym
(Ent
) then
23760 ("argument for pragma% may not be overloaded", Arg
);
23763 if Ekind
(Ent
) /= E_Function
23764 or else No
(First_Formal
(Ent
))
23765 or else Present
(Next_Formal
(First_Formal
(Ent
)))
23768 ("argument for pragma% must be function of one argument",
23771 end Check_OK_Stream_Convert_Function
;
23773 -- Start of processing for Stream_Convert
23777 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
23778 Check_Arg_Count
(3);
23779 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23780 Check_Optional_Identifier
(Arg2
, Name_Read
);
23781 Check_Optional_Identifier
(Arg3
, Name_Write
);
23782 Check_Arg_Is_Local_Name
(Arg1
);
23783 Check_OK_Stream_Convert_Function
(Arg2
);
23784 Check_OK_Stream_Convert_Function
(Arg3
);
23787 Typ
: constant Entity_Id
:=
23788 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
23789 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
23790 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
23793 Check_First_Subtype
(Arg1
);
23795 -- Check for too early or too late. Note that we don't enforce
23796 -- the rule about primitive operations in this case, since, as
23797 -- is the case for explicit stream attributes themselves, these
23798 -- restrictions are not appropriate. Note that the chaining of
23799 -- the pragma by Rep_Item_Too_Late is actually the critical
23800 -- processing done for this pragma.
23802 if Rep_Item_Too_Early
(Typ
, N
)
23804 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
23809 -- Return if previous error
23811 if Etype
(Typ
) = Any_Type
23813 Etype
(Read
) = Any_Type
23815 Etype
(Write
) = Any_Type
23822 if Underlying_Type
(Etype
(Read
)) /= Typ
then
23824 ("incorrect return type for function&", Arg2
);
23827 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
23829 ("incorrect parameter type for function&", Arg3
);
23832 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
23833 Underlying_Type
(Etype
(Write
))
23836 ("result type of & does not match Read parameter type",
23840 end Stream_Convert
;
23846 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23848 -- This is processed by the parser since some of the style checks
23849 -- take place during source scanning and parsing. This means that
23850 -- we don't need to issue error messages here.
23852 when Pragma_Style_Checks
=> Style_Checks
: declare
23853 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23859 Check_No_Identifiers
;
23861 -- Two argument form
23863 if Arg_Count
= 2 then
23864 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23871 E_Id
:= Get_Pragma_Arg
(Arg2
);
23874 if not Is_Entity_Name
(E_Id
) then
23876 ("second argument of pragma% must be entity name",
23880 E
:= Entity
(E_Id
);
23882 if not Ignore_Style_Checks_Pragmas
then
23887 Set_Suppress_Style_Checks
23888 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
23889 exit when No
(Homonym
(E
));
23896 -- One argument form
23899 Check_Arg_Count
(1);
23901 if Nkind
(A
) = N_String_Literal
then
23905 Slen
: constant Natural := Natural (String_Length
(S
));
23906 Options
: String (1 .. Slen
);
23912 C
:= Get_String_Char
(S
, Pos
(J
));
23913 exit when not In_Character_Range
(C
);
23914 Options
(J
) := Get_Character
(C
);
23916 -- If at end of string, set options. As per discussion
23917 -- above, no need to check for errors, since we issued
23918 -- them in the parser.
23921 if not Ignore_Style_Checks_Pragmas
then
23922 Set_Style_Check_Options
(Options
);
23932 elsif Nkind
(A
) = N_Identifier
then
23933 if Chars
(A
) = Name_All_Checks
then
23934 if not Ignore_Style_Checks_Pragmas
then
23936 Set_GNAT_Style_Check_Options
;
23938 Set_Default_Style_Check_Options
;
23942 elsif Chars
(A
) = Name_On
then
23943 if not Ignore_Style_Checks_Pragmas
then
23944 Style_Check
:= True;
23947 elsif Chars
(A
) = Name_Off
then
23948 if not Ignore_Style_Checks_Pragmas
then
23949 Style_Check
:= False;
23960 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23962 when Pragma_Subtitle
=>
23964 Check_Arg_Count
(1);
23965 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
23966 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23973 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23975 when Pragma_Suppress
=>
23976 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
23982 -- pragma Suppress_All;
23984 -- The only check made here is that the pragma has no arguments.
23985 -- There are no placement rules, and the processing required (setting
23986 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23987 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23988 -- then creates and inserts a pragma Suppress (All_Checks).
23990 when Pragma_Suppress_All
=>
23992 Check_Arg_Count
(0);
23994 -------------------------
23995 -- Suppress_Debug_Info --
23996 -------------------------
23998 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
24000 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
24001 Nam_Id
: Entity_Id
;
24005 Check_Arg_Count
(1);
24006 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24007 Check_Arg_Is_Local_Name
(Arg1
);
24009 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
24011 -- A pragma that applies to a Ghost entity becomes Ghost for the
24012 -- purposes of legality checks and removal of ignored Ghost code.
24014 Mark_Ghost_Pragma
(N
, Nam_Id
);
24015 Set_Debug_Info_Off
(Nam_Id
);
24016 end Suppress_Debug_Info
;
24018 ----------------------------------
24019 -- Suppress_Exception_Locations --
24020 ----------------------------------
24022 -- pragma Suppress_Exception_Locations;
24024 when Pragma_Suppress_Exception_Locations
=>
24026 Check_Arg_Count
(0);
24027 Check_Valid_Configuration_Pragma
;
24028 Exception_Locations_Suppressed
:= True;
24030 -----------------------------
24031 -- Suppress_Initialization --
24032 -----------------------------
24034 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24036 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
24042 Check_Arg_Count
(1);
24043 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24044 Check_Arg_Is_Local_Name
(Arg1
);
24046 E_Id
:= Get_Pragma_Arg
(Arg1
);
24048 if Etype
(E_Id
) = Any_Type
then
24052 E
:= Entity
(E_Id
);
24054 -- A pragma that applies to a Ghost entity becomes Ghost for the
24055 -- purposes of legality checks and removal of ignored Ghost code.
24057 Mark_Ghost_Pragma
(N
, E
);
24059 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
24061 ("pragma% requires variable, type or subtype", Arg1
);
24064 if Rep_Item_Too_Early
(E
, N
)
24066 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
24071 -- For incomplete/private type, set flag on full view
24073 if Is_Incomplete_Or_Private_Type
(E
) then
24074 if No
(Full_View
(Base_Type
(E
))) then
24076 ("argument of pragma% cannot be an incomplete type", Arg1
);
24078 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
24081 -- For first subtype, set flag on base type
24083 elsif Is_First_Subtype
(E
) then
24084 Set_Suppress_Initialization
(Base_Type
(E
));
24086 -- For other than first subtype, set flag on subtype or variable
24089 Set_Suppress_Initialization
(E
);
24097 -- pragma System_Name (DIRECT_NAME);
24099 -- Syntax check: one argument, which must be the identifier GNAT or
24100 -- the identifier GCC, no other identifiers are acceptable.
24102 when Pragma_System_Name
=>
24104 Check_No_Identifiers
;
24105 Check_Arg_Count
(1);
24106 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
24108 -----------------------------
24109 -- Task_Dispatching_Policy --
24110 -----------------------------
24112 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24114 when Pragma_Task_Dispatching_Policy
=> declare
24118 Check_Ada_83_Warning
;
24119 Check_Arg_Count
(1);
24120 Check_No_Identifiers
;
24121 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
24122 Check_Valid_Configuration_Pragma
;
24123 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24124 DP
:= Fold_Upper
(Name_Buffer
(1));
24126 if Task_Dispatching_Policy
/= ' '
24127 and then Task_Dispatching_Policy
/= DP
24129 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
24131 ("task dispatching policy incompatible with policy#");
24133 -- Set new policy, but always preserve System_Location since we
24134 -- like the error message with the run time name.
24137 Task_Dispatching_Policy
:= DP
;
24139 if Task_Dispatching_Policy_Sloc
/= System_Location
then
24140 Task_Dispatching_Policy_Sloc
:= Loc
;
24149 -- pragma Task_Info (EXPRESSION);
24151 when Pragma_Task_Info
=> Task_Info
: declare
24152 P
: constant Node_Id
:= Parent
(N
);
24158 if Warn_On_Obsolescent_Feature
then
24160 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24161 & "instead?j?", N
);
24164 if Nkind
(P
) /= N_Task_Definition
then
24165 Error_Pragma
("pragma% must appear in task definition");
24168 Check_No_Identifiers
;
24169 Check_Arg_Count
(1);
24171 Analyze_And_Resolve
24172 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
24174 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
24178 Ent
:= Defining_Identifier
(Parent
(P
));
24180 -- Check duplicate pragma before we chain the pragma in the Rep
24181 -- Item chain of Ent.
24184 (Ent
, Name_Task_Info
, Check_Parents
=> False)
24186 Error_Pragma
("duplicate pragma% not allowed");
24189 Record_Rep_Item
(Ent
, N
);
24196 -- pragma Task_Name (string_EXPRESSION);
24198 when Pragma_Task_Name
=> Task_Name
: declare
24199 P
: constant Node_Id
:= Parent
(N
);
24204 Check_No_Identifiers
;
24205 Check_Arg_Count
(1);
24207 Arg
:= Get_Pragma_Arg
(Arg1
);
24209 -- The expression is used in the call to Create_Task, and must be
24210 -- expanded there, not in the context of the current spec. It must
24211 -- however be analyzed to capture global references, in case it
24212 -- appears in a generic context.
24214 Preanalyze_And_Resolve
(Arg
, Standard_String
);
24216 if Nkind
(P
) /= N_Task_Definition
then
24220 Ent
:= Defining_Identifier
(Parent
(P
));
24222 -- Check duplicate pragma before we chain the pragma in the Rep
24223 -- Item chain of Ent.
24226 (Ent
, Name_Task_Name
, Check_Parents
=> False)
24228 Error_Pragma
("duplicate pragma% not allowed");
24231 Record_Rep_Item
(Ent
, N
);
24238 -- pragma Task_Storage (
24239 -- [Task_Type =>] LOCAL_NAME,
24240 -- [Top_Guard =>] static_integer_EXPRESSION);
24242 when Pragma_Task_Storage
=> Task_Storage
: declare
24243 Args
: Args_List
(1 .. 2);
24244 Names
: constant Name_List
(1 .. 2) := (
24248 Task_Type
: Node_Id
renames Args
(1);
24249 Top_Guard
: Node_Id
renames Args
(2);
24255 Gather_Associations
(Names
, Args
);
24257 if No
(Task_Type
) then
24259 ("missing task_type argument for pragma%");
24262 Check_Arg_Is_Local_Name
(Task_Type
);
24264 Ent
:= Entity
(Task_Type
);
24266 if not Is_Task_Type
(Ent
) then
24268 ("argument for pragma% must be task type", Task_Type
);
24271 if No
(Top_Guard
) then
24273 ("pragma% takes two arguments", Task_Type
);
24275 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
24278 Check_First_Subtype
(Task_Type
);
24280 if Rep_Item_Too_Late
(Ent
, N
) then
24289 -- pragma Test_Case
24290 -- ([Name =>] Static_String_EXPRESSION
24291 -- ,[Mode =>] MODE_TYPE
24292 -- [, Requires => Boolean_EXPRESSION]
24293 -- [, Ensures => Boolean_EXPRESSION]);
24295 -- MODE_TYPE ::= Nominal | Robustness
24297 -- Characteristics:
24299 -- * Analysis - The annotation undergoes initial checks to verify
24300 -- the legal placement and context. Secondary checks preanalyze the
24303 -- Analyze_Test_Case_In_Decl_Part
24305 -- * Expansion - None.
24307 -- * Template - The annotation utilizes the generic template of the
24308 -- related subprogram when it is:
24310 -- aspect on subprogram declaration
24312 -- The annotation must prepare its own template when it is:
24314 -- pragma on subprogram declaration
24316 -- * Globals - Capture of global references must occur after full
24319 -- * Instance - The annotation is instantiated automatically when
24320 -- the related generic subprogram is instantiated except for the
24321 -- "pragma on subprogram declaration" case. In that scenario the
24322 -- annotation must instantiate itself.
24324 when Pragma_Test_Case
=> Test_Case
: declare
24325 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
24326 -- Ensure that the contract of subprogram Subp_Id does not contain
24327 -- another Test_Case pragma with the same Name as the current one.
24329 -------------------------
24330 -- Check_Distinct_Name --
24331 -------------------------
24333 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
24334 Items
: constant Node_Id
:= Contract
(Subp_Id
);
24335 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
24339 -- Inspect all Test_Case pragma of the related subprogram
24340 -- looking for one with a duplicate "Name" argument.
24342 if Present
(Items
) then
24343 Prag
:= Contract_Test_Cases
(Items
);
24344 while Present
(Prag
) loop
24345 if Pragma_Name
(Prag
) = Name_Test_Case
24347 and then String_Equal
24348 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
24350 Error_Msg_Sloc
:= Sloc
(Prag
);
24351 Error_Pragma
("name for pragma % is already used #");
24354 Prag
:= Next_Pragma
(Prag
);
24357 end Check_Distinct_Name
;
24361 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
24364 Subp_Decl
: Node_Id
;
24365 Subp_Id
: Entity_Id
;
24367 -- Start of processing for Test_Case
24371 Check_At_Least_N_Arguments
(2);
24372 Check_At_Most_N_Arguments
(4);
24374 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
24378 Check_Optional_Identifier
(Arg1
, Name_Name
);
24379 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24383 Check_Optional_Identifier
(Arg2
, Name_Mode
);
24384 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
24386 -- Arguments "Requires" and "Ensures"
24388 if Present
(Arg3
) then
24389 if Present
(Arg4
) then
24390 Check_Identifier
(Arg3
, Name_Requires
);
24391 Check_Identifier
(Arg4
, Name_Ensures
);
24393 Check_Identifier_Is_One_Of
24394 (Arg3
, Name_Requires
, Name_Ensures
);
24398 -- Pragma Test_Case must be associated with a subprogram declared
24399 -- in a library-level package. First determine whether the current
24400 -- compilation unit is a legal context.
24402 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
24403 N_Generic_Package_Declaration
)
24407 -- Otherwise the placement is illegal
24411 ("pragma % must be specified within a package declaration");
24415 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
24417 -- Find the enclosing context
24419 Context
:= Parent
(Subp_Decl
);
24421 if Present
(Context
) then
24422 Context
:= Parent
(Context
);
24425 -- Verify the placement of the pragma
24427 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
24429 ("pragma % cannot be applied to abstract subprogram");
24432 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
24433 Error_Pragma
("pragma % cannot be applied to entry");
24436 -- The context is a [generic] subprogram declared at the top level
24437 -- of the [generic] package unit.
24439 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
24440 N_Subprogram_Declaration
)
24441 and then Present
(Context
)
24442 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
24443 N_Package_Declaration
)
24447 -- Otherwise the placement is illegal
24451 ("pragma % must be applied to a library-level subprogram "
24456 Subp_Id
:= Defining_Entity
(Subp_Decl
);
24458 -- A pragma that applies to a Ghost entity becomes Ghost for the
24459 -- purposes of legality checks and removal of ignored Ghost code.
24461 Mark_Ghost_Pragma
(N
, Subp_Id
);
24463 -- Chain the pragma on the contract for further processing by
24464 -- Analyze_Test_Case_In_Decl_Part.
24466 Add_Contract_Item
(N
, Subp_Id
);
24468 -- Preanalyze the original aspect argument "Name" for ASIS or for
24469 -- a generic subprogram to properly capture global references.
24471 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
24472 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
24474 if Present
(Asp_Arg
) then
24476 -- The argument appears with an identifier in association
24479 if Nkind
(Asp_Arg
) = N_Component_Association
then
24480 Asp_Arg
:= Expression
(Asp_Arg
);
24483 Check_Expr_Is_OK_Static_Expression
24484 (Asp_Arg
, Standard_String
);
24488 -- Ensure that the all Test_Case pragmas of the related subprogram
24489 -- have distinct names.
24491 Check_Distinct_Name
(Subp_Id
);
24493 -- Fully analyze the pragma when it appears inside an entry
24494 -- or subprogram body because it cannot benefit from forward
24497 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
24499 N_Subprogram_Body_Stub
)
24501 -- The legality checks of pragma Test_Case are affected by the
24502 -- SPARK mode in effect and the volatility of the context.
24503 -- Analyze all pragmas in a specific order.
24505 Analyze_If_Present
(Pragma_SPARK_Mode
);
24506 Analyze_If_Present
(Pragma_Volatile_Function
);
24507 Analyze_Test_Case_In_Decl_Part
(N
);
24511 --------------------------
24512 -- Thread_Local_Storage --
24513 --------------------------
24515 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24517 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
24523 Check_Arg_Count
(1);
24524 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24525 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
24527 Id
:= Get_Pragma_Arg
(Arg1
);
24530 if not Is_Entity_Name
(Id
)
24531 or else Ekind
(Entity
(Id
)) /= E_Variable
24533 Error_Pragma_Arg
("local variable name required", Arg1
);
24538 -- A pragma that applies to a Ghost entity becomes Ghost for the
24539 -- purposes of legality checks and removal of ignored Ghost code.
24541 Mark_Ghost_Pragma
(N
, E
);
24543 if Rep_Item_Too_Early
(E
, N
)
24545 Rep_Item_Too_Late
(E
, N
)
24550 Set_Has_Pragma_Thread_Local_Storage
(E
);
24551 Set_Has_Gigi_Rep_Item
(E
);
24552 end Thread_Local_Storage
;
24558 -- pragma Time_Slice (static_duration_EXPRESSION);
24560 when Pragma_Time_Slice
=> Time_Slice
: declare
24566 Check_Arg_Count
(1);
24567 Check_No_Identifiers
;
24568 Check_In_Main_Program
;
24569 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
24571 if not Error_Posted
(Arg1
) then
24573 while Present
(Nod
) loop
24574 if Nkind
(Nod
) = N_Pragma
24575 and then Pragma_Name
(Nod
) = Name_Time_Slice
24577 Error_Msg_Name_1
:= Pname
;
24578 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
24585 -- Process only if in main unit
24587 if Get_Source_Unit
(Loc
) = Main_Unit
then
24588 Opt
.Time_Slice_Set
:= True;
24589 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
24591 if Val
<= Ureal_0
then
24592 Opt
.Time_Slice_Value
:= 0;
24594 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
24595 Opt
.Time_Slice_Value
:= 1_000_000_000
;
24598 Opt
.Time_Slice_Value
:=
24599 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
24608 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24610 -- TITLING_OPTION ::=
24611 -- [Title =>] STRING_LITERAL
24612 -- | [Subtitle =>] STRING_LITERAL
24614 when Pragma_Title
=> Title
: declare
24615 Args
: Args_List
(1 .. 2);
24616 Names
: constant Name_List
(1 .. 2) := (
24622 Gather_Associations
(Names
, Args
);
24625 for J
in 1 .. 2 loop
24626 if Present
(Args
(J
)) then
24627 Check_Arg_Is_OK_Static_Expression
24628 (Args
(J
), Standard_String
);
24633 ----------------------------
24634 -- Type_Invariant[_Class] --
24635 ----------------------------
24637 -- pragma Type_Invariant[_Class]
24638 -- ([Entity =>] type_LOCAL_NAME,
24639 -- [Check =>] EXPRESSION);
24641 when Pragma_Type_Invariant
24642 | Pragma_Type_Invariant_Class
24644 Type_Invariant
: declare
24645 I_Pragma
: Node_Id
;
24648 Check_Arg_Count
(2);
24650 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24651 -- setting Class_Present for the Type_Invariant_Class case.
24653 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
24654 I_Pragma
:= New_Copy
(N
);
24655 Set_Pragma_Identifier
24656 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
24657 Rewrite
(N
, I_Pragma
);
24658 Set_Analyzed
(N
, False);
24660 end Type_Invariant
;
24662 ---------------------
24663 -- Unchecked_Union --
24664 ---------------------
24666 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24668 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
24669 Assoc
: constant Node_Id
:= Arg1
;
24670 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
24680 Check_No_Identifiers
;
24681 Check_Arg_Count
(1);
24682 Check_Arg_Is_Local_Name
(Arg1
);
24684 Find_Type
(Type_Id
);
24686 Typ
:= Entity
(Type_Id
);
24688 -- A pragma that applies to a Ghost entity becomes Ghost for the
24689 -- purposes of legality checks and removal of ignored Ghost code.
24691 Mark_Ghost_Pragma
(N
, Typ
);
24694 or else Rep_Item_Too_Early
(Typ
, N
)
24698 Typ
:= Underlying_Type
(Typ
);
24701 if Rep_Item_Too_Late
(Typ
, N
) then
24705 Check_First_Subtype
(Arg1
);
24707 -- Note remaining cases are references to a type in the current
24708 -- declarative part. If we find an error, we post the error on
24709 -- the relevant type declaration at an appropriate point.
24711 if not Is_Record_Type
(Typ
) then
24712 Error_Msg_N
("unchecked union must be record type", Typ
);
24715 elsif Is_Tagged_Type
(Typ
) then
24716 Error_Msg_N
("unchecked union must not be tagged", Typ
);
24719 elsif not Has_Discriminants
(Typ
) then
24721 ("unchecked union must have one discriminant", Typ
);
24724 -- Note: in previous versions of GNAT we used to check for limited
24725 -- types and give an error, but in fact the standard does allow
24726 -- Unchecked_Union on limited types, so this check was removed.
24728 -- Similarly, GNAT used to require that all discriminants have
24729 -- default values, but this is not mandated by the RM.
24731 -- Proceed with basic error checks completed
24734 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
24735 Clist
:= Component_List
(Tdef
);
24737 -- Check presence of component list and variant part
24739 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
24741 ("unchecked union must have variant part", Tdef
);
24745 -- Check components
24747 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
24748 while Present
(Comp
) loop
24749 Check_Component
(Comp
, Typ
);
24750 Next_Non_Pragma
(Comp
);
24753 -- Check variant part
24755 Vpart
:= Variant_Part
(Clist
);
24757 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
24758 while Present
(Variant
) loop
24759 Check_Variant
(Variant
, Typ
);
24760 Next_Non_Pragma
(Variant
);
24764 Set_Is_Unchecked_Union
(Typ
);
24765 Set_Convention
(Typ
, Convention_C
);
24766 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
24767 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
24768 end Unchecked_Union
;
24770 ----------------------------
24771 -- Unevaluated_Use_Of_Old --
24772 ----------------------------
24774 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24776 when Pragma_Unevaluated_Use_Of_Old
=>
24778 Check_Arg_Count
(1);
24779 Check_No_Identifiers
;
24780 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
24782 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24783 -- a declarative part or a package spec.
24785 if not Is_Configuration_Pragma
then
24786 Check_Is_In_Decl_Part_Or_Package_Spec
;
24789 -- Store proper setting of Uneval_Old
24791 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24792 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
24794 ------------------------
24795 -- Unimplemented_Unit --
24796 ------------------------
24798 -- pragma Unimplemented_Unit;
24800 -- Note: this only gives an error if we are generating code, or if
24801 -- we are in a generic library unit (where the pragma appears in the
24802 -- body, not in the spec).
24804 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
24805 Cunitent
: constant Entity_Id
:=
24806 Cunit_Entity
(Get_Source_Unit
(Loc
));
24807 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
24811 Check_Arg_Count
(0);
24813 if Operating_Mode
= Generate_Code
24814 or else Ent_Kind
= E_Generic_Function
24815 or else Ent_Kind
= E_Generic_Procedure
24816 or else Ent_Kind
= E_Generic_Package
24818 Get_Name_String
(Chars
(Cunitent
));
24819 Set_Casing
(Mixed_Case
);
24820 Write_Str
(Name_Buffer
(1 .. Name_Len
));
24821 Write_Str
(" is not supported in this configuration");
24823 raise Unrecoverable_Error
;
24825 end Unimplemented_Unit
;
24827 ------------------------
24828 -- Universal_Aliasing --
24829 ------------------------
24831 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24833 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
24839 Check_Arg_Count
(1);
24840 Check_Optional_Identifier
(Arg2
, Name_Entity
);
24841 Check_Arg_Is_Local_Name
(Arg1
);
24842 E_Id
:= Get_Pragma_Arg
(Arg1
);
24844 if Etype
(E_Id
) = Any_Type
then
24848 E
:= Entity
(E_Id
);
24850 if not Is_Type
(E
) then
24851 Error_Pragma_Arg
("pragma% requires type", Arg1
);
24854 -- A pragma that applies to a Ghost entity becomes Ghost for the
24855 -- purposes of legality checks and removal of ignored Ghost code.
24857 Mark_Ghost_Pragma
(N
, E
);
24858 Set_Universal_Aliasing
(Base_Type
(E
));
24859 Record_Rep_Item
(E
, N
);
24860 end Universal_Alias
;
24862 --------------------
24863 -- Universal_Data --
24864 --------------------
24866 -- pragma Universal_Data [(library_unit_NAME)];
24868 when Pragma_Universal_Data
=>
24870 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
24876 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24878 when Pragma_Unmodified
=>
24879 Analyze_Unmodified_Or_Unused
;
24885 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24887 -- or when used in a context clause:
24889 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24891 when Pragma_Unreferenced
=>
24892 Analyze_Unreferenced_Or_Unused
;
24894 --------------------------
24895 -- Unreferenced_Objects --
24896 --------------------------
24898 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24900 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
24902 Arg_Expr
: Node_Id
;
24903 Arg_Id
: Entity_Id
;
24905 Ghost_Error_Posted
: Boolean := False;
24906 -- Flag set when an error concerning the illegal mix of Ghost and
24907 -- non-Ghost types is emitted.
24909 Ghost_Id
: Entity_Id
:= Empty
;
24910 -- The entity of the first Ghost type encountered while processing
24911 -- the arguments of the pragma.
24915 Check_At_Least_N_Arguments
(1);
24918 while Present
(Arg
) loop
24919 Check_No_Identifier
(Arg
);
24920 Check_Arg_Is_Local_Name
(Arg
);
24921 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
24923 if Is_Entity_Name
(Arg_Expr
) then
24924 Arg_Id
:= Entity
(Arg_Expr
);
24926 if Is_Type
(Arg_Id
) then
24927 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
24929 -- A pragma that applies to a Ghost entity becomes Ghost
24930 -- for the purposes of legality checks and removal of
24931 -- ignored Ghost code.
24933 Mark_Ghost_Pragma
(N
, Arg_Id
);
24935 -- Capture the entity of the first Ghost type being
24936 -- processed for error detection purposes.
24938 if Is_Ghost_Entity
(Arg_Id
) then
24939 if No
(Ghost_Id
) then
24940 Ghost_Id
:= Arg_Id
;
24943 -- Otherwise the type is non-Ghost. It is illegal to mix
24944 -- references to Ghost and non-Ghost entities
24947 elsif Present
(Ghost_Id
)
24948 and then not Ghost_Error_Posted
24950 Ghost_Error_Posted
:= True;
24952 Error_Msg_Name_1
:= Pname
;
24954 ("pragma % cannot mention ghost and non-ghost types",
24957 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
24958 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
24960 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
24961 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
24965 ("argument for pragma% must be type or subtype", Arg
);
24969 ("argument for pragma% must be type or subtype", Arg
);
24974 end Unreferenced_Objects
;
24976 ------------------------------
24977 -- Unreserve_All_Interrupts --
24978 ------------------------------
24980 -- pragma Unreserve_All_Interrupts;
24982 when Pragma_Unreserve_All_Interrupts
=>
24984 Check_Arg_Count
(0);
24986 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
24987 Unreserve_All_Interrupts
:= True;
24994 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24996 when Pragma_Unsuppress
=>
24998 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
25004 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25006 when Pragma_Unused
=>
25007 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
25008 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
25010 -------------------
25011 -- Use_VADS_Size --
25012 -------------------
25014 -- pragma Use_VADS_Size;
25016 when Pragma_Use_VADS_Size
=>
25018 Check_Arg_Count
(0);
25019 Check_Valid_Configuration_Pragma
;
25020 Use_VADS_Size
:= True;
25022 ---------------------
25023 -- Validity_Checks --
25024 ---------------------
25026 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25028 when Pragma_Validity_Checks
=> Validity_Checks
: declare
25029 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
25035 Check_Arg_Count
(1);
25036 Check_No_Identifiers
;
25038 -- Pragma always active unless in CodePeer or GNATprove modes,
25039 -- which use a fixed configuration of validity checks.
25041 if not (CodePeer_Mode
or GNATprove_Mode
) then
25042 if Nkind
(A
) = N_String_Literal
then
25046 Slen
: constant Natural := Natural (String_Length
(S
));
25047 Options
: String (1 .. Slen
);
25051 -- Couldn't we use a for loop here over Options'Range???
25055 C
:= Get_String_Char
(S
, Pos
(J
));
25057 -- This is a weird test, it skips setting validity
25058 -- checks entirely if any element of S is out of
25059 -- range of Character, what is that about ???
25061 exit when not In_Character_Range
(C
);
25062 Options
(J
) := Get_Character
(C
);
25065 Set_Validity_Check_Options
(Options
);
25073 elsif Nkind
(A
) = N_Identifier
then
25074 if Chars
(A
) = Name_All_Checks
then
25075 Set_Validity_Check_Options
("a");
25076 elsif Chars
(A
) = Name_On
then
25077 Validity_Checks_On
:= True;
25078 elsif Chars
(A
) = Name_Off
then
25079 Validity_Checks_On
:= False;
25083 end Validity_Checks
;
25089 -- pragma Volatile (LOCAL_NAME);
25091 when Pragma_Volatile
=>
25092 Process_Atomic_Independent_Shared_Volatile
;
25094 -------------------------
25095 -- Volatile_Components --
25096 -------------------------
25098 -- pragma Volatile_Components (array_LOCAL_NAME);
25100 -- Volatile is handled by the same circuit as Atomic_Components
25102 --------------------------
25103 -- Volatile_Full_Access --
25104 --------------------------
25106 -- pragma Volatile_Full_Access (LOCAL_NAME);
25108 when Pragma_Volatile_Full_Access
=>
25110 Process_Atomic_Independent_Shared_Volatile
;
25112 -----------------------
25113 -- Volatile_Function --
25114 -----------------------
25116 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25118 when Pragma_Volatile_Function
=> Volatile_Function
: declare
25119 Over_Id
: Entity_Id
;
25120 Spec_Id
: Entity_Id
;
25121 Subp_Decl
: Node_Id
;
25125 Check_No_Identifiers
;
25126 Check_At_Most_N_Arguments
(1);
25129 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25131 -- Generic subprogram
25133 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25136 -- Body acts as spec
25138 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25139 and then No
(Corresponding_Spec
(Subp_Decl
))
25143 -- Body stub acts as spec
25145 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25146 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25152 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25160 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25162 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
25167 -- A pragma that applies to a Ghost entity becomes Ghost for the
25168 -- purposes of legality checks and removal of ignored Ghost code.
25170 Mark_Ghost_Pragma
(N
, Spec_Id
);
25172 -- Chain the pragma on the contract for completeness
25174 Add_Contract_Item
(N
, Spec_Id
);
25176 -- The legality checks of pragma Volatile_Function are affected by
25177 -- the SPARK mode in effect. Analyze all pragmas in a specific
25180 Analyze_If_Present
(Pragma_SPARK_Mode
);
25182 -- A volatile function cannot override a non-volatile function
25183 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25184 -- in New_Overloaded_Entity, however at that point the pragma has
25185 -- not been processed yet.
25187 Over_Id
:= Overridden_Operation
(Spec_Id
);
25189 if Present
(Over_Id
)
25190 and then not Is_Volatile_Function
(Over_Id
)
25193 ("incompatible volatile function values in effect", Spec_Id
);
25195 Error_Msg_Sloc
:= Sloc
(Over_Id
);
25197 ("\& declared # with Volatile_Function value False",
25200 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
25202 ("\overridden # with Volatile_Function value True",
25206 -- Analyze the Boolean expression (if any)
25208 if Present
(Arg1
) then
25209 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
25211 end Volatile_Function
;
25213 ----------------------
25214 -- Warning_As_Error --
25215 ----------------------
25217 -- pragma Warning_As_Error (static_string_EXPRESSION);
25219 when Pragma_Warning_As_Error
=>
25221 Check_Arg_Count
(1);
25222 Check_No_Identifiers
;
25223 Check_Valid_Configuration_Pragma
;
25225 if not Is_Static_String_Expression
(Arg1
) then
25227 ("argument of pragma% must be static string expression",
25230 -- OK static string expression
25233 Acquire_Warning_Match_String
(Arg1
);
25234 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
25235 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
25236 new String'(Name_Buffer (1 .. Name_Len));
25243 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25245 -- DETAILS ::= On | Off
25246 -- DETAILS ::= On | Off, local_NAME
25247 -- DETAILS ::= static_string_EXPRESSION
25248 -- DETAILS ::= On | Off, static_string_EXPRESSION
25250 -- TOOL_NAME ::= GNAT | GNATProve
25252 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25254 -- Note: If the first argument matches an allowed tool name, it is
25255 -- always considered to be a tool name, even if there is a string
25256 -- variable of that name.
25258 -- Note if the second argument of DETAILS is a local_NAME then the
25259 -- second form is always understood. If the intention is to use
25260 -- the fourth form, then you can write NAME & "" to force the
25261 -- intepretation as a static_string_EXPRESSION.
25263 when Pragma_Warnings => Warnings : declare
25264 Reason : String_Id;
25268 Check_At_Least_N_Arguments (1);
25270 -- See if last argument is labeled Reason. If so, make sure we
25271 -- have a string literal or a concatenation of string literals,
25272 -- and acquire the REASON string. Then remove the REASON argument
25273 -- by decreasing Num_Args by one; Remaining processing looks only
25274 -- at first Num_Args arguments).
25277 Last_Arg : constant Node_Id :=
25278 Last (Pragma_Argument_Associations (N));
25281 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25282 and then Chars (Last_Arg) = Name_Reason
25285 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25286 Reason := End_String;
25287 Arg_Count := Arg_Count - 1;
25289 -- Not allowed in compiler units (bootstrap issues)
25291 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25293 -- No REASON string, set null string as reason
25296 Reason := Null_String_Id;
25300 -- Now proceed with REASON taken care of and eliminated
25302 Check_No_Identifiers;
25304 -- If debug flag -gnatd.i is set, pragma is ignored
25306 if Debug_Flag_Dot_I then
25310 -- Process various forms of the pragma
25313 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25314 Shifted_Args : List_Id;
25317 -- See if first argument is a tool name, currently either
25318 -- GNAT or GNATprove. If so, either ignore the pragma if the
25319 -- tool used does not match, or continue as if no tool name
25320 -- was given otherwise, by shifting the arguments.
25322 if Nkind (Argx) = N_Identifier
25323 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25325 if Chars (Argx) = Name_Gnat then
25326 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25327 Rewrite (N, Make_Null_Statement (Loc));
25332 elsif Chars (Argx) = Name_Gnatprove then
25333 if not GNATprove_Mode then
25334 Rewrite (N, Make_Null_Statement (Loc));
25340 raise Program_Error;
25343 -- At this point, the pragma Warnings applies to the tool,
25344 -- so continue with shifted arguments.
25346 Arg_Count := Arg_Count - 1;
25348 if Arg_Count = 1 then
25349 Shifted_Args := New_List (New_Copy (Arg2));
25350 elsif Arg_Count = 2 then
25351 Shifted_Args := New_List (New_Copy (Arg2),
25353 elsif Arg_Count = 3 then
25354 Shifted_Args := New_List (New_Copy (Arg2),
25358 raise Program_Error;
25363 Chars => Name_Warnings,
25364 Pragma_Argument_Associations => Shifted_Args));
25369 -- One argument case
25371 if Arg_Count = 1 then
25373 -- On/Off one argument case was processed by parser
25375 if Nkind (Argx) = N_Identifier
25376 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25380 -- One argument case must be ON/OFF or static string expr
25382 elsif not Is_Static_String_Expression (Arg1) then
25384 ("argument of pragma% must be On/Off or static string "
25385 & "expression", Arg1);
25387 -- One argument string expression case
25391 Lit : constant Node_Id := Expr_Value_S (Argx);
25392 Str : constant String_Id := Strval (Lit);
25393 Len : constant Nat := String_Length (Str);
25401 while J <= Len loop
25402 C := Get_String_Char (Str, J);
25403 OK := In_Character_Range (C);
25406 Chr := Get_Character (C);
25408 -- Dash case: only -Wxxx is accepted
25415 C := Get_String_Char (Str, J);
25416 Chr := Get_Character (C);
25417 exit when Chr = 'W
';
25422 elsif J < Len and then Chr = '.' then
25424 C := Get_String_Char (Str, J);
25425 Chr := Get_Character (C);
25427 if not Set_Dot_Warning_Switch (Chr) then
25429 ("invalid warning switch character "
25430 & '.' & Chr, Arg1);
25436 OK := Set_Warning_Switch (Chr);
25441 ("invalid warning switch character " & Chr,
25447 ("invalid wide character in warning switch ",
25456 -- Two or more arguments (must be two)
25459 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25460 Check_Arg_Count (2);
25468 E_Id := Get_Pragma_Arg (Arg2);
25471 -- In the expansion of an inlined body, a reference to
25472 -- the formal may be wrapped in a conversion if the
25473 -- actual is a conversion. Retrieve the real entity name.
25475 if (In_Instance_Body or In_Inlined_Body)
25476 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25478 E_Id := Expression (E_Id);
25481 -- Entity name case
25483 if Is_Entity_Name (E_Id) then
25484 E := Entity (E_Id);
25491 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25494 -- Suppress elaboration warnings if the entity
25495 -- denotes an elaboration target.
25497 if Is_Elaboration_Target (E) then
25498 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25501 -- For OFF case, make entry in warnings off
25502 -- pragma table for later processing. But we do
25503 -- not do that within an instance, since these
25504 -- warnings are about what is needed in the
25505 -- template, not an instance of it.
25507 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25508 and then Warn_On_Warnings_Off
25509 and then not In_Instance
25511 Warnings_Off_Pragmas.Append ((N, E, Reason));
25514 if Is_Enumeration_Type (E) then
25518 Lit := First_Literal (E);
25519 while Present (Lit) loop
25520 Set_Warnings_Off (Lit);
25521 Next_Literal (Lit);
25526 exit when No (Homonym (E));
25531 -- Error if not entity or static string expression case
25533 elsif not Is_Static_String_Expression (Arg2) then
25535 ("second argument of pragma% must be entity name "
25536 & "or static string expression", Arg2);
25538 -- Static string expression case
25541 Acquire_Warning_Match_String (Arg2);
25543 -- Note on configuration pragma case: If this is a
25544 -- configuration pragma, then for an OFF pragma, we
25545 -- just set Config True in the call, which is all
25546 -- that needs to be done. For the case of ON, this
25547 -- is normally an error, unless it is canceling the
25548 -- effect of a previous OFF pragma in the same file.
25549 -- In any other case, an error will be signalled (ON
25550 -- with no matching OFF).
25552 -- Note: We set Used if we are inside a generic to
25553 -- disable the test that the non-config case actually
25554 -- cancels a warning. That's because we can't be sure
25555 -- there isn't an instantiation in some other unit
25556 -- where a warning is suppressed.
25558 -- We could do a little better here by checking if the
25559 -- generic unit we are inside is public, but for now
25560 -- we don't bother with that refinement.
25562 if Chars (Argx) = Name_Off then
25563 Set_Specific_Warning_Off
25564 (Loc, Name_Buffer (1 .. Name_Len), Reason,
25565 Config => Is_Configuration_Pragma,
25566 Used => Inside_A_Generic or else In_Instance);
25568 elsif Chars (Argx) = Name_On then
25569 Set_Specific_Warning_On
25570 (Loc, Name_Buffer (1 .. Name_Len), Err);
25574 ("??pragma Warnings On with no matching "
25575 & "Warnings Off", Loc);
25584 -------------------
25585 -- Weak_External --
25586 -------------------
25588 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25590 when Pragma_Weak_External => Weak_External : declare
25595 Check_Arg_Count (1);
25596 Check_Optional_Identifier (Arg1, Name_Entity);
25597 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25598 Ent := Entity (Get_Pragma_Arg (Arg1));
25600 if Rep_Item_Too_Early (Ent, N) then
25603 Ent := Underlying_Type (Ent);
25606 -- The only processing required is to link this item on to the
25607 -- list of rep items for the given entity. This is accomplished
25608 -- by the call to Rep_Item_Too_Late (when no error is detected
25609 -- and False is returned).
25611 if Rep_Item_Too_Late (Ent, N) then
25614 Set_Has_Gigi_Rep_Item (Ent);
25618 -----------------------------
25619 -- Wide_Character_Encoding --
25620 -----------------------------
25622 -- pragma Wide_Character_Encoding (IDENTIFIER);
25624 when Pragma_Wide_Character_Encoding =>
25627 -- Nothing to do, handled in parser. Note that we do not enforce
25628 -- configuration pragma placement, this pragma can appear at any
25629 -- place in the source, allowing mixed encodings within a single
25634 --------------------
25635 -- Unknown_Pragma --
25636 --------------------
25638 -- Should be impossible, since the case of an unknown pragma is
25639 -- separately processed before the case statement is entered.
25641 when Unknown_Pragma =>
25642 raise Program_Error;
25645 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25646 -- until AI is formally approved.
25648 -- Check_Order_Dependence;
25651 when Pragma_Exit => null;
25652 end Analyze_Pragma;
25654 ---------------------------------------------
25655 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25656 ---------------------------------------------
25658 -- WARNING: This routine manages Ghost regions. Return statements must be
25659 -- replaced by gotos which jump to the end of the routine and restore the
25662 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25664 Freeze_Id : Entity_Id := Empty)
25666 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25667 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25669 Disp_Typ : Entity_Id;
25670 -- The dispatching type of the subprogram subject to the pre- or
25673 function Check_References (Nod : Node_Id) return Traverse_Result;
25674 -- Check that expression Nod does not mention non-primitives of the
25675 -- type, global objects of the type, or other illegalities described
25676 -- and implied by AI12-0113.
25678 ----------------------
25679 -- Check_References --
25680 ----------------------
25682 function Check_References (Nod : Node_Id) return Traverse_Result is
25684 if Nkind (Nod) = N_Function_Call
25685 and then Is_Entity_Name (Name (Nod))
25688 Func : constant Entity_Id := Entity (Name (Nod));
25692 -- An operation of the type must be a primitive
25694 if No (Find_Dispatching_Type (Func)) then
25695 Form := First_Formal (Func);
25696 while Present (Form) loop
25697 if Etype (Form) = Disp_Typ then
25699 ("operation in class-wide condition must be "
25700 & "primitive of &", Nod, Disp_Typ);
25703 Next_Formal (Form);
25706 -- A return object of the type is illegal as well
25708 if Etype (Func) = Disp_Typ
25709 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25712 ("operation in class-wide condition must be primitive "
25713 & "of &", Nod, Disp_Typ);
25716 -- Otherwise we have a call to an overridden primitive, and we
25717 -- will create a common class-wide clone for the body of
25718 -- original operation and its eventual inherited versions. If
25719 -- the original operation dispatches on result it is never
25720 -- inherited and there is no need for a clone. There is not
25721 -- need for a clone either in GNATprove mode, as cases that
25722 -- would require it are rejected (when an inherited primitive
25723 -- calls an overridden operation in a class-wide contract), and
25724 -- the clone would make proof impossible in some cases.
25726 elsif not Is_Abstract_Subprogram (Spec_Id)
25727 and then No (Class_Wide_Clone (Spec_Id))
25728 and then not Has_Controlling_Result (Spec_Id)
25729 and then not GNATprove_Mode
25731 Build_Class_Wide_Clone_Decl (Spec_Id);
25735 elsif Is_Entity_Name (Nod)
25737 (Etype (Nod) = Disp_Typ
25738 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25739 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25742 ("object in class-wide condition must be formal of type &",
25745 elsif Nkind (Nod) = N_Explicit_Dereference
25746 and then (Etype (Nod) = Disp_Typ
25747 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25748 and then (not Is_Entity_Name (Prefix (Nod))
25749 or else not Is_Formal (Entity (Prefix (Nod))))
25752 ("operation in class-wide condition must be primitive of &",
25757 end Check_References;
25759 procedure Check_Class_Wide_Condition is
25760 new Traverse_Proc (Check_References);
25764 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25766 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25767 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25768 -- Save the Ghost-related attributes to restore on exit
25771 Restore_Scope : Boolean := False;
25773 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25776 -- Do not analyze the pragma multiple times
25778 if Is_Analyzed_Pragma (N) then
25782 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25783 -- analysis of the pragma, the Ghost mode at point of declaration and
25784 -- point of analysis may not necessarily be the same. Use the mode in
25785 -- effect at the point of declaration.
25787 Set_Ghost_Mode (N);
25789 -- Ensure that the subprogram and its formals are visible when analyzing
25790 -- the expression of the pragma.
25792 if not In_Open_Scopes (Spec_Id) then
25793 Restore_Scope := True;
25794 Push_Scope (Spec_Id);
25796 if Is_Generic_Subprogram (Spec_Id) then
25797 Install_Generic_Formals (Spec_Id);
25799 Install_Formals (Spec_Id);
25803 Errors := Serious_Errors_Detected;
25804 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25806 -- Emit a clarification message when the expression contains at least
25807 -- one undefined reference, possibly due to contract freezing.
25809 if Errors /= Serious_Errors_Detected
25810 and then Present (Freeze_Id)
25811 and then Has_Undefined_Reference (Expr)
25813 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25816 if Class_Present (N) then
25818 -- Verify that a class-wide condition is legal, i.e. the operation is
25819 -- a primitive of a tagged type. Note that a generic subprogram is
25820 -- not a primitive operation.
25822 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25824 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25825 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25827 if From_Aspect_Specification (N) then
25829 ("aspect % can only be specified for a primitive operation "
25830 & "of a tagged type", Corresponding_Aspect (N));
25832 -- The pragma is a source construct
25836 ("pragma % can only be specified for a primitive operation "
25837 & "of a tagged type", N);
25840 -- Remaining semantic checks require a full tree traversal
25843 Check_Class_Wide_Condition (Expr);
25848 if Restore_Scope then
25852 -- If analysis of the condition indicates that a class-wide clone
25853 -- has been created, build and analyze its declaration.
25855 if Is_Subprogram (Spec_Id)
25856 and then Present (Class_Wide_Clone (Spec_Id))
25858 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25861 -- Currently it is not possible to inline pre/postconditions on a
25862 -- subprogram subject to pragma Inline_Always.
25864 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25865 Set_Is_Analyzed_Pragma (N);
25867 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25868 end Analyze_Pre_Post_Condition_In_Decl_Part;
25870 ------------------------------------------
25871 -- Analyze_Refined_Depends_In_Decl_Part --
25872 ------------------------------------------
25874 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25875 procedure Check_Dependency_Clause
25876 (Spec_Id : Entity_Id;
25877 Dep_Clause : Node_Id;
25878 Dep_States : Elist_Id;
25879 Refinements : List_Id;
25880 Matched_Items : in out Elist_Id);
25881 -- Try to match a single dependency clause Dep_Clause against one or
25882 -- more refinement clauses found in list Refinements. Each successful
25883 -- match eliminates at least one refinement clause from Refinements.
25884 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25885 -- denotes the entities of all abstract states which appear in pragma
25886 -- Depends. Matched_Items contains the entities of all successfully
25887 -- matched items found in pragma Depends.
25889 procedure Check_Output_States
25890 (Spec_Id : Entity_Id;
25891 Spec_Inputs : Elist_Id;
25892 Spec_Outputs : Elist_Id;
25893 Body_Inputs : Elist_Id;
25894 Body_Outputs : Elist_Id);
25895 -- Determine whether pragma Depends contains an output state with a
25896 -- visible refinement and if so, ensure that pragma Refined_Depends
25897 -- mentions all its constituents as outputs. Spec_Id is the entity of
25898 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25899 -- inputs and outputs of the subprogram spec synthesized from pragma
25900 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25901 -- of the subprogram body synthesized from pragma Refined_Depends.
25903 function Collect_States (Clauses : List_Id) return Elist_Id;
25904 -- Given a normalized list of dependencies obtained from calling
25905 -- Normalize_Clauses, return a list containing the entities of all
25906 -- states appearing in dependencies. It helps in checking refinements
25907 -- involving a state and a corresponding constituent which is not a
25908 -- direct constituent of the state.
25910 procedure Normalize_Clauses (Clauses : List_Id);
25911 -- Given a list of dependence or refinement clauses Clauses, normalize
25912 -- each clause by creating multiple dependencies with exactly one input
25915 procedure Remove_Extra_Clauses
25916 (Clauses : List_Id;
25917 Matched_Items : Elist_Id);
25918 -- Given a list of refinement clauses Clauses, remove all clauses whose
25919 -- inputs and/or outputs have been previously matched. See the body for
25920 -- all special cases. Matched_Items contains the entities of all matched
25921 -- items found in pragma Depends.
25923 procedure Report_Extra_Clauses
25924 (Spec_Id : Entity_Id;
25925 Clauses : List_Id);
25926 -- Emit an error for each extra clause found in list Clauses. Spec_Id
25927 -- denotes the entity of the related subprogram.
25929 -----------------------------
25930 -- Check_Dependency_Clause --
25931 -----------------------------
25933 procedure Check_Dependency_Clause
25934 (Spec_Id : Entity_Id;
25935 Dep_Clause : Node_Id;
25936 Dep_States : Elist_Id;
25937 Refinements : List_Id;
25938 Matched_Items : in out Elist_Id)
25940 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25941 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25943 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25944 -- Determine whether dependency item Dep_Item has been matched in a
25945 -- previous clause.
25947 function Is_In_Out_State_Clause return Boolean;
25948 -- Determine whether dependence clause Dep_Clause denotes an abstract
25949 -- state that depends on itself (State => State).
25951 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25952 -- Determine whether item Item denotes an abstract state with visible
25953 -- null refinement.
25955 procedure Match_Items
25956 (Dep_Item : Node_Id;
25957 Ref_Item : Node_Id;
25958 Matched : out Boolean);
25959 -- Try to match dependence item Dep_Item against refinement item
25960 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25961 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25962 -- the following conformance scenarios is in effect:
25963 -- 1) Both items denote null
25964 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25965 -- 3) Both items denote attribute 'Result
25966 -- 4) Both items denote the same object
25967 -- 5) Both items denote the same formal parameter
25968 -- 6) Both items denote the same current instance of a type
25969 -- 7) Both items denote the same discriminant
25970 -- 8) Dep_Item is an abstract state with visible null refinement
25971 -- and Ref_Item denotes null.
25972 -- 9) Dep_Item is an abstract state with visible null refinement
25973 -- and Ref_Item is Empty (special case).
25974 -- 10) Dep_Item is an abstract state with full or partial visible
25975 -- non-null refinement and Ref_Item denotes one of its
25977 -- 11) Dep_Item is an abstract state without a full visible
25978 -- refinement and Ref_Item denotes the same state.
25979 -- When scenario 10 is in effect, the entity of the abstract state
25980 -- denoted by Dep_Item is added to list Refined_States.
25982 procedure Record_Item
(Item_Id
: Entity_Id
);
25983 -- Store the entity of an item denoted by Item_Id in Matched_Items
25985 ------------------------
25986 -- Is_Already_Matched --
25987 ------------------------
25989 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
25990 Item_Id
: Entity_Id
:= Empty
;
25993 -- When the dependency item denotes attribute 'Result, check for
25994 -- the entity of the related subprogram.
25996 if Is_Attribute_Result
(Dep_Item
) then
25997 Item_Id
:= Spec_Id
;
25999 elsif Is_Entity_Name
(Dep_Item
) then
26000 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26004 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
26005 end Is_Already_Matched
;
26007 ----------------------------
26008 -- Is_In_Out_State_Clause --
26009 ----------------------------
26011 function Is_In_Out_State_Clause
return Boolean is
26012 Dep_Input_Id
: Entity_Id
;
26013 Dep_Output_Id
: Entity_Id
;
26016 -- Detect the following clause:
26019 if Is_Entity_Name
(Dep_Input
)
26020 and then Is_Entity_Name
(Dep_Output
)
26022 -- Handle abstract views generated for limited with clauses
26024 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
26025 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
26028 Ekind
(Dep_Input_Id
) = E_Abstract_State
26029 and then Dep_Input_Id
= Dep_Output_Id
;
26033 end Is_In_Out_State_Clause
;
26035 ---------------------------
26036 -- Is_Null_Refined_State --
26037 ---------------------------
26039 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
26040 Item_Id
: Entity_Id
;
26043 if Is_Entity_Name
(Item
) then
26045 -- Handle abstract views generated for limited with clauses
26047 Item_Id
:= Available_View
(Entity_Of
(Item
));
26050 Ekind
(Item_Id
) = E_Abstract_State
26051 and then Has_Null_Visible_Refinement
(Item_Id
);
26055 end Is_Null_Refined_State
;
26061 procedure Match_Items
26062 (Dep_Item
: Node_Id
;
26063 Ref_Item
: Node_Id
;
26064 Matched
: out Boolean)
26066 Dep_Item_Id
: Entity_Id
;
26067 Ref_Item_Id
: Entity_Id
;
26070 -- Assume that the two items do not match
26074 -- A null matches null or Empty (special case)
26076 if Nkind
(Dep_Item
) = N_Null
26077 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26081 -- Attribute 'Result matches attribute 'Result
26083 elsif Is_Attribute_Result
(Dep_Item
)
26084 and then Is_Attribute_Result
(Ref_Item
)
26086 -- Put the entity of the related function on the list of
26087 -- matched items because attribute 'Result does not carry
26088 -- an entity similar to states and constituents.
26090 Record_Item
(Spec_Id
);
26093 -- Abstract states, current instances of concurrent types,
26094 -- discriminants, formal parameters and objects.
26096 elsif Is_Entity_Name
(Dep_Item
) then
26098 -- Handle abstract views generated for limited with clauses
26100 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26102 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
26104 -- An abstract state with visible null refinement matches
26105 -- null or Empty (special case).
26107 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
26108 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26110 Record_Item
(Dep_Item_Id
);
26113 -- An abstract state with visible non-null refinement
26114 -- matches one of its constituents, or itself for an
26115 -- abstract state with partial visible refinement.
26117 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
26118 if Is_Entity_Name
(Ref_Item
) then
26119 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
26121 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
26124 and then Present
(Encapsulating_State
(Ref_Item_Id
))
26125 and then Find_Encapsulating_State
26126 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
26128 Record_Item
(Dep_Item_Id
);
26131 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
26132 and then Ref_Item_Id
= Dep_Item_Id
26134 Record_Item
(Dep_Item_Id
);
26139 -- An abstract state without a visible refinement matches
26142 elsif Is_Entity_Name
(Ref_Item
)
26143 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26145 Record_Item
(Dep_Item_Id
);
26149 -- A current instance of a concurrent type, discriminant,
26150 -- formal parameter or an object matches itself.
26152 elsif Is_Entity_Name
(Ref_Item
)
26153 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26155 Record_Item
(Dep_Item_Id
);
26165 procedure Record_Item
(Item_Id
: Entity_Id
) is
26167 if No
(Matched_Items
) then
26168 Matched_Items
:= New_Elmt_List
;
26171 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
26176 Clause_Matched
: Boolean := False;
26177 Dummy
: Boolean := False;
26178 Inputs_Match
: Boolean;
26179 Next_Ref_Clause
: Node_Id
;
26180 Outputs_Match
: Boolean;
26181 Ref_Clause
: Node_Id
;
26182 Ref_Input
: Node_Id
;
26183 Ref_Output
: Node_Id
;
26185 -- Start of processing for Check_Dependency_Clause
26188 -- Do not perform this check in an instance because it was already
26189 -- performed successfully in the generic template.
26191 if Is_Generic_Instance
(Spec_Id
) then
26195 -- Examine all refinement clauses and compare them against the
26196 -- dependence clause.
26198 Ref_Clause
:= First
(Refinements
);
26199 while Present
(Ref_Clause
) loop
26200 Next_Ref_Clause
:= Next
(Ref_Clause
);
26202 -- Obtain the attributes of the current refinement clause
26204 Ref_Input
:= Expression
(Ref_Clause
);
26205 Ref_Output
:= First
(Choices
(Ref_Clause
));
26207 -- The current refinement clause matches the dependence clause
26208 -- when both outputs match and both inputs match. See routine
26209 -- Match_Items for all possible conformance scenarios.
26211 -- Depends Dep_Output => Dep_Input
26215 -- Refined_Depends Ref_Output => Ref_Input
26218 (Dep_Item
=> Dep_Input
,
26219 Ref_Item
=> Ref_Input
,
26220 Matched
=> Inputs_Match
);
26223 (Dep_Item
=> Dep_Output
,
26224 Ref_Item
=> Ref_Output
,
26225 Matched
=> Outputs_Match
);
26227 -- An In_Out state clause may be matched against a refinement with
26228 -- a null input or null output as long as the non-null side of the
26229 -- relation contains a valid constituent of the In_Out_State.
26231 if Is_In_Out_State_Clause
then
26233 -- Depends => (State => State)
26234 -- Refined_Depends => (null => Constit) -- OK
26237 and then not Outputs_Match
26238 and then Nkind
(Ref_Output
) = N_Null
26240 Outputs_Match
:= True;
26243 -- Depends => (State => State)
26244 -- Refined_Depends => (Constit => null) -- OK
26246 if not Inputs_Match
26247 and then Outputs_Match
26248 and then Nkind
(Ref_Input
) = N_Null
26250 Inputs_Match
:= True;
26254 -- The current refinement clause is legally constructed following
26255 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26256 -- the pool of candidates. The seach continues because a single
26257 -- dependence clause may have multiple matching refinements.
26259 if Inputs_Match
and Outputs_Match
then
26260 Clause_Matched
:= True;
26261 Remove
(Ref_Clause
);
26264 Ref_Clause
:= Next_Ref_Clause
;
26267 -- Depending on the order or composition of refinement clauses, an
26268 -- In_Out state clause may not be directly refinable.
26270 -- Refined_State => (State => (Constit_1, Constit_2))
26271 -- Depends => ((Output, State) => (Input, State))
26272 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26274 -- Matching normalized clause (State => State) fails because there is
26275 -- no direct refinement capable of satisfying this relation. Another
26276 -- similar case arises when clauses (Constit_1 => Input) and (Output
26277 -- => Constit_2) are matched first, leaving no candidates for clause
26278 -- (State => State). Both scenarios are legal as long as one of the
26279 -- previous clauses mentioned a valid constituent of State.
26281 if not Clause_Matched
26282 and then Is_In_Out_State_Clause
26283 and then Is_Already_Matched
(Dep_Input
)
26285 Clause_Matched
:= True;
26288 -- A clause where the input is an abstract state with visible null
26289 -- refinement or a 'Result attribute is implicitly matched when the
26290 -- output has already been matched in a previous clause.
26292 -- Refined_State => (State => null)
26293 -- Depends => (Output => State) -- implicitly OK
26294 -- Refined_Depends => (Output => ...)
26295 -- Depends => (...'Result => State) -- implicitly OK
26296 -- Refined_Depends => (...'Result => ...)
26298 if not Clause_Matched
26299 and then Is_Null_Refined_State
(Dep_Input
)
26300 and then Is_Already_Matched
(Dep_Output
)
26302 Clause_Matched
:= True;
26305 -- A clause where the output is an abstract state with visible null
26306 -- refinement is implicitly matched when the input has already been
26307 -- matched in a previous clause.
26309 -- Refined_State => (State => null)
26310 -- Depends => (State => Input) -- implicitly OK
26311 -- Refined_Depends => (... => Input)
26313 if not Clause_Matched
26314 and then Is_Null_Refined_State
(Dep_Output
)
26315 and then Is_Already_Matched
(Dep_Input
)
26317 Clause_Matched
:= True;
26320 -- At this point either all refinement clauses have been examined or
26321 -- pragma Refined_Depends contains a solitary null. Only an abstract
26322 -- state with null refinement can possibly match these cases.
26324 -- Refined_State => (State => null)
26325 -- Depends => (State => null)
26326 -- Refined_Depends => null -- OK
26328 if not Clause_Matched
then
26330 (Dep_Item
=> Dep_Input
,
26332 Matched
=> Inputs_Match
);
26335 (Dep_Item
=> Dep_Output
,
26337 Matched
=> Outputs_Match
);
26339 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
26342 -- If the contents of Refined_Depends are legal, then the current
26343 -- dependence clause should be satisfied either by an explicit match
26344 -- or by one of the special cases.
26346 if not Clause_Matched
then
26348 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
26349 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
26351 end Check_Dependency_Clause
;
26353 -------------------------
26354 -- Check_Output_States --
26355 -------------------------
26357 procedure Check_Output_States
26358 (Spec_Id
: Entity_Id
;
26359 Spec_Inputs
: Elist_Id
;
26360 Spec_Outputs
: Elist_Id
;
26361 Body_Inputs
: Elist_Id
;
26362 Body_Outputs
: Elist_Id
)
26364 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26365 -- Determine whether all constituents of state State_Id with full
26366 -- visible refinement are used as outputs in pragma Refined_Depends.
26367 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26369 -----------------------------
26370 -- Check_Constituent_Usage --
26371 -----------------------------
26373 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26374 Constits
: constant Elist_Id
:=
26375 Partial_Refinement_Constituents
(State_Id
);
26376 Constit_Elmt
: Elmt_Id
;
26377 Constit_Id
: Entity_Id
;
26378 Only_Partial
: constant Boolean :=
26379 not Has_Visible_Refinement
(State_Id
);
26380 Posted
: Boolean := False;
26383 if Present
(Constits
) then
26384 Constit_Elmt
:= First_Elmt
(Constits
);
26385 while Present
(Constit_Elmt
) loop
26386 Constit_Id
:= Node
(Constit_Elmt
);
26388 -- Issue an error when a constituent of State_Id is used,
26389 -- and State_Id has only partial visible refinement
26390 -- (SPARK RM 7.2.4(3d)).
26392 if Only_Partial
then
26393 if (Present
(Body_Inputs
)
26394 and then Appears_In
(Body_Inputs
, Constit_Id
))
26396 (Present
(Body_Outputs
)
26397 and then Appears_In
(Body_Outputs
, Constit_Id
))
26399 Error_Msg_Name_1
:= Chars
(State_Id
);
26401 ("constituent & of state % cannot be used in "
26402 & "dependence refinement", N
, Constit_Id
);
26403 Error_Msg_Name_1
:= Chars
(State_Id
);
26404 SPARK_Msg_N
("\use state % instead", N
);
26407 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26409 elsif Present
(Body_Inputs
)
26410 and then Appears_In
(Body_Inputs
, Constit_Id
)
26412 Error_Msg_Name_1
:= Chars
(State_Id
);
26414 ("constituent & of state % must act as output in "
26415 & "dependence refinement", N
, Constit_Id
);
26417 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26419 elsif No
(Body_Outputs
)
26420 or else not Appears_In
(Body_Outputs
, Constit_Id
)
26425 ("output state & must be replaced by all its "
26426 & "constituents in dependence refinement",
26431 ("\constituent & is missing in output list",
26435 Next_Elmt
(Constit_Elmt
);
26438 end Check_Constituent_Usage
;
26443 Item_Elmt
: Elmt_Id
;
26444 Item_Id
: Entity_Id
;
26446 -- Start of processing for Check_Output_States
26449 -- Do not perform this check in an instance because it was already
26450 -- performed successfully in the generic template.
26452 if Is_Generic_Instance
(Spec_Id
) then
26455 -- Inspect the outputs of pragma Depends looking for a state with a
26456 -- visible refinement.
26458 elsif Present
(Spec_Outputs
) then
26459 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
26460 while Present
(Item_Elmt
) loop
26461 Item
:= Node
(Item_Elmt
);
26463 -- Deal with the mixed nature of the input and output lists
26465 if Nkind
(Item
) = N_Defining_Identifier
then
26468 Item_Id
:= Available_View
(Entity_Of
(Item
));
26471 if Ekind
(Item_Id
) = E_Abstract_State
then
26473 -- The state acts as an input-output, skip it
26475 if Present
(Spec_Inputs
)
26476 and then Appears_In
(Spec_Inputs
, Item_Id
)
26480 -- Ensure that all of the constituents are utilized as
26481 -- outputs in pragma Refined_Depends.
26483 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26484 Check_Constituent_Usage
(Item_Id
);
26488 Next_Elmt
(Item_Elmt
);
26491 end Check_Output_States
;
26493 --------------------
26494 -- Collect_States --
26495 --------------------
26497 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
26498 procedure Collect_State
26500 States
: in out Elist_Id
);
26501 -- Add the entity of Item to list States when it denotes to a state
26503 -------------------
26504 -- Collect_State --
26505 -------------------
26507 procedure Collect_State
26509 States
: in out Elist_Id
)
26514 if Is_Entity_Name
(Item
) then
26515 Id
:= Entity_Of
(Item
);
26517 if Ekind
(Id
) = E_Abstract_State
then
26518 if No
(States
) then
26519 States
:= New_Elmt_List
;
26522 Append_Unique_Elmt
(Id
, States
);
26532 States
: Elist_Id
:= No_Elist
;
26534 -- Start of processing for Collect_States
26537 Clause
:= First
(Clauses
);
26538 while Present
(Clause
) loop
26539 Input
:= Expression
(Clause
);
26540 Output
:= First
(Choices
(Clause
));
26542 Collect_State
(Input
, States
);
26543 Collect_State
(Output
, States
);
26549 end Collect_States
;
26551 -----------------------
26552 -- Normalize_Clauses --
26553 -----------------------
26555 procedure Normalize_Clauses
(Clauses
: List_Id
) is
26556 procedure Normalize_Inputs
(Clause
: Node_Id
);
26557 -- Normalize clause Clause by creating multiple clauses for each
26558 -- input item of Clause. It is assumed that Clause has exactly one
26559 -- output. The transformation is as follows:
26561 -- Output => (Input_1, Input_2) -- original
26563 -- Output => Input_1 -- normalizations
26564 -- Output => Input_2
26566 procedure Normalize_Outputs
(Clause
: Node_Id
);
26567 -- Normalize clause Clause by creating multiple clause for each
26568 -- output item of Clause. The transformation is as follows:
26570 -- (Output_1, Output_2) => Input -- original
26572 -- Output_1 => Input -- normalization
26573 -- Output_2 => Input
26575 ----------------------
26576 -- Normalize_Inputs --
26577 ----------------------
26579 procedure Normalize_Inputs
(Clause
: Node_Id
) is
26580 Inputs
: constant Node_Id
:= Expression
(Clause
);
26581 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26582 Output
: constant List_Id
:= Choices
(Clause
);
26583 Last_Input
: Node_Id
;
26585 New_Clause
: Node_Id
;
26586 Next_Input
: Node_Id
;
26589 -- Normalization is performed only when the original clause has
26590 -- more than one input. Multiple inputs appear as an aggregate.
26592 if Nkind
(Inputs
) = N_Aggregate
then
26593 Last_Input
:= Last
(Expressions
(Inputs
));
26595 -- Create a new clause for each input
26597 Input
:= First
(Expressions
(Inputs
));
26598 while Present
(Input
) loop
26599 Next_Input
:= Next
(Input
);
26601 -- Unhook the current input from the original input list
26602 -- because it will be relocated to a new clause.
26606 -- Special processing for the last input. At this point the
26607 -- original aggregate has been stripped down to one element.
26608 -- Replace the aggregate by the element itself.
26610 if Input
= Last_Input
then
26611 Rewrite
(Inputs
, Input
);
26613 -- Generate a clause of the form:
26618 Make_Component_Association
(Loc
,
26619 Choices
=> New_Copy_List_Tree
(Output
),
26620 Expression
=> Input
);
26622 -- The new clause contains replicated content that has
26623 -- already been analyzed, mark the clause as analyzed.
26625 Set_Analyzed
(New_Clause
);
26626 Insert_After
(Clause
, New_Clause
);
26629 Input
:= Next_Input
;
26632 end Normalize_Inputs
;
26634 -----------------------
26635 -- Normalize_Outputs --
26636 -----------------------
26638 procedure Normalize_Outputs
(Clause
: Node_Id
) is
26639 Inputs
: constant Node_Id
:= Expression
(Clause
);
26640 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26641 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
26642 Last_Output
: Node_Id
;
26643 New_Clause
: Node_Id
;
26644 Next_Output
: Node_Id
;
26648 -- Multiple outputs appear as an aggregate. Nothing to do when
26649 -- the clause has exactly one output.
26651 if Nkind
(Outputs
) = N_Aggregate
then
26652 Last_Output
:= Last
(Expressions
(Outputs
));
26654 -- Create a clause for each output. Note that each time a new
26655 -- clause is created, the original output list slowly shrinks
26656 -- until there is one item left.
26658 Output
:= First
(Expressions
(Outputs
));
26659 while Present
(Output
) loop
26660 Next_Output
:= Next
(Output
);
26662 -- Unhook the output from the original output list as it
26663 -- will be relocated to a new clause.
26667 -- Special processing for the last output. At this point
26668 -- the original aggregate has been stripped down to one
26669 -- element. Replace the aggregate by the element itself.
26671 if Output
= Last_Output
then
26672 Rewrite
(Outputs
, Output
);
26675 -- Generate a clause of the form:
26676 -- (Output => Inputs)
26679 Make_Component_Association
(Loc
,
26680 Choices
=> New_List
(Output
),
26681 Expression
=> New_Copy_Tree
(Inputs
));
26683 -- The new clause contains replicated content that has
26684 -- already been analyzed. There is not need to reanalyze
26687 Set_Analyzed
(New_Clause
);
26688 Insert_After
(Clause
, New_Clause
);
26691 Output
:= Next_Output
;
26694 end Normalize_Outputs
;
26700 -- Start of processing for Normalize_Clauses
26703 Clause
:= First
(Clauses
);
26704 while Present
(Clause
) loop
26705 Normalize_Outputs
(Clause
);
26709 Clause
:= First
(Clauses
);
26710 while Present
(Clause
) loop
26711 Normalize_Inputs
(Clause
);
26714 end Normalize_Clauses
;
26716 --------------------------
26717 -- Remove_Extra_Clauses --
26718 --------------------------
26720 procedure Remove_Extra_Clauses
26721 (Clauses
: List_Id
;
26722 Matched_Items
: Elist_Id
)
26726 Input_Id
: Entity_Id
;
26727 Next_Clause
: Node_Id
;
26729 State_Id
: Entity_Id
;
26732 Clause
:= First
(Clauses
);
26733 while Present
(Clause
) loop
26734 Next_Clause
:= Next
(Clause
);
26736 Input
:= Expression
(Clause
);
26737 Output
:= First
(Choices
(Clause
));
26739 -- Recognize a clause of the form
26743 -- where Input is a constituent of a state which was already
26744 -- successfully matched. This clause must be removed because it
26745 -- simply indicates that some of the constituents of the state
26748 -- Refined_State => (State => (Constit_1, Constit_2))
26749 -- Depends => (Output => State)
26750 -- Refined_Depends => ((Output => Constit_1), -- State matched
26751 -- (null => Constit_2)) -- OK
26753 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
26755 -- Handle abstract views generated for limited with clauses
26757 Input_Id
:= Available_View
(Entity_Of
(Input
));
26759 -- The input must be a constituent of a state
26761 if Ekind_In
(Input_Id
, E_Abstract_State
,
26764 and then Present
(Encapsulating_State
(Input_Id
))
26766 State_Id
:= Encapsulating_State
(Input_Id
);
26768 -- The state must have a non-null visible refinement and be
26769 -- matched in a previous clause.
26771 if Has_Non_Null_Visible_Refinement
(State_Id
)
26772 and then Contains
(Matched_Items
, State_Id
)
26778 -- Recognize a clause of the form
26782 -- where Output is an arbitrary item. This clause must be removed
26783 -- because a null input legitimately matches anything.
26785 elsif Nkind
(Input
) = N_Null
then
26789 Clause
:= Next_Clause
;
26791 end Remove_Extra_Clauses
;
26793 --------------------------
26794 -- Report_Extra_Clauses --
26795 --------------------------
26797 procedure Report_Extra_Clauses
26798 (Spec_Id
: Entity_Id
;
26804 -- Do not perform this check in an instance because it was already
26805 -- performed successfully in the generic template.
26807 if Is_Generic_Instance
(Spec_Id
) then
26810 elsif Present
(Clauses
) then
26811 Clause
:= First
(Clauses
);
26812 while Present
(Clause
) loop
26814 ("unmatched or extra clause in dependence refinement",
26820 end Report_Extra_Clauses
;
26824 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26825 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26826 Errors
: constant Nat
:= Serious_Errors_Detected
;
26833 Body_Inputs
: Elist_Id
:= No_Elist
;
26834 Body_Outputs
: Elist_Id
:= No_Elist
;
26835 -- The inputs and outputs of the subprogram body synthesized from pragma
26836 -- Refined_Depends.
26838 Dependencies
: List_Id
:= No_List
;
26840 -- The corresponding Depends pragma along with its clauses
26842 Matched_Items
: Elist_Id
:= No_Elist
;
26843 -- A list containing the entities of all successfully matched items
26844 -- found in pragma Depends.
26846 Refinements
: List_Id
:= No_List
;
26847 -- The clauses of pragma Refined_Depends
26849 Spec_Id
: Entity_Id
;
26850 -- The entity of the subprogram subject to pragma Refined_Depends
26852 Spec_Inputs
: Elist_Id
:= No_Elist
;
26853 Spec_Outputs
: Elist_Id
:= No_Elist
;
26854 -- The inputs and outputs of the subprogram spec synthesized from pragma
26857 States
: Elist_Id
:= No_Elist
;
26858 -- A list containing the entities of all states whose constituents
26859 -- appear in pragma Depends.
26861 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26864 -- Do not analyze the pragma multiple times
26866 if Is_Analyzed_Pragma
(N
) then
26870 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26872 -- Use the anonymous object as the proper spec when Refined_Depends
26873 -- applies to the body of a single task type. The object carries the
26874 -- proper Chars as well as all non-refined versions of pragmas.
26876 if Is_Single_Concurrent_Type
(Spec_Id
) then
26877 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26880 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26882 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26883 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26885 if No
(Depends
) then
26887 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26888 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
26892 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26894 -- A null dependency relation renders the refinement useless because it
26895 -- cannot possibly mention abstract states with visible refinement. Note
26896 -- that the inverse is not true as states may be refined to null
26897 -- (SPARK RM 7.2.5(2)).
26899 if Nkind
(Deps
) = N_Null
then
26901 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26902 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
26906 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26907 -- This ensures that the categorization of all refined dependency items
26908 -- is consistent with their role.
26910 Analyze_Depends_In_Decl_Part
(N
);
26912 -- Do not match dependencies against refinements if Refined_Depends is
26913 -- illegal to avoid emitting misleading error.
26915 if Serious_Errors_Detected
= Errors
then
26917 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26918 -- the inputs and outputs of the subprogram spec and body to verify
26919 -- the use of states with visible refinement and their constituents.
26921 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
26922 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
26924 Collect_Subprogram_Inputs_Outputs
26925 (Subp_Id
=> Spec_Id
,
26926 Synthesize
=> True,
26927 Subp_Inputs
=> Spec_Inputs
,
26928 Subp_Outputs
=> Spec_Outputs
,
26929 Global_Seen
=> Dummy
);
26931 Collect_Subprogram_Inputs_Outputs
26932 (Subp_Id
=> Body_Id
,
26933 Synthesize
=> True,
26934 Subp_Inputs
=> Body_Inputs
,
26935 Subp_Outputs
=> Body_Outputs
,
26936 Global_Seen
=> Dummy
);
26938 -- For an output state with a visible refinement, ensure that all
26939 -- constituents appear as outputs in the dependency refinement.
26941 Check_Output_States
26942 (Spec_Id
=> Spec_Id
,
26943 Spec_Inputs
=> Spec_Inputs
,
26944 Spec_Outputs
=> Spec_Outputs
,
26945 Body_Inputs
=> Body_Inputs
,
26946 Body_Outputs
=> Body_Outputs
);
26949 -- Matching is disabled in ASIS because clauses are not normalized as
26950 -- this is a tree altering activity similar to expansion.
26956 -- Multiple dependency clauses appear as component associations of an
26957 -- aggregate. Note that the clauses are copied because the algorithm
26958 -- modifies them and this should not be visible in Depends.
26960 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
26961 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
26962 Normalize_Clauses
(Dependencies
);
26964 -- Gather all states which appear in Depends
26966 States
:= Collect_States
(Dependencies
);
26968 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
26970 if Nkind
(Refs
) = N_Null
then
26971 Refinements
:= No_List
;
26973 -- Multiple dependency clauses appear as component associations of an
26974 -- aggregate. Note that the clauses are copied because the algorithm
26975 -- modifies them and this should not be visible in Refined_Depends.
26977 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
26978 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
26979 Normalize_Clauses
(Refinements
);
26982 -- At this point the clauses of pragmas Depends and Refined_Depends
26983 -- have been normalized into simple dependencies between one output
26984 -- and one input. Examine all clauses of pragma Depends looking for
26985 -- matching clauses in pragma Refined_Depends.
26987 Clause
:= First
(Dependencies
);
26988 while Present
(Clause
) loop
26989 Check_Dependency_Clause
26990 (Spec_Id
=> Spec_Id
,
26991 Dep_Clause
=> Clause
,
26992 Dep_States
=> States
,
26993 Refinements
=> Refinements
,
26994 Matched_Items
=> Matched_Items
);
26999 -- Pragma Refined_Depends may contain multiple clarification clauses
27000 -- which indicate that certain constituents do not influence the data
27001 -- flow in any way. Such clauses must be removed as long as the state
27002 -- has been matched, otherwise they will be incorrectly flagged as
27005 -- Refined_State => (State => (Constit_1, Constit_2))
27006 -- Depends => (Output => State)
27007 -- Refined_Depends => ((Output => Constit_1), -- State matched
27008 -- (null => Constit_2)) -- must be removed
27010 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
27012 if Serious_Errors_Detected
= Errors
then
27013 Report_Extra_Clauses
(Spec_Id
, Refinements
);
27018 Set_Is_Analyzed_Pragma
(N
);
27019 end Analyze_Refined_Depends_In_Decl_Part
;
27021 -----------------------------------------
27022 -- Analyze_Refined_Global_In_Decl_Part --
27023 -----------------------------------------
27025 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
27027 -- The corresponding Global pragma
27029 Has_In_State
: Boolean := False;
27030 Has_In_Out_State
: Boolean := False;
27031 Has_Out_State
: Boolean := False;
27032 Has_Proof_In_State
: Boolean := False;
27033 -- These flags are set when the corresponding Global pragma has a state
27034 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27037 Has_Null_State
: Boolean := False;
27038 -- This flag is set when the corresponding Global pragma has at least
27039 -- one state with a null refinement.
27041 In_Constits
: Elist_Id
:= No_Elist
;
27042 In_Out_Constits
: Elist_Id
:= No_Elist
;
27043 Out_Constits
: Elist_Id
:= No_Elist
;
27044 Proof_In_Constits
: Elist_Id
:= No_Elist
;
27045 -- These lists contain the entities of all Input, In_Out, Output and
27046 -- Proof_In constituents that appear in Refined_Global and participate
27047 -- in state refinement.
27049 In_Items
: Elist_Id
:= No_Elist
;
27050 In_Out_Items
: Elist_Id
:= No_Elist
;
27051 Out_Items
: Elist_Id
:= No_Elist
;
27052 Proof_In_Items
: Elist_Id
:= No_Elist
;
27053 -- These lists contain the entities of all Input, In_Out, Output and
27054 -- Proof_In items defined in the corresponding Global pragma.
27056 Repeat_Items
: Elist_Id
:= No_Elist
;
27057 -- A list of all global items without full visible refinement found
27058 -- in pragma Global. These states should be repeated in the global
27059 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27060 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27062 Spec_Id
: Entity_Id
;
27063 -- The entity of the subprogram subject to pragma Refined_Global
27065 States
: Elist_Id
:= No_Elist
;
27066 -- A list of all states with full or partial visible refinement found in
27069 procedure Check_In_Out_States
;
27070 -- Determine whether the corresponding Global pragma mentions In_Out
27071 -- states with visible refinement and if so, ensure that one of the
27072 -- following completions apply to the constituents of the state:
27073 -- 1) there is at least one constituent of mode In_Out
27074 -- 2) there is at least one Input and one Output constituent
27075 -- 3) not all constituents are present and one of them is of mode
27077 -- This routine may remove elements from In_Constits, In_Out_Constits,
27078 -- Out_Constits and Proof_In_Constits.
27080 procedure Check_Input_States
;
27081 -- Determine whether the corresponding Global pragma mentions Input
27082 -- states with visible refinement and if so, ensure that at least one of
27083 -- its constituents appears as an Input item in Refined_Global.
27084 -- This routine may remove elements from In_Constits, In_Out_Constits,
27085 -- Out_Constits and Proof_In_Constits.
27087 procedure Check_Output_States
;
27088 -- Determine whether the corresponding Global pragma mentions Output
27089 -- states with visible refinement and if so, ensure that all of its
27090 -- constituents appear as Output items in Refined_Global.
27091 -- This routine may remove elements from In_Constits, In_Out_Constits,
27092 -- Out_Constits and Proof_In_Constits.
27094 procedure Check_Proof_In_States
;
27095 -- Determine whether the corresponding Global pragma mentions Proof_In
27096 -- states with visible refinement and if so, ensure that at least one of
27097 -- its constituents appears as a Proof_In item in Refined_Global.
27098 -- This routine may remove elements from In_Constits, In_Out_Constits,
27099 -- Out_Constits and Proof_In_Constits.
27101 procedure Check_Refined_Global_List
27103 Global_Mode
: Name_Id
:= Name_Input
);
27104 -- Verify the legality of a single global list declaration. Global_Mode
27105 -- denotes the current mode in effect.
27107 procedure Collect_Global_Items
27109 Mode
: Name_Id
:= Name_Input
);
27110 -- Gather all Input, In_Out, Output and Proof_In items from node List
27111 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27112 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27113 -- and Has_Proof_In_State are set when there is at least one abstract
27114 -- state with full or partial visible refinement available in the
27115 -- corresponding mode. Flag Has_Null_State is set when at least state
27116 -- has a null refinement. Mode denotes the current global mode in
27119 function Present_Then_Remove
27121 Item
: Entity_Id
) return Boolean;
27122 -- Search List for a particular entity Item. If Item has been found,
27123 -- remove it from List. This routine is used to strip lists In_Constits,
27124 -- In_Out_Constits and Out_Constits of valid constituents.
27126 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
27127 -- Same as function Present_Then_Remove, but do not report the presence
27128 -- of Item in List.
27130 procedure Report_Extra_Constituents
;
27131 -- Emit an error for each constituent found in lists In_Constits,
27132 -- In_Out_Constits and Out_Constits.
27134 procedure Report_Missing_Items
;
27135 -- Emit an error for each global item not repeated found in list
27138 -------------------------
27139 -- Check_In_Out_States --
27140 -------------------------
27142 procedure Check_In_Out_States
is
27143 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27144 -- Determine whether one of the following coverage scenarios is in
27146 -- 1) there is at least one constituent of mode In_Out or Output
27147 -- 2) there is at least one pair of constituents with modes Input
27148 -- and Output, or Proof_In and Output.
27149 -- 3) there is at least one constituent of mode Output and not all
27150 -- constituents are present.
27151 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27153 -----------------------------
27154 -- Check_Constituent_Usage --
27155 -----------------------------
27157 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27158 Constits
: constant Elist_Id
:=
27159 Partial_Refinement_Constituents
(State_Id
);
27160 Constit_Elmt
: Elmt_Id
;
27161 Constit_Id
: Entity_Id
;
27162 Has_Missing
: Boolean := False;
27163 In_Out_Seen
: Boolean := False;
27164 Input_Seen
: Boolean := False;
27165 Output_Seen
: Boolean := False;
27166 Proof_In_Seen
: Boolean := False;
27169 -- Process all the constituents of the state and note their modes
27170 -- within the global refinement.
27172 if Present
(Constits
) then
27173 Constit_Elmt
:= First_Elmt
(Constits
);
27174 while Present
(Constit_Elmt
) loop
27175 Constit_Id
:= Node
(Constit_Elmt
);
27177 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27178 Input_Seen
:= True;
27180 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
27181 In_Out_Seen
:= True;
27183 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27184 Output_Seen
:= True;
27186 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27188 Proof_In_Seen
:= True;
27191 Has_Missing
:= True;
27194 Next_Elmt
(Constit_Elmt
);
27198 -- An In_Out constituent is a valid completion
27200 if In_Out_Seen
then
27203 -- A pair of one Input/Proof_In and one Output constituent is a
27204 -- valid completion.
27206 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
27209 elsif Output_Seen
then
27211 -- A single Output constituent is a valid completion only when
27212 -- some of the other constituents are missing.
27214 if Has_Missing
then
27217 -- Otherwise all constituents are of mode Output
27221 ("global refinement of state & must include at least one "
27222 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27226 -- The state lacks a completion. When full refinement is visible,
27227 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27228 -- refinement is visible, emit an error if the abstract state
27229 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27230 -- both are utilized, Check_State_And_Constituent_Use. will issue
27233 elsif not Input_Seen
27234 and then not In_Out_Seen
27235 and then not Output_Seen
27236 and then not Proof_In_Seen
27238 if Has_Visible_Refinement
(State_Id
)
27239 or else Contains
(Repeat_Items
, State_Id
)
27242 ("missing global refinement of state &", N
, State_Id
);
27245 -- Otherwise the state has a malformed completion where at least
27246 -- one of the constituents has a different mode.
27250 ("global refinement of state & redefines the mode of its "
27251 & "constituents", N
, State_Id
);
27253 end Check_Constituent_Usage
;
27257 Item_Elmt
: Elmt_Id
;
27258 Item_Id
: Entity_Id
;
27260 -- Start of processing for Check_In_Out_States
27263 -- Do not perform this check in an instance because it was already
27264 -- performed successfully in the generic template.
27266 if Is_Generic_Instance
(Spec_Id
) then
27269 -- Inspect the In_Out items of the corresponding Global pragma
27270 -- looking for a state with a visible refinement.
27272 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
27273 Item_Elmt
:= First_Elmt
(In_Out_Items
);
27274 while Present
(Item_Elmt
) loop
27275 Item_Id
:= Node
(Item_Elmt
);
27277 -- Ensure that one of the three coverage variants is satisfied
27279 if Ekind
(Item_Id
) = E_Abstract_State
27280 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27282 Check_Constituent_Usage
(Item_Id
);
27285 Next_Elmt
(Item_Elmt
);
27288 end Check_In_Out_States
;
27290 ------------------------
27291 -- Check_Input_States --
27292 ------------------------
27294 procedure Check_Input_States
is
27295 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27296 -- Determine whether at least one constituent of state State_Id with
27297 -- full or partial visible refinement is used and has mode Input.
27298 -- Ensure that the remaining constituents do not have In_Out or
27299 -- Output modes. Emit an error if this is not the case
27300 -- (SPARK RM 7.2.4(5)).
27302 -----------------------------
27303 -- Check_Constituent_Usage --
27304 -----------------------------
27306 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27307 Constits
: constant Elist_Id
:=
27308 Partial_Refinement_Constituents
(State_Id
);
27309 Constit_Elmt
: Elmt_Id
;
27310 Constit_Id
: Entity_Id
;
27311 In_Seen
: Boolean := False;
27314 if Present
(Constits
) then
27315 Constit_Elmt
:= First_Elmt
(Constits
);
27316 while Present
(Constit_Elmt
) loop
27317 Constit_Id
:= Node
(Constit_Elmt
);
27319 -- At least one of the constituents appears as an Input
27321 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27324 -- A Proof_In constituent can refine an Input state as long
27325 -- as there is at least one Input constituent present.
27327 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27331 -- The constituent appears in the global refinement, but has
27332 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27334 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27335 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27337 Error_Msg_Name_1
:= Chars
(State_Id
);
27339 ("constituent & of state % must have mode `Input` in "
27340 & "global refinement", N
, Constit_Id
);
27343 Next_Elmt
(Constit_Elmt
);
27347 -- Not one of the constituents appeared as Input. Always emit an
27348 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27349 -- When only partial refinement is visible, emit an error if the
27350 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27351 -- the case where both are utilized, an error will be issued in
27352 -- Check_State_And_Constituent_Use.
27355 and then (Has_Visible_Refinement
(State_Id
)
27356 or else Contains
(Repeat_Items
, State_Id
))
27359 ("global refinement of state & must include at least one "
27360 & "constituent of mode `Input`", N
, State_Id
);
27362 end Check_Constituent_Usage
;
27366 Item_Elmt
: Elmt_Id
;
27367 Item_Id
: Entity_Id
;
27369 -- Start of processing for Check_Input_States
27372 -- Do not perform this check in an instance because it was already
27373 -- performed successfully in the generic template.
27375 if Is_Generic_Instance
(Spec_Id
) then
27378 -- Inspect the Input items of the corresponding Global pragma looking
27379 -- for a state with a visible refinement.
27381 elsif Has_In_State
and then Present
(In_Items
) then
27382 Item_Elmt
:= First_Elmt
(In_Items
);
27383 while Present
(Item_Elmt
) loop
27384 Item_Id
:= Node
(Item_Elmt
);
27386 -- When full refinement is visible, ensure that at least one of
27387 -- the constituents is utilized and is of mode Input. When only
27388 -- partial refinement is visible, ensure that either one of
27389 -- the constituents is utilized and is of mode Input, or the
27390 -- abstract state is repeated and no constituent is utilized.
27392 if Ekind
(Item_Id
) = E_Abstract_State
27393 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27395 Check_Constituent_Usage
(Item_Id
);
27398 Next_Elmt
(Item_Elmt
);
27401 end Check_Input_States
;
27403 -------------------------
27404 -- Check_Output_States --
27405 -------------------------
27407 procedure Check_Output_States
is
27408 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27409 -- Determine whether all constituents of state State_Id with full
27410 -- visible refinement are used and have mode Output. Emit an error
27411 -- if this is not the case (SPARK RM 7.2.4(5)).
27413 -----------------------------
27414 -- Check_Constituent_Usage --
27415 -----------------------------
27417 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27418 Constits
: constant Elist_Id
:=
27419 Partial_Refinement_Constituents
(State_Id
);
27420 Only_Partial
: constant Boolean :=
27421 not Has_Visible_Refinement
(State_Id
);
27422 Constit_Elmt
: Elmt_Id
;
27423 Constit_Id
: Entity_Id
;
27424 Posted
: Boolean := False;
27427 if Present
(Constits
) then
27428 Constit_Elmt
:= First_Elmt
(Constits
);
27429 while Present
(Constit_Elmt
) loop
27430 Constit_Id
:= Node
(Constit_Elmt
);
27432 -- Issue an error when a constituent of State_Id is utilized
27433 -- and State_Id has only partial visible refinement
27434 -- (SPARK RM 7.2.4(3d)).
27436 if Only_Partial
then
27437 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
27438 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
27440 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27442 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27444 Error_Msg_Name_1
:= Chars
(State_Id
);
27446 ("constituent & of state % cannot be used in global "
27447 & "refinement", N
, Constit_Id
);
27448 Error_Msg_Name_1
:= Chars
(State_Id
);
27449 SPARK_Msg_N
("\use state % instead", N
);
27452 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27455 -- The constituent appears in the global refinement, but has
27456 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27458 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27459 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27460 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27462 Error_Msg_Name_1
:= Chars
(State_Id
);
27464 ("constituent & of state % must have mode `Output` in "
27465 & "global refinement", N
, Constit_Id
);
27467 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27473 ("`Output` state & must be replaced by all its "
27474 & "constituents in global refinement", N
, State_Id
);
27478 ("\constituent & is missing in output list",
27482 Next_Elmt
(Constit_Elmt
);
27485 end Check_Constituent_Usage
;
27489 Item_Elmt
: Elmt_Id
;
27490 Item_Id
: Entity_Id
;
27492 -- Start of processing for Check_Output_States
27495 -- Do not perform this check in an instance because it was already
27496 -- performed successfully in the generic template.
27498 if Is_Generic_Instance
(Spec_Id
) then
27501 -- Inspect the Output items of the corresponding Global pragma
27502 -- looking for a state with a visible refinement.
27504 elsif Has_Out_State
and then Present
(Out_Items
) then
27505 Item_Elmt
:= First_Elmt
(Out_Items
);
27506 while Present
(Item_Elmt
) loop
27507 Item_Id
:= Node
(Item_Elmt
);
27509 -- When full refinement is visible, ensure that all of the
27510 -- constituents are utilized and they have mode Output. When
27511 -- only partial refinement is visible, ensure that no
27512 -- constituent is utilized.
27514 if Ekind
(Item_Id
) = E_Abstract_State
27515 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27517 Check_Constituent_Usage
(Item_Id
);
27520 Next_Elmt
(Item_Elmt
);
27523 end Check_Output_States
;
27525 ---------------------------
27526 -- Check_Proof_In_States --
27527 ---------------------------
27529 procedure Check_Proof_In_States
is
27530 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27531 -- Determine whether at least one constituent of state State_Id with
27532 -- full or partial visible refinement is used and has mode Proof_In.
27533 -- Ensure that the remaining constituents do not have Input, In_Out,
27534 -- or Output modes. Emit an error if this is not the case
27535 -- (SPARK RM 7.2.4(5)).
27537 -----------------------------
27538 -- Check_Constituent_Usage --
27539 -----------------------------
27541 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27542 Constits
: constant Elist_Id
:=
27543 Partial_Refinement_Constituents
(State_Id
);
27544 Constit_Elmt
: Elmt_Id
;
27545 Constit_Id
: Entity_Id
;
27546 Proof_In_Seen
: Boolean := False;
27549 if Present
(Constits
) then
27550 Constit_Elmt
:= First_Elmt
(Constits
);
27551 while Present
(Constit_Elmt
) loop
27552 Constit_Id
:= Node
(Constit_Elmt
);
27554 -- At least one of the constituents appears as Proof_In
27556 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
27557 Proof_In_Seen
:= True;
27559 -- The constituent appears in the global refinement, but has
27560 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27562 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27563 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27564 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27566 Error_Msg_Name_1
:= Chars
(State_Id
);
27568 ("constituent & of state % must have mode `Proof_In` "
27569 & "in global refinement", N
, Constit_Id
);
27572 Next_Elmt
(Constit_Elmt
);
27576 -- Not one of the constituents appeared as Proof_In. Always emit
27577 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27578 -- When only partial refinement is visible, emit an error if the
27579 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27580 -- the case where both are utilized, an error will be issued by
27581 -- Check_State_And_Constituent_Use.
27583 if not Proof_In_Seen
27584 and then (Has_Visible_Refinement
(State_Id
)
27585 or else Contains
(Repeat_Items
, State_Id
))
27588 ("global refinement of state & must include at least one "
27589 & "constituent of mode `Proof_In`", N
, State_Id
);
27591 end Check_Constituent_Usage
;
27595 Item_Elmt
: Elmt_Id
;
27596 Item_Id
: Entity_Id
;
27598 -- Start of processing for Check_Proof_In_States
27601 -- Do not perform this check in an instance because it was already
27602 -- performed successfully in the generic template.
27604 if Is_Generic_Instance
(Spec_Id
) then
27607 -- Inspect the Proof_In items of the corresponding Global pragma
27608 -- looking for a state with a visible refinement.
27610 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
27611 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
27612 while Present
(Item_Elmt
) loop
27613 Item_Id
:= Node
(Item_Elmt
);
27615 -- Ensure that at least one of the constituents is utilized
27616 -- and is of mode Proof_In. When only partial refinement is
27617 -- visible, ensure that either one of the constituents is
27618 -- utilized and is of mode Proof_In, or the abstract state
27619 -- is repeated and no constituent is utilized.
27621 if Ekind
(Item_Id
) = E_Abstract_State
27622 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27624 Check_Constituent_Usage
(Item_Id
);
27627 Next_Elmt
(Item_Elmt
);
27630 end Check_Proof_In_States
;
27632 -------------------------------
27633 -- Check_Refined_Global_List --
27634 -------------------------------
27636 procedure Check_Refined_Global_List
27638 Global_Mode
: Name_Id
:= Name_Input
)
27640 procedure Check_Refined_Global_Item
27642 Global_Mode
: Name_Id
);
27643 -- Verify the legality of a single global item declaration. Parameter
27644 -- Global_Mode denotes the current mode in effect.
27646 -------------------------------
27647 -- Check_Refined_Global_Item --
27648 -------------------------------
27650 procedure Check_Refined_Global_Item
27652 Global_Mode
: Name_Id
)
27654 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
27656 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
27657 -- Issue a common error message for all mode mismatches. Expect
27658 -- denotes the expected mode.
27660 -----------------------------
27661 -- Inconsistent_Mode_Error --
27662 -----------------------------
27664 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
27667 ("global item & has inconsistent modes", Item
, Item_Id
);
27669 Error_Msg_Name_1
:= Global_Mode
;
27670 Error_Msg_Name_2
:= Expect
;
27671 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
27672 end Inconsistent_Mode_Error
;
27676 Enc_State
: Entity_Id
:= Empty
;
27677 -- Encapsulating state for constituent, Empty otherwise
27679 -- Start of processing for Check_Refined_Global_Item
27682 if Ekind_In
(Item_Id
, E_Abstract_State
,
27686 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
27689 -- When the state or object acts as a constituent of another
27690 -- state with a visible refinement, collect it for the state
27691 -- completeness checks performed later on. Note that the item
27692 -- acts as a constituent only when the encapsulating state is
27693 -- present in pragma Global.
27695 if Present
(Enc_State
)
27696 and then (Has_Visible_Refinement
(Enc_State
)
27697 or else Has_Partial_Visible_Refinement
(Enc_State
))
27698 and then Contains
(States
, Enc_State
)
27700 -- If the state has only partial visible refinement, remove it
27701 -- from the list of items that should be repeated from pragma
27704 if not Has_Visible_Refinement
(Enc_State
) then
27705 Present_Then_Remove
(Repeat_Items
, Enc_State
);
27708 if Global_Mode
= Name_Input
then
27709 Append_New_Elmt
(Item_Id
, In_Constits
);
27711 elsif Global_Mode
= Name_In_Out
then
27712 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
27714 elsif Global_Mode
= Name_Output
then
27715 Append_New_Elmt
(Item_Id
, Out_Constits
);
27717 elsif Global_Mode
= Name_Proof_In
then
27718 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
27721 -- When not a constituent, ensure that both occurrences of the
27722 -- item in pragmas Global and Refined_Global match. Also remove
27723 -- it when present from the list of items that should be repeated
27724 -- from pragma Global.
27727 Present_Then_Remove
(Repeat_Items
, Item_Id
);
27729 if Contains
(In_Items
, Item_Id
) then
27730 if Global_Mode
/= Name_Input
then
27731 Inconsistent_Mode_Error
(Name_Input
);
27734 elsif Contains
(In_Out_Items
, Item_Id
) then
27735 if Global_Mode
/= Name_In_Out
then
27736 Inconsistent_Mode_Error
(Name_In_Out
);
27739 elsif Contains
(Out_Items
, Item_Id
) then
27740 if Global_Mode
/= Name_Output
then
27741 Inconsistent_Mode_Error
(Name_Output
);
27744 elsif Contains
(Proof_In_Items
, Item_Id
) then
27747 -- The item does not appear in the corresponding Global pragma,
27748 -- it must be an extra (SPARK RM 7.2.4(3)).
27751 pragma Assert
(Present
(Global
));
27752 Error_Msg_Sloc
:= Sloc
(Global
);
27754 ("extra global item & does not refine or repeat any "
27755 & "global item #", Item
, Item_Id
);
27758 end Check_Refined_Global_Item
;
27764 -- Start of processing for Check_Refined_Global_List
27767 -- Do not perform this check in an instance because it was already
27768 -- performed successfully in the generic template.
27770 if Is_Generic_Instance
(Spec_Id
) then
27773 elsif Nkind
(List
) = N_Null
then
27776 -- Single global item declaration
27778 elsif Nkind_In
(List
, N_Expanded_Name
,
27780 N_Selected_Component
)
27782 Check_Refined_Global_Item
(List
, Global_Mode
);
27784 -- Simple global list or moded global list declaration
27786 elsif Nkind
(List
) = N_Aggregate
then
27788 -- The declaration of a simple global list appear as a collection
27791 if Present
(Expressions
(List
)) then
27792 Item
:= First
(Expressions
(List
));
27793 while Present
(Item
) loop
27794 Check_Refined_Global_Item
(Item
, Global_Mode
);
27798 -- The declaration of a moded global list appears as a collection
27799 -- of component associations where individual choices denote
27802 elsif Present
(Component_Associations
(List
)) then
27803 Item
:= First
(Component_Associations
(List
));
27804 while Present
(Item
) loop
27805 Check_Refined_Global_List
27806 (List
=> Expression
(Item
),
27807 Global_Mode
=> Chars
(First
(Choices
(Item
))));
27815 raise Program_Error
;
27821 raise Program_Error
;
27823 end Check_Refined_Global_List
;
27825 --------------------------
27826 -- Collect_Global_Items --
27827 --------------------------
27829 procedure Collect_Global_Items
27831 Mode
: Name_Id
:= Name_Input
)
27833 procedure Collect_Global_Item
27835 Item_Mode
: Name_Id
);
27836 -- Add a single item to the appropriate list. Item_Mode denotes the
27837 -- current mode in effect.
27839 -------------------------
27840 -- Collect_Global_Item --
27841 -------------------------
27843 procedure Collect_Global_Item
27845 Item_Mode
: Name_Id
)
27847 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
27848 -- The above handles abstract views of variables and states built
27849 -- for limited with clauses.
27852 -- Signal that the global list contains at least one abstract
27853 -- state with a visible refinement. Note that the refinement may
27854 -- be null in which case there are no constituents.
27856 if Ekind
(Item_Id
) = E_Abstract_State
then
27857 if Has_Null_Visible_Refinement
(Item_Id
) then
27858 Has_Null_State
:= True;
27860 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27861 Append_New_Elmt
(Item_Id
, States
);
27863 if Item_Mode
= Name_Input
then
27864 Has_In_State
:= True;
27865 elsif Item_Mode
= Name_In_Out
then
27866 Has_In_Out_State
:= True;
27867 elsif Item_Mode
= Name_Output
then
27868 Has_Out_State
:= True;
27869 elsif Item_Mode
= Name_Proof_In
then
27870 Has_Proof_In_State
:= True;
27875 -- Record global items without full visible refinement found in
27876 -- pragma Global which should be repeated in the global refinement
27877 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27879 if Ekind
(Item_Id
) /= E_Abstract_State
27880 or else not Has_Visible_Refinement
(Item_Id
)
27882 Append_New_Elmt
(Item_Id
, Repeat_Items
);
27885 -- Add the item to the proper list
27887 if Item_Mode
= Name_Input
then
27888 Append_New_Elmt
(Item_Id
, In_Items
);
27889 elsif Item_Mode
= Name_In_Out
then
27890 Append_New_Elmt
(Item_Id
, In_Out_Items
);
27891 elsif Item_Mode
= Name_Output
then
27892 Append_New_Elmt
(Item_Id
, Out_Items
);
27893 elsif Item_Mode
= Name_Proof_In
then
27894 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
27896 end Collect_Global_Item
;
27902 -- Start of processing for Collect_Global_Items
27905 if Nkind
(List
) = N_Null
then
27908 -- Single global item declaration
27910 elsif Nkind_In
(List
, N_Expanded_Name
,
27912 N_Selected_Component
)
27914 Collect_Global_Item
(List
, Mode
);
27916 -- Single global list or moded global list declaration
27918 elsif Nkind
(List
) = N_Aggregate
then
27920 -- The declaration of a simple global list appear as a collection
27923 if Present
(Expressions
(List
)) then
27924 Item
:= First
(Expressions
(List
));
27925 while Present
(Item
) loop
27926 Collect_Global_Item
(Item
, Mode
);
27930 -- The declaration of a moded global list appears as a collection
27931 -- of component associations where individual choices denote mode.
27933 elsif Present
(Component_Associations
(List
)) then
27934 Item
:= First
(Component_Associations
(List
));
27935 while Present
(Item
) loop
27936 Collect_Global_Items
27937 (List
=> Expression
(Item
),
27938 Mode
=> Chars
(First
(Choices
(Item
))));
27946 raise Program_Error
;
27949 -- To accommodate partial decoration of disabled SPARK features, this
27950 -- routine may be called with illegal input. If this is the case, do
27951 -- not raise Program_Error.
27956 end Collect_Global_Items
;
27958 -------------------------
27959 -- Present_Then_Remove --
27960 -------------------------
27962 function Present_Then_Remove
27964 Item
: Entity_Id
) return Boolean
27969 if Present
(List
) then
27970 Elmt
:= First_Elmt
(List
);
27971 while Present
(Elmt
) loop
27972 if Node
(Elmt
) = Item
then
27973 Remove_Elmt
(List
, Elmt
);
27982 end Present_Then_Remove
;
27984 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
27987 Ignore
:= Present_Then_Remove
(List
, Item
);
27988 end Present_Then_Remove
;
27990 -------------------------------
27991 -- Report_Extra_Constituents --
27992 -------------------------------
27994 procedure Report_Extra_Constituents
is
27995 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
27996 -- Emit an error for every element of List
27998 ---------------------------------------
27999 -- Report_Extra_Constituents_In_List --
28000 ---------------------------------------
28002 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
28003 Constit_Elmt
: Elmt_Id
;
28006 if Present
(List
) then
28007 Constit_Elmt
:= First_Elmt
(List
);
28008 while Present
(Constit_Elmt
) loop
28009 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
28010 Next_Elmt
(Constit_Elmt
);
28013 end Report_Extra_Constituents_In_List
;
28015 -- Start of processing for Report_Extra_Constituents
28018 -- Do not perform this check in an instance because it was already
28019 -- performed successfully in the generic template.
28021 if Is_Generic_Instance
(Spec_Id
) then
28025 Report_Extra_Constituents_In_List
(In_Constits
);
28026 Report_Extra_Constituents_In_List
(In_Out_Constits
);
28027 Report_Extra_Constituents_In_List
(Out_Constits
);
28028 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
28030 end Report_Extra_Constituents
;
28032 --------------------------
28033 -- Report_Missing_Items --
28034 --------------------------
28036 procedure Report_Missing_Items
is
28037 Item_Elmt
: Elmt_Id
;
28038 Item_Id
: Entity_Id
;
28041 -- Do not perform this check in an instance because it was already
28042 -- performed successfully in the generic template.
28044 if Is_Generic_Instance
(Spec_Id
) then
28048 if Present
(Repeat_Items
) then
28049 Item_Elmt
:= First_Elmt
(Repeat_Items
);
28050 while Present
(Item_Elmt
) loop
28051 Item_Id
:= Node
(Item_Elmt
);
28052 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
28053 Next_Elmt
(Item_Elmt
);
28057 end Report_Missing_Items
;
28061 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28062 Errors
: constant Nat
:= Serious_Errors_Detected
;
28064 No_Constit
: Boolean;
28066 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28069 -- Do not analyze the pragma multiple times
28071 if Is_Analyzed_Pragma
(N
) then
28075 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28077 -- Use the anonymous object as the proper spec when Refined_Global
28078 -- applies to the body of a single task type. The object carries the
28079 -- proper Chars as well as all non-refined versions of pragmas.
28081 if Is_Single_Concurrent_Type
(Spec_Id
) then
28082 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28085 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28086 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
28088 -- The subprogram declaration lacks pragma Global. This renders
28089 -- Refined_Global useless as there is nothing to refine.
28091 if No
(Global
) then
28093 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28094 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
28098 -- Extract all relevant items from the corresponding Global pragma
28100 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28102 -- Package and subprogram bodies are instantiated individually in
28103 -- a separate compiler pass. Due to this mode of instantiation, the
28104 -- refinement of a state may no longer be visible when a subprogram
28105 -- body contract is instantiated. Since the generic template is legal,
28106 -- do not perform this check in the instance to circumvent this oddity.
28108 if Is_Generic_Instance
(Spec_Id
) then
28111 -- Non-instance case
28114 -- The corresponding Global pragma must mention at least one
28115 -- state with a visible refinement at the point Refined_Global
28116 -- is processed. States with null refinements need Refined_Global
28117 -- pragma (SPARK RM 7.2.4(2)).
28119 if not Has_In_State
28120 and then not Has_In_Out_State
28121 and then not Has_Out_State
28122 and then not Has_Proof_In_State
28123 and then not Has_Null_State
28126 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28127 & "depend on abstract state with visible refinement"),
28131 -- The global refinement of inputs and outputs cannot be null when
28132 -- the corresponding Global pragma contains at least one item except
28133 -- in the case where we have states with null refinements.
28135 elsif Nkind
(Items
) = N_Null
28137 (Present
(In_Items
)
28138 or else Present
(In_Out_Items
)
28139 or else Present
(Out_Items
)
28140 or else Present
(Proof_In_Items
))
28141 and then not Has_Null_State
28144 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
28145 & "global items"), N
, Spec_Id
);
28150 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28151 -- This ensures that the categorization of all refined global items is
28152 -- consistent with their role.
28154 Analyze_Global_In_Decl_Part
(N
);
28156 -- Perform all refinement checks with respect to completeness and mode
28159 if Serious_Errors_Detected
= Errors
then
28160 Check_Refined_Global_List
(Items
);
28163 -- Store the information that no constituent is used in the global
28164 -- refinement, prior to calling checking procedures which remove items
28165 -- from the list of constituents.
28169 and then No
(In_Out_Constits
)
28170 and then No
(Out_Constits
)
28171 and then No
(Proof_In_Constits
);
28173 -- For Input states with visible refinement, at least one constituent
28174 -- must be used as an Input in the global refinement.
28176 if Serious_Errors_Detected
= Errors
then
28177 Check_Input_States
;
28180 -- Verify all possible completion variants for In_Out states with
28181 -- visible refinement.
28183 if Serious_Errors_Detected
= Errors
then
28184 Check_In_Out_States
;
28187 -- For Output states with visible refinement, all constituents must be
28188 -- used as Outputs in the global refinement.
28190 if Serious_Errors_Detected
= Errors
then
28191 Check_Output_States
;
28194 -- For Proof_In states with visible refinement, at least one constituent
28195 -- must be used as Proof_In in the global refinement.
28197 if Serious_Errors_Detected
= Errors
then
28198 Check_Proof_In_States
;
28201 -- Emit errors for all constituents that belong to other states with
28202 -- visible refinement that do not appear in Global.
28204 if Serious_Errors_Detected
= Errors
then
28205 Report_Extra_Constituents
;
28208 -- Emit errors for all items in Global that are not repeated in the
28209 -- global refinement and for which there is no full visible refinement
28210 -- and, in the case of states with partial visible refinement, no
28211 -- constituent is mentioned in the global refinement.
28213 if Serious_Errors_Detected
= Errors
then
28214 Report_Missing_Items
;
28217 -- Emit an error if no constituent is used in the global refinement
28218 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28219 -- one may be issued by the checking procedures. Do not perform this
28220 -- check in an instance because it was already performed successfully
28221 -- in the generic template.
28223 if Serious_Errors_Detected
= Errors
28224 and then not Is_Generic_Instance
(Spec_Id
)
28225 and then not Has_Null_State
28226 and then No_Constit
28228 SPARK_Msg_N
("missing refinement", N
);
28232 Set_Is_Analyzed_Pragma
(N
);
28233 end Analyze_Refined_Global_In_Decl_Part
;
28235 ----------------------------------------
28236 -- Analyze_Refined_State_In_Decl_Part --
28237 ----------------------------------------
28239 procedure Analyze_Refined_State_In_Decl_Part
28241 Freeze_Id
: Entity_Id
:= Empty
)
28243 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
28244 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28245 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
28247 Available_States
: Elist_Id
:= No_Elist
;
28248 -- A list of all abstract states defined in the package declaration that
28249 -- are available for refinement. The list is used to report unrefined
28252 Body_States
: Elist_Id
:= No_Elist
;
28253 -- A list of all hidden states that appear in the body of the related
28254 -- package. The list is used to report unused hidden states.
28256 Constituents_Seen
: Elist_Id
:= No_Elist
;
28257 -- A list that contains all constituents processed so far. The list is
28258 -- used to detect multiple uses of the same constituent.
28260 Freeze_Posted
: Boolean := False;
28261 -- A flag that controls the output of a freezing-related error (see use
28264 Refined_States_Seen
: Elist_Id
:= No_Elist
;
28265 -- A list that contains all refined states processed so far. The list is
28266 -- used to detect duplicate refinements.
28268 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
28269 -- Perform full analysis of a single refinement clause
28271 procedure Report_Unrefined_States
(States
: Elist_Id
);
28272 -- Emit errors for all unrefined abstract states found in list States
28274 -------------------------------
28275 -- Analyze_Refinement_Clause --
28276 -------------------------------
28278 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
28279 AR_Constit
: Entity_Id
:= Empty
;
28280 AW_Constit
: Entity_Id
:= Empty
;
28281 ER_Constit
: Entity_Id
:= Empty
;
28282 EW_Constit
: Entity_Id
:= Empty
;
28283 -- The entities of external constituents that contain one of the
28284 -- following enabled properties: Async_Readers, Async_Writers,
28285 -- Effective_Reads and Effective_Writes.
28287 External_Constit_Seen
: Boolean := False;
28288 -- Flag used to mark when at least one external constituent is part
28289 -- of the state refinement.
28291 Non_Null_Seen
: Boolean := False;
28292 Null_Seen
: Boolean := False;
28293 -- Flags used to detect multiple uses of null in a single clause or a
28294 -- mixture of null and non-null constituents.
28296 Part_Of_Constits
: Elist_Id
:= No_Elist
;
28297 -- A list of all candidate constituents subject to indicator Part_Of
28298 -- where the encapsulating state is the current state.
28301 State_Id
: Entity_Id
;
28302 -- The current state being refined
28304 procedure Analyze_Constituent
(Constit
: Node_Id
);
28305 -- Perform full analysis of a single constituent
28307 procedure Check_External_Property
28308 (Prop_Nam
: Name_Id
;
28310 Constit
: Entity_Id
);
28311 -- Determine whether a property denoted by name Prop_Nam is present
28312 -- in the refined state. Emit an error if this is not the case. Flag
28313 -- Enabled should be set when the property applies to the refined
28314 -- state. Constit denotes the constituent (if any) which introduces
28315 -- the property in the refinement.
28317 procedure Match_State
;
28318 -- Determine whether the state being refined appears in list
28319 -- Available_States. Emit an error when attempting to re-refine the
28320 -- state or when the state is not defined in the package declaration,
28321 -- otherwise remove the state from Available_States.
28323 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
28324 -- Emit errors for all unused Part_Of constituents in list Constits
28326 -------------------------
28327 -- Analyze_Constituent --
28328 -------------------------
28330 procedure Analyze_Constituent
(Constit
: Node_Id
) is
28331 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
28332 -- Determine whether constituent Constit denoted by its entity
28333 -- Constit_Id appears in Body_States. Emit an error when the
28334 -- constituent is not a valid hidden state of the related package
28335 -- or when it is used more than once. Otherwise remove the
28336 -- constituent from Body_States.
28338 -----------------------
28339 -- Match_Constituent --
28340 -----------------------
28342 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
28343 procedure Collect_Constituent
;
28344 -- Verify the legality of constituent Constit_Id and add it to
28345 -- the refinements of State_Id.
28347 -------------------------
28348 -- Collect_Constituent --
28349 -------------------------
28351 procedure Collect_Constituent
is
28352 Constits
: Elist_Id
;
28355 -- The Ghost policy in effect at the point of abstract state
28356 -- declaration and constituent must match (SPARK RM 6.9(15))
28358 Check_Ghost_Refinement
28359 (State
, State_Id
, Constit
, Constit_Id
);
28361 -- A synchronized state must be refined by a synchronized
28362 -- object or another synchronized state (SPARK RM 9.6).
28364 if Is_Synchronized_State
(State_Id
)
28365 and then not Is_Synchronized_Object
(Constit_Id
)
28366 and then not Is_Synchronized_State
(Constit_Id
)
28369 ("constituent of synchronized state & must be "
28370 & "synchronized", Constit
, State_Id
);
28373 -- Add the constituent to the list of processed items to aid
28374 -- with the detection of duplicates.
28376 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
28378 -- Collect the constituent in the list of refinement items
28379 -- and establish a relation between the refined state and
28382 Constits
:= Refinement_Constituents
(State_Id
);
28384 if No
(Constits
) then
28385 Constits
:= New_Elmt_List
;
28386 Set_Refinement_Constituents
(State_Id
, Constits
);
28389 Append_Elmt
(Constit_Id
, Constits
);
28390 Set_Encapsulating_State
(Constit_Id
, State_Id
);
28392 -- The state has at least one legal constituent, mark the
28393 -- start of the refinement region. The region ends when the
28394 -- body declarations end (see routine Analyze_Declarations).
28396 Set_Has_Visible_Refinement
(State_Id
);
28398 -- When the constituent is external, save its relevant
28399 -- property for further checks.
28401 if Async_Readers_Enabled
(Constit_Id
) then
28402 AR_Constit
:= Constit_Id
;
28403 External_Constit_Seen
:= True;
28406 if Async_Writers_Enabled
(Constit_Id
) then
28407 AW_Constit
:= Constit_Id
;
28408 External_Constit_Seen
:= True;
28411 if Effective_Reads_Enabled
(Constit_Id
) then
28412 ER_Constit
:= Constit_Id
;
28413 External_Constit_Seen
:= True;
28416 if Effective_Writes_Enabled
(Constit_Id
) then
28417 EW_Constit
:= Constit_Id
;
28418 External_Constit_Seen
:= True;
28420 end Collect_Constituent
;
28424 State_Elmt
: Elmt_Id
;
28426 -- Start of processing for Match_Constituent
28429 -- Detect a duplicate use of a constituent
28431 if Contains
(Constituents_Seen
, Constit_Id
) then
28433 ("duplicate use of constituent &", Constit
, Constit_Id
);
28437 -- The constituent is subject to a Part_Of indicator
28439 if Present
(Encapsulating_State
(Constit_Id
)) then
28440 if Encapsulating_State
(Constit_Id
) = State_Id
then
28441 Remove
(Part_Of_Constits
, Constit_Id
);
28442 Collect_Constituent
;
28444 -- The constituent is part of another state and is used
28445 -- incorrectly in the refinement of the current state.
28448 Error_Msg_Name_1
:= Chars
(State_Id
);
28450 ("& cannot act as constituent of state %",
28451 Constit
, Constit_Id
);
28453 ("\Part_Of indicator specifies encapsulator &",
28454 Constit
, Encapsulating_State
(Constit_Id
));
28457 -- The only other source of legal constituents is the body
28458 -- state space of the related package.
28461 if Present
(Body_States
) then
28462 State_Elmt
:= First_Elmt
(Body_States
);
28463 while Present
(State_Elmt
) loop
28465 -- Consume a valid constituent to signal that it has
28466 -- been encountered.
28468 if Node
(State_Elmt
) = Constit_Id
then
28469 Remove_Elmt
(Body_States
, State_Elmt
);
28470 Collect_Constituent
;
28474 Next_Elmt
(State_Elmt
);
28478 -- At this point it is known that the constituent is not
28479 -- part of the package hidden state and cannot be used in
28480 -- a refinement (SPARK RM 7.2.2(9)).
28482 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28484 ("cannot use & in refinement, constituent is not a hidden "
28485 & "state of package %", Constit
, Constit_Id
);
28487 end Match_Constituent
;
28491 Constit_Id
: Entity_Id
;
28492 Constits
: Elist_Id
;
28494 -- Start of processing for Analyze_Constituent
28497 -- Detect multiple uses of null in a single refinement clause or a
28498 -- mixture of null and non-null constituents.
28500 if Nkind
(Constit
) = N_Null
then
28503 ("multiple null constituents not allowed", Constit
);
28505 elsif Non_Null_Seen
then
28507 ("cannot mix null and non-null constituents", Constit
);
28512 -- Collect the constituent in the list of refinement items
28514 Constits
:= Refinement_Constituents
(State_Id
);
28516 if No
(Constits
) then
28517 Constits
:= New_Elmt_List
;
28518 Set_Refinement_Constituents
(State_Id
, Constits
);
28521 Append_Elmt
(Constit
, Constits
);
28523 -- The state has at least one legal constituent, mark the
28524 -- start of the refinement region. The region ends when the
28525 -- body declarations end (see Analyze_Declarations).
28527 Set_Has_Visible_Refinement
(State_Id
);
28530 -- Non-null constituents
28533 Non_Null_Seen
:= True;
28537 ("cannot mix null and non-null constituents", Constit
);
28541 Resolve_State
(Constit
);
28543 -- Ensure that the constituent denotes a valid state or a
28544 -- whole object (SPARK RM 7.2.2(5)).
28546 if Is_Entity_Name
(Constit
) then
28547 Constit_Id
:= Entity_Of
(Constit
);
28549 -- When a constituent is declared after a subprogram body
28550 -- that caused freezing of the related contract where
28551 -- pragma Refined_State resides, the constituent appears
28552 -- undefined and carries Any_Id as its entity.
28554 -- package body Pack
28555 -- with Refined_State => (State => Constit)
28558 -- with Refined_Global => (Input => Constit)
28566 if Constit_Id
= Any_Id
then
28567 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
28569 -- Emit a specialized info message when the contract of
28570 -- the related package body was "frozen" by another body.
28571 -- Note that it is not possible to precisely identify why
28572 -- the constituent is undefined because it is not visible
28573 -- when pragma Refined_State is analyzed. This message is
28574 -- a reasonable approximation.
28576 if Present
(Freeze_Id
) and then not Freeze_Posted
then
28577 Freeze_Posted
:= True;
28579 Error_Msg_Name_1
:= Chars
(Body_Id
);
28580 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28582 ("body & declared # freezes the contract of %",
28585 ("\all constituents must be declared before body #",
28588 -- A misplaced constituent is a critical error because
28589 -- pragma Refined_Depends or Refined_Global depends on
28590 -- the proper link between a state and a constituent.
28591 -- Stop the compilation, as this leads to a multitude
28592 -- of misleading cascaded errors.
28594 raise Unrecoverable_Error
;
28597 -- The constituent is a valid state or object
28599 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
28603 Match_Constituent
(Constit_Id
);
28605 -- The variable may eventually become a constituent of a
28606 -- single protected/task type. Record the reference now
28607 -- and verify its legality when analyzing the contract of
28608 -- the variable (SPARK RM 9.3).
28610 if Ekind
(Constit_Id
) = E_Variable
then
28611 Record_Possible_Part_Of_Reference
28612 (Var_Id
=> Constit_Id
,
28616 -- Otherwise the constituent is illegal
28620 ("constituent & must denote object or state",
28621 Constit
, Constit_Id
);
28624 -- The constituent is illegal
28627 SPARK_Msg_N
("malformed constituent", Constit
);
28630 end Analyze_Constituent
;
28632 -----------------------------
28633 -- Check_External_Property --
28634 -----------------------------
28636 procedure Check_External_Property
28637 (Prop_Nam
: Name_Id
;
28639 Constit
: Entity_Id
)
28642 -- The property is missing in the declaration of the state, but
28643 -- a constituent is introducing it in the state refinement
28644 -- (SPARK RM 7.2.8(2)).
28646 if not Enabled
and then Present
(Constit
) then
28647 Error_Msg_Name_1
:= Prop_Nam
;
28648 Error_Msg_Name_2
:= Chars
(State_Id
);
28650 ("constituent & introduces external property % in refinement "
28651 & "of state %", State
, Constit
);
28653 Error_Msg_Sloc
:= Sloc
(State_Id
);
28655 ("\property is missing in abstract state declaration #",
28658 end Check_External_Property
;
28664 procedure Match_State
is
28665 State_Elmt
: Elmt_Id
;
28668 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28670 if Contains
(Refined_States_Seen
, State_Id
) then
28672 ("duplicate refinement of state &", State
, State_Id
);
28676 -- Inspect the abstract states defined in the package declaration
28677 -- looking for a match.
28679 State_Elmt
:= First_Elmt
(Available_States
);
28680 while Present
(State_Elmt
) loop
28682 -- A valid abstract state is being refined in the body. Add
28683 -- the state to the list of processed refined states to aid
28684 -- with the detection of duplicate refinements. Remove the
28685 -- state from Available_States to signal that it has already
28688 if Node
(State_Elmt
) = State_Id
then
28689 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
28690 Remove_Elmt
(Available_States
, State_Elmt
);
28694 Next_Elmt
(State_Elmt
);
28697 -- If we get here, we are refining a state that is not defined in
28698 -- the package declaration.
28700 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28702 ("cannot refine state, & is not defined in package %",
28706 --------------------------------
28707 -- Report_Unused_Constituents --
28708 --------------------------------
28710 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
28711 Constit_Elmt
: Elmt_Id
;
28712 Constit_Id
: Entity_Id
;
28713 Posted
: Boolean := False;
28716 if Present
(Constits
) then
28717 Constit_Elmt
:= First_Elmt
(Constits
);
28718 while Present
(Constit_Elmt
) loop
28719 Constit_Id
:= Node
(Constit_Elmt
);
28721 -- Generate an error message of the form:
28723 -- state ... has unused Part_Of constituents
28724 -- abstract state ... defined at ...
28725 -- constant ... defined at ...
28726 -- variable ... defined at ...
28731 ("state & has unused Part_Of constituents",
28735 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
28737 if Ekind
(Constit_Id
) = E_Abstract_State
then
28739 ("\abstract state & defined #", State
, Constit_Id
);
28741 elsif Ekind
(Constit_Id
) = E_Constant
then
28743 ("\constant & defined #", State
, Constit_Id
);
28746 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
28747 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
28750 Next_Elmt
(Constit_Elmt
);
28753 end Report_Unused_Constituents
;
28755 -- Local declarations
28757 Body_Ref
: Node_Id
;
28758 Body_Ref_Elmt
: Elmt_Id
;
28760 Extra_State
: Node_Id
;
28762 -- Start of processing for Analyze_Refinement_Clause
28765 -- A refinement clause appears as a component association where the
28766 -- sole choice is the state and the expressions are the constituents.
28767 -- This is a syntax error, always report.
28769 if Nkind
(Clause
) /= N_Component_Association
then
28770 Error_Msg_N
("malformed state refinement clause", Clause
);
28774 -- Analyze the state name of a refinement clause
28776 State
:= First
(Choices
(Clause
));
28779 Resolve_State
(State
);
28781 -- Ensure that the state name denotes a valid abstract state that is
28782 -- defined in the spec of the related package.
28784 if Is_Entity_Name
(State
) then
28785 State_Id
:= Entity_Of
(State
);
28787 -- When the abstract state is undefined, it appears as Any_Id. Do
28788 -- not continue with the analysis of the clause.
28790 if State_Id
= Any_Id
then
28793 -- Catch any attempts to re-refine a state or refine a state that
28794 -- is not defined in the package declaration.
28796 elsif Ekind
(State_Id
) = E_Abstract_State
then
28800 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
28804 -- References to a state with visible refinement are illegal.
28805 -- When nested packages are involved, detecting such references is
28806 -- tricky because pragma Refined_State is analyzed later than the
28807 -- offending pragma Depends or Global. References that occur in
28808 -- such nested context are stored in a list. Emit errors for all
28809 -- references found in Body_References (SPARK RM 6.1.4(8)).
28811 if Present
(Body_References
(State_Id
)) then
28812 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
28813 while Present
(Body_Ref_Elmt
) loop
28814 Body_Ref
:= Node
(Body_Ref_Elmt
);
28816 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
28817 Error_Msg_Sloc
:= Sloc
(State
);
28818 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
28820 Next_Elmt
(Body_Ref_Elmt
);
28824 -- The state name is illegal. This is a syntax error, always report.
28827 Error_Msg_N
("malformed state name in refinement clause", State
);
28831 -- A refinement clause may only refine one state at a time
28833 Extra_State
:= Next
(State
);
28835 if Present
(Extra_State
) then
28837 ("refinement clause cannot cover multiple states", Extra_State
);
28840 -- Replicate the Part_Of constituents of the refined state because
28841 -- the algorithm will consume items.
28843 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
28845 -- Analyze all constituents of the refinement. Multiple constituents
28846 -- appear as an aggregate.
28848 Constit
:= Expression
(Clause
);
28850 if Nkind
(Constit
) = N_Aggregate
then
28851 if Present
(Component_Associations
(Constit
)) then
28853 ("constituents of refinement clause must appear in "
28854 & "positional form", Constit
);
28856 else pragma Assert
(Present
(Expressions
(Constit
)));
28857 Constit
:= First
(Expressions
(Constit
));
28858 while Present
(Constit
) loop
28859 Analyze_Constituent
(Constit
);
28864 -- Various forms of a single constituent. Note that these may include
28865 -- malformed constituents.
28868 Analyze_Constituent
(Constit
);
28871 -- Verify that external constituents do not introduce new external
28872 -- property in the state refinement (SPARK RM 7.2.8(2)).
28874 if Is_External_State
(State_Id
) then
28875 Check_External_Property
28876 (Prop_Nam
=> Name_Async_Readers
,
28877 Enabled
=> Async_Readers_Enabled
(State_Id
),
28878 Constit
=> AR_Constit
);
28880 Check_External_Property
28881 (Prop_Nam
=> Name_Async_Writers
,
28882 Enabled
=> Async_Writers_Enabled
(State_Id
),
28883 Constit
=> AW_Constit
);
28885 Check_External_Property
28886 (Prop_Nam
=> Name_Effective_Reads
,
28887 Enabled
=> Effective_Reads_Enabled
(State_Id
),
28888 Constit
=> ER_Constit
);
28890 Check_External_Property
28891 (Prop_Nam
=> Name_Effective_Writes
,
28892 Enabled
=> Effective_Writes_Enabled
(State_Id
),
28893 Constit
=> EW_Constit
);
28895 -- When a refined state is not external, it should not have external
28896 -- constituents (SPARK RM 7.2.8(1)).
28898 elsif External_Constit_Seen
then
28900 ("non-external state & cannot contain external constituents in "
28901 & "refinement", State
, State_Id
);
28904 -- Ensure that all Part_Of candidate constituents have been mentioned
28905 -- in the refinement clause.
28907 Report_Unused_Constituents
(Part_Of_Constits
);
28908 end Analyze_Refinement_Clause
;
28910 -----------------------------
28911 -- Report_Unrefined_States --
28912 -----------------------------
28914 procedure Report_Unrefined_States
(States
: Elist_Id
) is
28915 State_Elmt
: Elmt_Id
;
28918 if Present
(States
) then
28919 State_Elmt
:= First_Elmt
(States
);
28920 while Present
(State_Elmt
) loop
28922 ("abstract state & must be refined", Node
(State_Elmt
));
28924 Next_Elmt
(State_Elmt
);
28927 end Report_Unrefined_States
;
28929 -- Local declarations
28931 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
28934 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28937 -- Do not analyze the pragma multiple times
28939 if Is_Analyzed_Pragma
(N
) then
28943 -- Save the scenario for examination by the ABE Processing phase
28945 Record_Elaboration_Scenario
(N
);
28947 -- Replicate the abstract states declared by the package because the
28948 -- matching algorithm will consume states.
28950 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
28952 -- Gather all abstract states and objects declared in the visible
28953 -- state space of the package body. These items must be utilized as
28954 -- constituents in a state refinement.
28956 Body_States
:= Collect_Body_States
(Body_Id
);
28958 -- Multiple non-null state refinements appear as an aggregate
28960 if Nkind
(Clauses
) = N_Aggregate
then
28961 if Present
(Expressions
(Clauses
)) then
28963 ("state refinements must appear as component associations",
28966 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
28967 Clause
:= First
(Component_Associations
(Clauses
));
28968 while Present
(Clause
) loop
28969 Analyze_Refinement_Clause
(Clause
);
28974 -- Various forms of a single state refinement. Note that these may
28975 -- include malformed refinements.
28978 Analyze_Refinement_Clause
(Clauses
);
28981 -- List all abstract states that were left unrefined
28983 Report_Unrefined_States
(Available_States
);
28985 Set_Is_Analyzed_Pragma
(N
);
28986 end Analyze_Refined_State_In_Decl_Part
;
28988 ------------------------------------
28989 -- Analyze_Test_Case_In_Decl_Part --
28990 ------------------------------------
28992 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
28993 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28994 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28996 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
28997 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28998 -- denoted by Arg_Nam.
29000 ------------------------------
29001 -- Preanalyze_Test_Case_Arg --
29002 ------------------------------
29004 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
29008 -- Preanalyze the original aspect argument for ASIS or for a generic
29009 -- subprogram to properly capture global references.
29011 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
29015 Arg_Nam
=> Arg_Nam
,
29016 From_Aspect
=> True);
29018 if Present
(Arg
) then
29019 Preanalyze_Assert_Expression
29020 (Expression
(Arg
), Standard_Boolean
);
29024 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
29026 if Present
(Arg
) then
29027 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
29029 end Preanalyze_Test_Case_Arg
;
29033 Restore_Scope
: Boolean := False;
29035 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29038 -- Do not analyze the pragma multiple times
29040 if Is_Analyzed_Pragma
(N
) then
29044 -- Ensure that the formal parameters are visible when analyzing all
29045 -- clauses. This falls out of the general rule of aspects pertaining
29046 -- to subprogram declarations.
29048 if not In_Open_Scopes
(Spec_Id
) then
29049 Restore_Scope
:= True;
29050 Push_Scope
(Spec_Id
);
29052 if Is_Generic_Subprogram
(Spec_Id
) then
29053 Install_Generic_Formals
(Spec_Id
);
29055 Install_Formals
(Spec_Id
);
29059 Preanalyze_Test_Case_Arg
(Name_Requires
);
29060 Preanalyze_Test_Case_Arg
(Name_Ensures
);
29062 if Restore_Scope
then
29066 -- Currently it is not possible to inline pre/postconditions on a
29067 -- subprogram subject to pragma Inline_Always.
29069 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
29071 Set_Is_Analyzed_Pragma
(N
);
29072 end Analyze_Test_Case_In_Decl_Part
;
29078 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
29083 if Present
(List
) then
29084 Elmt
:= First_Elmt
(List
);
29085 while Present
(Elmt
) loop
29086 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
29089 Id
:= Entity_Of
(Node
(Elmt
));
29092 if Id
= Item_Id
then
29103 -----------------------------------
29104 -- Build_Pragma_Check_Equivalent --
29105 -----------------------------------
29107 function Build_Pragma_Check_Equivalent
29109 Subp_Id
: Entity_Id
:= Empty
;
29110 Inher_Id
: Entity_Id
:= Empty
;
29111 Keep_Pragma_Id
: Boolean := False) return Node_Id
29113 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
29114 -- Detect whether node N references a formal parameter subject to
29115 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29116 -- to False to suppress the generation of a reference when analyzing
29119 ------------------------
29120 -- Suppress_Reference --
29121 ------------------------
29123 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
29124 Formal
: Entity_Id
;
29127 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29128 Formal
:= Entity
(N
);
29130 -- The formal parameter is subject to pragma Unreferenced. Prevent
29131 -- the generation of references by resetting the Comes_From_Source
29134 if Is_Formal
(Formal
)
29135 and then Has_Pragma_Unreferenced
(Formal
)
29137 Set_Comes_From_Source
(N
, False);
29142 end Suppress_Reference
;
29144 procedure Suppress_References
is
29145 new Traverse_Proc
(Suppress_Reference
);
29149 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
29150 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29151 Check_Prag
: Node_Id
;
29155 Needs_Wrapper
: Boolean;
29156 pragma Unreferenced
(Needs_Wrapper
);
29158 -- Start of processing for Build_Pragma_Check_Equivalent
29161 -- When the pre- or postcondition is inherited, map the formals of the
29162 -- inherited subprogram to those of the current subprogram. In addition,
29163 -- map primitive operations of the parent type into the corresponding
29164 -- primitive operations of the descendant.
29166 if Present
(Inher_Id
) then
29167 pragma Assert
(Present
(Subp_Id
));
29169 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
29171 -- Use generic machinery to copy inherited pragma, as if it were an
29172 -- instantiation, resetting source locations appropriately, so that
29173 -- expressions inside the inherited pragma use chained locations.
29174 -- This is used in particular in GNATprove to locate precisely
29175 -- messages on a given inherited pragma.
29177 Set_Copied_Sloc_For_Inherited_Pragma
29178 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
29179 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29181 -- Build the inherited class-wide condition
29183 Build_Class_Wide_Expression
29184 (Prag
=> Check_Prag
,
29186 Par_Subp
=> Inher_Id
,
29187 Adjust_Sloc
=> True,
29188 Needs_Wrapper
=> Needs_Wrapper
);
29190 -- If not an inherited condition simply copy the original pragma
29193 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29196 -- Mark the pragma as being internally generated and reset the Analyzed
29199 Set_Analyzed
(Check_Prag
, False);
29200 Set_Comes_From_Source
(Check_Prag
, False);
29202 -- The tree of the original pragma may contain references to the
29203 -- formal parameters of the related subprogram. At the same time
29204 -- the corresponding body may mark the formals as unreferenced:
29206 -- procedure Proc (Formal : ...)
29207 -- with Pre => Formal ...;
29209 -- procedure Proc (Formal : ...) is
29210 -- pragma Unreferenced (Formal);
29213 -- This creates problems because all pragma Check equivalents are
29214 -- analyzed at the end of the body declarations. Since all source
29215 -- references have already been accounted for, reset any references
29216 -- to such formals in the generated pragma Check equivalent.
29218 Suppress_References
(Check_Prag
);
29220 if Present
(Corresponding_Aspect
(Prag
)) then
29221 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
29226 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29227 -- the copied pragma in the newly created pragma, convert the copy into
29228 -- pragma Check by correcting the name and adding a check_kind argument.
29230 if not Keep_Pragma_Id
then
29231 Set_Class_Present
(Check_Prag
, False);
29233 Set_Pragma_Identifier
29234 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
29236 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
29237 Make_Pragma_Argument_Association
(Loc
,
29238 Expression
=> Make_Identifier
(Loc
, Nam
)));
29241 -- Update the error message when the pragma is inherited
29243 if Present
(Inher_Id
) then
29244 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
29246 if Chars
(Msg_Arg
) = Name_Message
then
29247 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
29249 -- Insert "inherited" to improve the error message
29251 if Name_Buffer
(1 .. 8) = "failed p" then
29252 Insert_Str_In_Name_Buffer
("inherited ", 8);
29253 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
29259 end Build_Pragma_Check_Equivalent
;
29261 -----------------------------
29262 -- Check_Applicable_Policy --
29263 -----------------------------
29265 procedure Check_Applicable_Policy
(N
: Node_Id
) is
29269 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
29272 -- No effect if not valid assertion kind name
29274 if not Is_Valid_Assertion_Kind
(Ename
) then
29278 -- Loop through entries in check policy list
29280 PP
:= Opt
.Check_Policy_List
;
29281 while Present
(PP
) loop
29283 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29284 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29288 or else Pnm
= Name_Assertion
29289 or else (Pnm
= Name_Statement_Assertions
29290 and then Nam_In
(Ename
, Name_Assert
,
29291 Name_Assert_And_Cut
,
29293 Name_Loop_Invariant
,
29294 Name_Loop_Variant
))
29296 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
29302 -- In CodePeer mode and GNATprove mode, we need to
29303 -- consider all assertions, unless they are disabled.
29304 -- Force Is_Checked on ignored assertions, in particular
29305 -- because transformations of the AST may depend on
29306 -- assertions being checked (e.g. the translation of
29307 -- attribute 'Loop_Entry).
29309 if CodePeer_Mode
or GNATprove_Mode
then
29310 Set_Is_Checked
(N
, True);
29311 Set_Is_Ignored
(N
, False);
29313 Set_Is_Checked
(N
, False);
29314 Set_Is_Ignored
(N
, True);
29320 Set_Is_Checked
(N
, True);
29321 Set_Is_Ignored
(N
, False);
29323 when Name_Disable
=>
29324 Set_Is_Ignored
(N
, True);
29325 Set_Is_Checked
(N
, False);
29326 Set_Is_Disabled
(N
, True);
29328 -- That should be exhaustive, the null here is a defence
29329 -- against a malformed tree from previous errors.
29338 PP
:= Next_Pragma
(PP
);
29342 -- If there are no specific entries that matched, then we let the
29343 -- setting of assertions govern. Note that this provides the needed
29344 -- compatibility with the RM for the cases of assertion, invariant,
29345 -- precondition, predicate, and postcondition. Note also that
29346 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29348 if Assertions_Enabled
then
29349 Set_Is_Checked
(N
, True);
29350 Set_Is_Ignored
(N
, False);
29352 Set_Is_Checked
(N
, False);
29353 Set_Is_Ignored
(N
, True);
29355 end Check_Applicable_Policy
;
29357 -------------------------------
29358 -- Check_External_Properties --
29359 -------------------------------
29361 procedure Check_External_Properties
29369 -- All properties enabled
29371 if AR
and AW
and ER
and EW
then
29374 -- Async_Readers + Effective_Writes
29375 -- Async_Readers + Async_Writers + Effective_Writes
29377 elsif AR
and EW
and not ER
then
29380 -- Async_Writers + Effective_Reads
29381 -- Async_Readers + Async_Writers + Effective_Reads
29383 elsif AW
and ER
and not EW
then
29386 -- Async_Readers + Async_Writers
29388 elsif AR
and AW
and not ER
and not EW
then
29393 elsif AR
and not AW
and not ER
and not EW
then
29398 elsif AW
and not AR
and not ER
and not EW
then
29403 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29406 end Check_External_Properties
;
29412 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
29416 -- Loop through entries in check policy list
29418 PP
:= Opt
.Check_Policy_List
;
29419 while Present
(PP
) loop
29421 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29422 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29426 or else (Pnm
= Name_Assertion
29427 and then Is_Valid_Assertion_Kind
(Nam
))
29428 or else (Pnm
= Name_Statement_Assertions
29429 and then Nam_In
(Nam
, Name_Assert
,
29430 Name_Assert_And_Cut
,
29432 Name_Loop_Invariant
,
29433 Name_Loop_Variant
))
29435 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
29444 return Name_Ignore
;
29446 when Name_Disable
=>
29447 return Name_Disable
;
29450 raise Program_Error
;
29454 PP
:= Next_Pragma
(PP
);
29459 -- If there are no specific entries that matched, then we let the
29460 -- setting of assertions govern. Note that this provides the needed
29461 -- compatibility with the RM for the cases of assertion, invariant,
29462 -- precondition, predicate, and postcondition.
29464 if Assertions_Enabled
then
29467 return Name_Ignore
;
29471 ---------------------------
29472 -- Check_Missing_Part_Of --
29473 ---------------------------
29475 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
29476 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
29477 -- Determine whether a package denoted by Pack_Id declares at least one
29480 -----------------------
29481 -- Has_Visible_State --
29482 -----------------------
29484 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
29485 Item_Id
: Entity_Id
;
29488 -- Traverse the entity chain of the package trying to find at least
29489 -- one visible abstract state, variable or a package [instantiation]
29490 -- that declares a visible state.
29492 Item_Id
:= First_Entity
(Pack_Id
);
29493 while Present
(Item_Id
)
29494 and then not In_Private_Part
(Item_Id
)
29496 -- Do not consider internally generated items
29498 if not Comes_From_Source
(Item_Id
) then
29501 -- Do not consider generic formals or their corresponding actuals
29502 -- because they are not part of a visible state. Note that both
29503 -- entities are marked as hidden.
29505 elsif Is_Hidden
(Item_Id
) then
29508 -- A visible state has been found. Note that constants are not
29509 -- considered here because it is not possible to determine whether
29510 -- they depend on variable input. This check is left to the SPARK
29513 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
29516 -- Recursively peek into nested packages and instantiations
29518 elsif Ekind
(Item_Id
) = E_Package
29519 and then Has_Visible_State
(Item_Id
)
29524 Next_Entity
(Item_Id
);
29528 end Has_Visible_State
;
29532 Pack_Id
: Entity_Id
;
29533 Placement
: State_Space_Kind
;
29535 -- Start of processing for Check_Missing_Part_Of
29538 -- Do not consider abstract states, variables or package instantiations
29539 -- coming from an instance as those always inherit the Part_Of indicator
29540 -- of the instance itself.
29542 if In_Instance
then
29545 -- Do not consider internally generated entities as these can never
29546 -- have a Part_Of indicator.
29548 elsif not Comes_From_Source
(Item_Id
) then
29551 -- Perform these checks only when SPARK_Mode is enabled as they will
29552 -- interfere with standard Ada rules and produce false positives.
29554 elsif SPARK_Mode
/= On
then
29557 -- Do not consider constants, because the compiler cannot accurately
29558 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29559 -- act as a hidden state of a package.
29561 elsif Ekind
(Item_Id
) = E_Constant
then
29565 -- Find where the abstract state, variable or package instantiation
29566 -- lives with respect to the state space.
29568 Find_Placement_In_State_Space
29569 (Item_Id
=> Item_Id
,
29570 Placement
=> Placement
,
29571 Pack_Id
=> Pack_Id
);
29573 -- Items that appear in a non-package construct (subprogram, block, etc)
29574 -- do not require a Part_Of indicator because they can never act as a
29577 if Placement
= Not_In_Package
then
29580 -- An item declared in the body state space of a package always act as a
29581 -- constituent and does not need explicit Part_Of indicator.
29583 elsif Placement
= Body_State_Space
then
29586 -- In general an item declared in the visible state space of a package
29587 -- does not require a Part_Of indicator. The only exception is when the
29588 -- related package is a nongeneric private child unit, in which case
29589 -- Part_Of must denote a state in the parent unit or in one of its
29592 elsif Placement
= Visible_State_Space
then
29593 if Is_Child_Unit
(Pack_Id
)
29594 and then not Is_Generic_Unit
(Pack_Id
)
29595 and then Is_Private_Descendant
(Pack_Id
)
29597 -- A package instantiation does not need a Part_Of indicator when
29598 -- the related generic template has no visible state.
29600 if Ekind
(Item_Id
) = E_Package
29601 and then Is_Generic_Instance
(Item_Id
)
29602 and then not Has_Visible_State
(Item_Id
)
29606 -- All other cases require Part_Of
29610 ("indicator Part_Of is required in this context "
29611 & "(SPARK RM 7.2.6(3))", Item_Id
);
29612 Error_Msg_Name_1
:= Chars
(Pack_Id
);
29614 ("\& is declared in the visible part of private child "
29615 & "unit %", Item_Id
);
29619 -- When the item appears in the private state space of a package, it
29620 -- must be a part of some state declared by the said package.
29622 else pragma Assert
(Placement
= Private_State_Space
);
29624 -- The related package does not declare a state, the item cannot act
29625 -- as a Part_Of constituent.
29627 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
29630 -- A package instantiation does not need a Part_Of indicator when the
29631 -- related generic template has no visible state.
29633 elsif Ekind
(Item_Id
) = E_Package
29634 and then Is_Generic_Instance
(Item_Id
)
29635 and then not Has_Visible_State
(Item_Id
)
29639 -- All other cases require Part_Of
29643 ("indicator Part_Of is required in this context "
29644 & "(SPARK RM 7.2.6(2))", Item_Id
);
29645 Error_Msg_Name_1
:= Chars
(Pack_Id
);
29647 ("\& is declared in the private part of package %", Item_Id
);
29650 end Check_Missing_Part_Of
;
29652 ---------------------------------------------------
29653 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29654 ---------------------------------------------------
29656 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29658 Spec_Id
: Entity_Id
)
29661 if Warn_On_Redundant_Constructs
29662 and then Has_Pragma_Inline_Always
(Spec_Id
)
29663 and then Assertions_Enabled
29665 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
29667 if From_Aspect_Specification
(Prag
) then
29669 ("aspect % not enforced on inlined subprogram &?r?",
29670 Corresponding_Aspect
(Prag
), Spec_Id
);
29673 ("pragma % not enforced on inlined subprogram &?r?",
29677 end Check_Postcondition_Use_In_Inlined_Subprogram
;
29679 -------------------------------------
29680 -- Check_State_And_Constituent_Use --
29681 -------------------------------------
29683 procedure Check_State_And_Constituent_Use
29684 (States
: Elist_Id
;
29685 Constits
: Elist_Id
;
29688 Constit_Elmt
: Elmt_Id
;
29689 Constit_Id
: Entity_Id
;
29690 State_Id
: Entity_Id
;
29693 -- Nothing to do if there are no states or constituents
29695 if No
(States
) or else No
(Constits
) then
29699 -- Inspect the list of constituents and try to determine whether its
29700 -- encapsulating state is in list States.
29702 Constit_Elmt
:= First_Elmt
(Constits
);
29703 while Present
(Constit_Elmt
) loop
29704 Constit_Id
:= Node
(Constit_Elmt
);
29706 -- Determine whether the constituent is part of an encapsulating
29707 -- state that appears in the same context and if this is the case,
29708 -- emit an error (SPARK RM 7.2.6(7)).
29710 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
29712 if Present
(State_Id
) then
29713 Error_Msg_Name_1
:= Chars
(Constit_Id
);
29715 ("cannot mention state & and its constituent % in the same "
29716 & "context", Context
, State_Id
);
29720 Next_Elmt
(Constit_Elmt
);
29722 end Check_State_And_Constituent_Use
;
29724 ---------------------------------------------
29725 -- Collect_Inherited_Class_Wide_Conditions --
29726 ---------------------------------------------
29728 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
29729 Parent_Subp
: constant Entity_Id
:=
29730 Ultimate_Alias
(Overridden_Operation
(Subp
));
29731 -- The Overridden_Operation may itself be inherited and as such have no
29732 -- explicit contract.
29734 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
29735 In_Spec_Expr
: Boolean;
29736 Installed
: Boolean;
29738 New_Prag
: Node_Id
;
29741 Installed
:= False;
29743 -- Iterate over the contract of the overridden subprogram to find all
29744 -- inherited class-wide pre- and postconditions.
29746 if Present
(Prags
) then
29747 Prag
:= Pre_Post_Conditions
(Prags
);
29749 while Present
(Prag
) loop
29750 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
29751 Name_Precondition
, Name_Postcondition
)
29752 and then Class_Present
(Prag
)
29754 -- The generated pragma must be analyzed in the context of
29755 -- the subprogram, to make its formals visible. In addition,
29756 -- we must inhibit freezing and full analysis because the
29757 -- controlling type of the subprogram is not frozen yet, and
29758 -- may have further primitives.
29760 if not Installed
then
29763 Install_Formals
(Subp
);
29764 In_Spec_Expr
:= In_Spec_Expression
;
29765 In_Spec_Expression
:= True;
29769 Build_Pragma_Check_Equivalent
29770 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
29772 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
29773 Preanalyze
(New_Prag
);
29775 -- Prevent further analysis in subsequent processing of the
29776 -- current list of declarations
29778 Set_Analyzed
(New_Prag
);
29781 Prag
:= Next_Pragma
(Prag
);
29785 In_Spec_Expression
:= In_Spec_Expr
;
29789 end Collect_Inherited_Class_Wide_Conditions
;
29791 ---------------------------------------
29792 -- Collect_Subprogram_Inputs_Outputs --
29793 ---------------------------------------
29795 procedure Collect_Subprogram_Inputs_Outputs
29796 (Subp_Id
: Entity_Id
;
29797 Synthesize
: Boolean := False;
29798 Subp_Inputs
: in out Elist_Id
;
29799 Subp_Outputs
: in out Elist_Id
;
29800 Global_Seen
: out Boolean)
29802 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
29803 -- Collect all relevant items from a dependency clause
29805 procedure Collect_Global_List
29807 Mode
: Name_Id
:= Name_Input
);
29808 -- Collect all relevant items from a global list
29810 -------------------------------
29811 -- Collect_Dependency_Clause --
29812 -------------------------------
29814 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
29815 procedure Collect_Dependency_Item
29817 Is_Input
: Boolean);
29818 -- Add an item to the proper subprogram input or output collection
29820 -----------------------------
29821 -- Collect_Dependency_Item --
29822 -----------------------------
29824 procedure Collect_Dependency_Item
29826 Is_Input
: Boolean)
29831 -- Nothing to collect when the item is null
29833 if Nkind
(Item
) = N_Null
then
29836 -- Ditto for attribute 'Result
29838 elsif Is_Attribute_Result
(Item
) then
29841 -- Multiple items appear as an aggregate
29843 elsif Nkind
(Item
) = N_Aggregate
then
29844 Extra
:= First
(Expressions
(Item
));
29845 while Present
(Extra
) loop
29846 Collect_Dependency_Item
(Extra
, Is_Input
);
29850 -- Otherwise this is a solitary item
29854 Append_New_Elmt
(Item
, Subp_Inputs
);
29856 Append_New_Elmt
(Item
, Subp_Outputs
);
29859 end Collect_Dependency_Item
;
29861 -- Start of processing for Collect_Dependency_Clause
29864 if Nkind
(Clause
) = N_Null
then
29867 -- A dependency clause appears as component association
29869 elsif Nkind
(Clause
) = N_Component_Association
then
29870 Collect_Dependency_Item
29871 (Item
=> Expression
(Clause
),
29874 Collect_Dependency_Item
29875 (Item
=> First
(Choices
(Clause
)),
29876 Is_Input
=> False);
29878 -- To accommodate partial decoration of disabled SPARK features, this
29879 -- routine may be called with illegal input. If this is the case, do
29880 -- not raise Program_Error.
29885 end Collect_Dependency_Clause
;
29887 -------------------------
29888 -- Collect_Global_List --
29889 -------------------------
29891 procedure Collect_Global_List
29893 Mode
: Name_Id
:= Name_Input
)
29895 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
29896 -- Add an item to the proper subprogram input or output collection
29898 -------------------------
29899 -- Collect_Global_Item --
29900 -------------------------
29902 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
29904 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
29905 Append_New_Elmt
(Item
, Subp_Inputs
);
29908 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
29909 Append_New_Elmt
(Item
, Subp_Outputs
);
29911 end Collect_Global_Item
;
29918 -- Start of processing for Collect_Global_List
29921 if Nkind
(List
) = N_Null
then
29924 -- Single global item declaration
29926 elsif Nkind_In
(List
, N_Expanded_Name
,
29928 N_Selected_Component
)
29930 Collect_Global_Item
(List
, Mode
);
29932 -- Simple global list or moded global list declaration
29934 elsif Nkind
(List
) = N_Aggregate
then
29935 if Present
(Expressions
(List
)) then
29936 Item
:= First
(Expressions
(List
));
29937 while Present
(Item
) loop
29938 Collect_Global_Item
(Item
, Mode
);
29943 Assoc
:= First
(Component_Associations
(List
));
29944 while Present
(Assoc
) loop
29945 Collect_Global_List
29946 (List
=> Expression
(Assoc
),
29947 Mode
=> Chars
(First
(Choices
(Assoc
))));
29952 -- To accommodate partial decoration of disabled SPARK features, this
29953 -- routine may be called with illegal input. If this is the case, do
29954 -- not raise Program_Error.
29959 end Collect_Global_List
;
29966 Formal
: Entity_Id
;
29968 Spec_Id
: Entity_Id
:= Empty
;
29969 Subp_Decl
: Node_Id
;
29972 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29975 Global_Seen
:= False;
29977 -- Process all formal parameters of entries, [generic] subprograms, and
29980 if Ekind_In
(Subp_Id
, E_Entry
,
29983 E_Generic_Function
,
29984 E_Generic_Procedure
,
29988 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
29989 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29991 -- Process all formal parameters
29993 Formal
:= First_Entity
(Spec_Id
);
29994 while Present
(Formal
) loop
29995 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
29996 Append_New_Elmt
(Formal
, Subp_Inputs
);
29999 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
30000 Append_New_Elmt
(Formal
, Subp_Outputs
);
30002 -- Out parameters can act as inputs when the related type is
30003 -- tagged, unconstrained array, unconstrained record, or record
30004 -- with unconstrained components.
30006 if Ekind
(Formal
) = E_Out_Parameter
30007 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
30009 Append_New_Elmt
(Formal
, Subp_Inputs
);
30013 Next_Entity
(Formal
);
30016 -- Otherwise the input denotes a task type, a task body, or the
30017 -- anonymous object created for a single task type.
30019 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
30020 or else Is_Single_Task_Object
(Subp_Id
)
30022 Subp_Decl
:= Declaration_Node
(Subp_Id
);
30023 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30026 -- When processing an entry, subprogram or task body, look for pragmas
30027 -- Refined_Depends and Refined_Global as they specify the inputs and
30030 if Is_Entry_Body
(Subp_Id
)
30031 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
30033 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
30034 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
30036 -- Subprogram declaration or stand-alone body case, look for pragmas
30037 -- Depends and Global
30040 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
30041 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
30044 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30045 -- because it provides finer granularity of inputs and outputs.
30047 if Present
(Global
) then
30048 Global_Seen
:= True;
30049 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
30051 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30052 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30053 -- the inputs and outputs from [Refined_]Depends.
30055 elsif Synthesize
and then Present
(Depends
) then
30056 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
30058 -- Multiple dependency clauses appear as an aggregate
30060 if Nkind
(Clauses
) = N_Aggregate
then
30061 Clause
:= First
(Component_Associations
(Clauses
));
30062 while Present
(Clause
) loop
30063 Collect_Dependency_Clause
(Clause
);
30067 -- Otherwise this is a single dependency clause
30070 Collect_Dependency_Clause
(Clauses
);
30074 -- The current instance of a protected type acts as a formal parameter
30075 -- of mode IN for functions and IN OUT for entries and procedures
30076 -- (SPARK RM 6.1.4).
30078 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
30079 Typ
:= Scope
(Spec_Id
);
30081 -- Use the anonymous object when the type is single protected
30083 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30084 Typ
:= Anonymous_Object
(Typ
);
30087 Append_New_Elmt
(Typ
, Subp_Inputs
);
30089 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
30090 Append_New_Elmt
(Typ
, Subp_Outputs
);
30093 -- The current instance of a task type acts as a formal parameter of
30094 -- mode IN OUT (SPARK RM 6.1.4).
30096 elsif Ekind
(Spec_Id
) = E_Task_Type
then
30099 -- Use the anonymous object when the type is single task
30101 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30102 Typ
:= Anonymous_Object
(Typ
);
30105 Append_New_Elmt
(Typ
, Subp_Inputs
);
30106 Append_New_Elmt
(Typ
, Subp_Outputs
);
30108 elsif Is_Single_Task_Object
(Spec_Id
) then
30109 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
30110 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
30112 end Collect_Subprogram_Inputs_Outputs
;
30114 ---------------------------
30115 -- Contract_Freeze_Error --
30116 ---------------------------
30118 procedure Contract_Freeze_Error
30119 (Contract_Id
: Entity_Id
;
30120 Freeze_Id
: Entity_Id
)
30123 Error_Msg_Name_1
:= Chars
(Contract_Id
);
30124 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30127 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
30129 ("\all contractual items must be declared before body #", Contract_Id
);
30130 end Contract_Freeze_Error
;
30132 ---------------------------------
30133 -- Delay_Config_Pragma_Analyze --
30134 ---------------------------------
30136 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
30138 return Nam_In
(Pragma_Name_Unmapped
(N
),
30139 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
30140 end Delay_Config_Pragma_Analyze
;
30142 -----------------------
30143 -- Duplication_Error --
30144 -----------------------
30146 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
30147 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
30148 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
30151 Error_Msg_Sloc
:= Sloc
(Prev
);
30152 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30154 -- Emit a precise message to distinguish between source pragmas and
30155 -- pragmas generated from aspects. The ordering of the two pragmas is
30159 -- Prag -- duplicate
30161 -- No error is emitted when both pragmas come from aspects because this
30162 -- is already detected by the general aspect analysis mechanism.
30164 if Prag_From_Asp
and Prev_From_Asp
then
30166 elsif Prag_From_Asp
then
30167 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
30168 elsif Prev_From_Asp
then
30169 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
30171 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
30173 end Duplication_Error
;
30175 ------------------------------
30176 -- Find_Encapsulating_State --
30177 ------------------------------
30179 function Find_Encapsulating_State
30180 (States
: Elist_Id
;
30181 Constit_Id
: Entity_Id
) return Entity_Id
30183 State_Id
: Entity_Id
;
30186 -- Since a constituent may be part of a larger constituent set, climb
30187 -- the encapsulating state chain looking for a state that appears in
30190 State_Id
:= Encapsulating_State
(Constit_Id
);
30191 while Present
(State_Id
) loop
30192 if Contains
(States
, State_Id
) then
30196 State_Id
:= Encapsulating_State
(State_Id
);
30200 end Find_Encapsulating_State
;
30202 --------------------------
30203 -- Find_Related_Context --
30204 --------------------------
30206 function Find_Related_Context
30208 Do_Checks
: Boolean := False) return Node_Id
30213 Stmt
:= Prev
(Prag
);
30214 while Present
(Stmt
) loop
30216 -- Skip prior pragmas, but check for duplicates
30218 if Nkind
(Stmt
) = N_Pragma
then
30220 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
30227 -- Skip internally generated code
30229 elsif not Comes_From_Source
(Stmt
) then
30231 -- The anonymous object created for a single concurrent type is a
30232 -- suitable context.
30234 if Nkind
(Stmt
) = N_Object_Declaration
30235 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30240 -- Return the current source construct
30250 end Find_Related_Context
;
30252 --------------------------------------
30253 -- Find_Related_Declaration_Or_Body --
30254 --------------------------------------
30256 function Find_Related_Declaration_Or_Body
30258 Do_Checks
: Boolean := False) return Node_Id
30260 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
30262 procedure Expression_Function_Error
;
30263 -- Emit an error concerning pragma Prag that illegaly applies to an
30264 -- expression function.
30266 -------------------------------
30267 -- Expression_Function_Error --
30268 -------------------------------
30270 procedure Expression_Function_Error
is
30272 Error_Msg_Name_1
:= Prag_Nam
;
30274 -- Emit a precise message to distinguish between source pragmas and
30275 -- pragmas generated from aspects.
30277 if From_Aspect_Specification
(Prag
) then
30279 ("aspect % cannot apply to a stand alone expression function",
30283 ("pragma % cannot apply to a stand alone expression function",
30286 end Expression_Function_Error
;
30290 Context
: constant Node_Id
:= Parent
(Prag
);
30293 Look_For_Body
: constant Boolean :=
30294 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
30295 Name_Refined_Global
,
30297 Name_Refined_State
);
30298 -- Refinement pragmas must be associated with a subprogram body [stub]
30300 -- Start of processing for Find_Related_Declaration_Or_Body
30303 Stmt
:= Prev
(Prag
);
30304 while Present
(Stmt
) loop
30306 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30307 -- by splitting a complex pre/postcondition are not considered to
30310 if Nkind
(Stmt
) = N_Pragma
then
30312 and then not Split_PPC
(Stmt
)
30313 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
30320 -- Emit an error when a refinement pragma appears on an expression
30321 -- function without a completion.
30324 and then Look_For_Body
30325 and then Nkind
(Stmt
) = N_Subprogram_Declaration
30326 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
30327 and then not Has_Completion
(Defining_Entity
(Stmt
))
30329 Expression_Function_Error
;
30332 -- The refinement pragma applies to a subprogram body stub
30334 elsif Look_For_Body
30335 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
30339 -- Skip internally generated code
30341 elsif not Comes_From_Source
(Stmt
) then
30343 -- The anonymous object created for a single concurrent type is a
30344 -- suitable context.
30346 if Nkind
(Stmt
) = N_Object_Declaration
30347 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30351 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
30353 -- The subprogram declaration is an internally generated spec
30354 -- for an expression function.
30356 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30359 -- The subprogram declaration is an internally generated spec
30360 -- for a stand-alone subrogram body declared inside a protected
30363 elsif Present
(Corresponding_Body
(Stmt
))
30364 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
30365 and then Is_Protected_Type
(Current_Scope
)
30369 -- The subprogram is actually an instance housed within an
30370 -- anonymous wrapper package.
30372 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30377 -- Return the current construct which is either a subprogram body,
30378 -- a subprogram declaration or is illegal.
30387 -- If we fall through, then the pragma was either the first declaration
30388 -- or it was preceded by other pragmas and no source constructs.
30390 -- The pragma is associated with a library-level subprogram
30392 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
30393 return Unit
(Parent
(Context
));
30395 -- The pragma appears inside the declarations of an entry body
30397 elsif Nkind
(Context
) = N_Entry_Body
then
30400 -- The pragma appears inside the statements of a subprogram body. This
30401 -- placement is the result of subprogram contract expansion.
30403 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
30404 return Parent
(Context
);
30406 -- The pragma appears inside the declarative part of a package body
30408 elsif Nkind
(Context
) = N_Package_Body
then
30411 -- The pragma appears inside the declarative part of a subprogram body
30413 elsif Nkind
(Context
) = N_Subprogram_Body
then
30416 -- The pragma appears inside the declarative part of a task body
30418 elsif Nkind
(Context
) = N_Task_Body
then
30421 -- The pragma appears inside the visible part of a package specification
30423 elsif Nkind
(Context
) = N_Package_Specification
then
30424 return Parent
(Context
);
30426 -- The pragma is a byproduct of aspect expansion, return the related
30427 -- context of the original aspect. This case has a lower priority as
30428 -- the above circuitry pinpoints precisely the related context.
30430 elsif Present
(Corresponding_Aspect
(Prag
)) then
30431 return Parent
(Corresponding_Aspect
(Prag
));
30433 -- No candidate subprogram [body] found
30438 end Find_Related_Declaration_Or_Body
;
30440 ----------------------------------
30441 -- Find_Related_Package_Or_Body --
30442 ----------------------------------
30444 function Find_Related_Package_Or_Body
30446 Do_Checks
: Boolean := False) return Node_Id
30448 Context
: constant Node_Id
:= Parent
(Prag
);
30449 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
30453 Stmt
:= Prev
(Prag
);
30454 while Present
(Stmt
) loop
30456 -- Skip prior pragmas, but check for duplicates
30458 if Nkind
(Stmt
) = N_Pragma
then
30459 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
30465 -- Skip internally generated code
30467 elsif not Comes_From_Source
(Stmt
) then
30468 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
30470 -- The subprogram declaration is an internally generated spec
30471 -- for an expression function.
30473 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30476 -- The subprogram is actually an instance housed within an
30477 -- anonymous wrapper package.
30479 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30484 -- Return the current source construct which is illegal
30493 -- If we fall through, then the pragma was either the first declaration
30494 -- or it was preceded by other pragmas and no source constructs.
30496 -- The pragma is associated with a package. The immediate context in
30497 -- this case is the specification of the package.
30499 if Nkind
(Context
) = N_Package_Specification
then
30500 return Parent
(Context
);
30502 -- The pragma appears in the declarations of a package body
30504 elsif Nkind
(Context
) = N_Package_Body
then
30507 -- The pragma appears in the statements of a package body
30509 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
30510 and then Nkind
(Parent
(Context
)) = N_Package_Body
30512 return Parent
(Context
);
30514 -- The pragma is a byproduct of aspect expansion, return the related
30515 -- context of the original aspect. This case has a lower priority as
30516 -- the above circuitry pinpoints precisely the related context.
30518 elsif Present
(Corresponding_Aspect
(Prag
)) then
30519 return Parent
(Corresponding_Aspect
(Prag
));
30521 -- No candidate package [body] found
30526 end Find_Related_Package_Or_Body
;
30532 function Get_Argument
30534 Context_Id
: Entity_Id
:= Empty
) return Node_Id
30536 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
30539 -- Use the expression of the original aspect when compiling for ASIS or
30540 -- when analyzing the template of a generic unit. In both cases the
30541 -- aspect's tree must be decorated to allow for ASIS queries or to save
30542 -- the global references in the generic context.
30544 if From_Aspect_Specification
(Prag
)
30545 and then (ASIS_Mode
or else (Present
(Context_Id
)
30546 and then Is_Generic_Unit
(Context_Id
)))
30548 return Corresponding_Aspect
(Prag
);
30550 -- Otherwise use the expression of the pragma
30552 elsif Present
(Args
) then
30553 return First
(Args
);
30560 -------------------------
30561 -- Get_Base_Subprogram --
30562 -------------------------
30564 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
30566 -- Follow subprogram renaming chain
30568 if Is_Subprogram
(Def_Id
)
30569 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
30570 N_Subprogram_Renaming_Declaration
30571 and then Present
(Alias
(Def_Id
))
30573 return Alias
(Def_Id
);
30577 end Get_Base_Subprogram
;
30579 -----------------------
30580 -- Get_SPARK_Mode_Type --
30581 -----------------------
30583 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
30585 if N
= Name_On
then
30587 elsif N
= Name_Off
then
30590 -- Any other argument is illegal. Assume that no SPARK mode applies to
30591 -- avoid potential cascaded errors.
30596 end Get_SPARK_Mode_Type
;
30598 ------------------------------------
30599 -- Get_SPARK_Mode_From_Annotation --
30600 ------------------------------------
30602 function Get_SPARK_Mode_From_Annotation
30603 (N
: Node_Id
) return SPARK_Mode_Type
30608 if Nkind
(N
) = N_Aspect_Specification
then
30609 Mode
:= Expression
(N
);
30611 else pragma Assert
(Nkind
(N
) = N_Pragma
);
30612 Mode
:= First
(Pragma_Argument_Associations
(N
));
30614 if Present
(Mode
) then
30615 Mode
:= Get_Pragma_Arg
(Mode
);
30619 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30621 if Present
(Mode
) then
30622 if Nkind
(Mode
) = N_Identifier
then
30623 return Get_SPARK_Mode_Type
(Chars
(Mode
));
30625 -- In case of a malformed aspect or pragma, return the default None
30631 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30636 end Get_SPARK_Mode_From_Annotation
;
30638 ---------------------------
30639 -- Has_Extra_Parentheses --
30640 ---------------------------
30642 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
30646 -- The aggregate should not have an expression list because a clause
30647 -- is always interpreted as a component association. The only way an
30648 -- expression list can sneak in is by adding extra parentheses around
30649 -- the individual clauses:
30651 -- Depends (Output => Input) -- proper form
30652 -- Depends ((Output => Input)) -- extra parentheses
30654 -- Since the extra parentheses are not allowed by the syntax of the
30655 -- pragma, flag them now to avoid emitting misleading errors down the
30658 if Nkind
(Clause
) = N_Aggregate
30659 and then Present
(Expressions
(Clause
))
30661 Expr
:= First
(Expressions
(Clause
));
30662 while Present
(Expr
) loop
30664 -- A dependency clause surrounded by extra parentheses appears
30665 -- as an aggregate of component associations with an optional
30666 -- Paren_Count set.
30668 if Nkind
(Expr
) = N_Aggregate
30669 and then Present
(Component_Associations
(Expr
))
30672 ("dependency clause contains extra parentheses", Expr
);
30674 -- Otherwise the expression is a malformed construct
30677 SPARK_Msg_N
("malformed dependency clause", Expr
);
30687 end Has_Extra_Parentheses
;
30693 procedure Initialize
is
30704 Dummy
:= Dummy
+ 1;
30707 -----------------------------
30708 -- Is_Config_Static_String --
30709 -----------------------------
30711 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
30713 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
30714 -- This is an internal recursive function that is just like the outer
30715 -- function except that it adds the string to the name buffer rather
30716 -- than placing the string in the name buffer.
30718 ------------------------------
30719 -- Add_Config_Static_String --
30720 ------------------------------
30722 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
30729 if Nkind
(N
) = N_Op_Concat
then
30730 if Add_Config_Static_String
(Left_Opnd
(N
)) then
30731 N
:= Right_Opnd
(N
);
30737 if Nkind
(N
) /= N_String_Literal
then
30738 Error_Msg_N
("string literal expected for pragma argument", N
);
30742 for J
in 1 .. String_Length
(Strval
(N
)) loop
30743 C
:= Get_String_Char
(Strval
(N
), J
);
30745 if not In_Character_Range
(C
) then
30747 ("string literal contains invalid wide character",
30748 Sloc
(N
) + 1 + Source_Ptr
(J
));
30752 Add_Char_To_Name_Buffer
(Get_Character
(C
));
30757 end Add_Config_Static_String
;
30759 -- Start of processing for Is_Config_Static_String
30764 return Add_Config_Static_String
(Arg
);
30765 end Is_Config_Static_String
;
30767 -------------------------------
30768 -- Is_Elaboration_SPARK_Mode --
30769 -------------------------------
30771 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
30774 (Nkind
(N
) = N_Pragma
30775 and then Pragma_Name
(N
) = Name_SPARK_Mode
30776 and then Is_List_Member
(N
));
30778 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30779 -- appears in the statement part of the body.
30782 Present
(Parent
(N
))
30783 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
30784 and then List_Containing
(N
) = Statements
(Parent
(N
))
30785 and then Present
(Parent
(Parent
(N
)))
30786 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
30787 end Is_Elaboration_SPARK_Mode
;
30789 -----------------------
30790 -- Is_Enabled_Pragma --
30791 -----------------------
30793 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
30797 if Present
(Prag
) then
30798 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30800 if Present
(Arg
) then
30801 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
30803 -- The lack of a Boolean argument automatically enables the pragma
30809 -- The pragma is missing, therefore it is not enabled
30814 end Is_Enabled_Pragma
;
30816 -----------------------------------------
30817 -- Is_Non_Significant_Pragma_Reference --
30818 -----------------------------------------
30820 -- This function makes use of the following static table which indicates
30821 -- whether appearance of some name in a given pragma is to be considered
30822 -- as a reference for the purposes of warnings about unreferenced objects.
30824 -- -1 indicates that appearence in any argument is significant
30825 -- 0 indicates that appearance in any argument is not significant
30826 -- +n indicates that appearance as argument n is significant, but all
30827 -- other arguments are not significant
30828 -- 9n arguments from n on are significant, before n insignificant
30830 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
30831 (Pragma_Abort_Defer
=> -1,
30832 Pragma_Abstract_State
=> -1,
30833 Pragma_Acc_Data
=> 0,
30834 Pragma_Acc_Kernels
=> 0,
30835 Pragma_Acc_Loop
=> 0,
30836 Pragma_Acc_Parallel
=> 0,
30837 Pragma_Ada_83
=> -1,
30838 Pragma_Ada_95
=> -1,
30839 Pragma_Ada_05
=> -1,
30840 Pragma_Ada_2005
=> -1,
30841 Pragma_Ada_12
=> -1,
30842 Pragma_Ada_2012
=> -1,
30843 Pragma_Ada_2020
=> -1,
30844 Pragma_All_Calls_Remote
=> -1,
30845 Pragma_Allow_Integer_Address
=> -1,
30846 Pragma_Annotate
=> 93,
30847 Pragma_Assert
=> -1,
30848 Pragma_Assert_And_Cut
=> -1,
30849 Pragma_Assertion_Policy
=> 0,
30850 Pragma_Assume
=> -1,
30851 Pragma_Assume_No_Invalid_Values
=> 0,
30852 Pragma_Async_Readers
=> 0,
30853 Pragma_Async_Writers
=> 0,
30854 Pragma_Asynchronous
=> 0,
30855 Pragma_Atomic
=> 0,
30856 Pragma_Atomic_Components
=> 0,
30857 Pragma_Attach_Handler
=> -1,
30858 Pragma_Attribute_Definition
=> 92,
30859 Pragma_Check
=> -1,
30860 Pragma_Check_Float_Overflow
=> 0,
30861 Pragma_Check_Name
=> 0,
30862 Pragma_Check_Policy
=> 0,
30863 Pragma_CPP_Class
=> 0,
30864 Pragma_CPP_Constructor
=> 0,
30865 Pragma_CPP_Virtual
=> 0,
30866 Pragma_CPP_Vtable
=> 0,
30868 Pragma_C_Pass_By_Copy
=> 0,
30869 Pragma_Comment
=> -1,
30870 Pragma_Common_Object
=> 0,
30871 Pragma_Compile_Time_Error
=> -1,
30872 Pragma_Compile_Time_Warning
=> -1,
30873 Pragma_Compiler_Unit
=> -1,
30874 Pragma_Compiler_Unit_Warning
=> -1,
30875 Pragma_Complete_Representation
=> 0,
30876 Pragma_Complex_Representation
=> 0,
30877 Pragma_Component_Alignment
=> 0,
30878 Pragma_Constant_After_Elaboration
=> 0,
30879 Pragma_Contract_Cases
=> -1,
30880 Pragma_Controlled
=> 0,
30881 Pragma_Convention
=> 0,
30882 Pragma_Convention_Identifier
=> 0,
30883 Pragma_Deadline_Floor
=> -1,
30884 Pragma_Debug
=> -1,
30885 Pragma_Debug_Policy
=> 0,
30886 Pragma_Detect_Blocking
=> 0,
30887 Pragma_Default_Initial_Condition
=> -1,
30888 Pragma_Default_Scalar_Storage_Order
=> 0,
30889 Pragma_Default_Storage_Pool
=> 0,
30890 Pragma_Depends
=> -1,
30891 Pragma_Disable_Atomic_Synchronization
=> 0,
30892 Pragma_Discard_Names
=> 0,
30893 Pragma_Dispatching_Domain
=> -1,
30894 Pragma_Effective_Reads
=> 0,
30895 Pragma_Effective_Writes
=> 0,
30896 Pragma_Elaborate
=> 0,
30897 Pragma_Elaborate_All
=> 0,
30898 Pragma_Elaborate_Body
=> 0,
30899 Pragma_Elaboration_Checks
=> 0,
30900 Pragma_Eliminate
=> 0,
30901 Pragma_Enable_Atomic_Synchronization
=> 0,
30902 Pragma_Export
=> -1,
30903 Pragma_Export_Function
=> -1,
30904 Pragma_Export_Object
=> -1,
30905 Pragma_Export_Procedure
=> -1,
30906 Pragma_Export_Value
=> -1,
30907 Pragma_Export_Valued_Procedure
=> -1,
30908 Pragma_Extend_System
=> -1,
30909 Pragma_Extensions_Allowed
=> 0,
30910 Pragma_Extensions_Visible
=> 0,
30911 Pragma_External
=> -1,
30912 Pragma_Favor_Top_Level
=> 0,
30913 Pragma_External_Name_Casing
=> 0,
30914 Pragma_Fast_Math
=> 0,
30915 Pragma_Finalize_Storage_Only
=> 0,
30917 Pragma_Global
=> -1,
30918 Pragma_Ident
=> -1,
30919 Pragma_Ignore_Pragma
=> 0,
30920 Pragma_Implementation_Defined
=> -1,
30921 Pragma_Implemented
=> -1,
30922 Pragma_Implicit_Packing
=> 0,
30923 Pragma_Import
=> 93,
30924 Pragma_Import_Function
=> 0,
30925 Pragma_Import_Object
=> 0,
30926 Pragma_Import_Procedure
=> 0,
30927 Pragma_Import_Valued_Procedure
=> 0,
30928 Pragma_Independent
=> 0,
30929 Pragma_Independent_Components
=> 0,
30930 Pragma_Initial_Condition
=> -1,
30931 Pragma_Initialize_Scalars
=> 0,
30932 Pragma_Initializes
=> -1,
30933 Pragma_Inline
=> 0,
30934 Pragma_Inline_Always
=> 0,
30935 Pragma_Inline_Generic
=> 0,
30936 Pragma_Inspection_Point
=> -1,
30937 Pragma_Interface
=> 92,
30938 Pragma_Interface_Name
=> 0,
30939 Pragma_Interrupt_Handler
=> -1,
30940 Pragma_Interrupt_Priority
=> -1,
30941 Pragma_Interrupt_State
=> -1,
30942 Pragma_Invariant
=> -1,
30943 Pragma_Keep_Names
=> 0,
30944 Pragma_License
=> 0,
30945 Pragma_Link_With
=> -1,
30946 Pragma_Linker_Alias
=> -1,
30947 Pragma_Linker_Constructor
=> -1,
30948 Pragma_Linker_Destructor
=> -1,
30949 Pragma_Linker_Options
=> -1,
30950 Pragma_Linker_Section
=> -1,
30952 Pragma_Lock_Free
=> 0,
30953 Pragma_Locking_Policy
=> 0,
30954 Pragma_Loop_Invariant
=> -1,
30955 Pragma_Loop_Optimize
=> 0,
30956 Pragma_Loop_Variant
=> -1,
30957 Pragma_Machine_Attribute
=> -1,
30959 Pragma_Main_Storage
=> -1,
30960 Pragma_Max_Entry_Queue_Depth
=> 0,
30961 Pragma_Max_Queue_Length
=> 0,
30962 Pragma_Memory_Size
=> 0,
30963 Pragma_No_Return
=> 0,
30964 Pragma_No_Body
=> 0,
30965 Pragma_No_Component_Reordering
=> -1,
30966 Pragma_No_Elaboration_Code_All
=> 0,
30967 Pragma_No_Heap_Finalization
=> 0,
30968 Pragma_No_Inline
=> 0,
30969 Pragma_No_Run_Time
=> -1,
30970 Pragma_No_Strict_Aliasing
=> -1,
30971 Pragma_No_Tagged_Streams
=> 0,
30972 Pragma_Normalize_Scalars
=> 0,
30973 Pragma_Obsolescent
=> 0,
30974 Pragma_Optimize
=> 0,
30975 Pragma_Optimize_Alignment
=> 0,
30976 Pragma_Overflow_Mode
=> 0,
30977 Pragma_Overriding_Renamings
=> 0,
30978 Pragma_Ordered
=> 0,
30981 Pragma_Part_Of
=> 0,
30982 Pragma_Partition_Elaboration_Policy
=> 0,
30983 Pragma_Passive
=> 0,
30984 Pragma_Persistent_BSS
=> 0,
30985 Pragma_Polling
=> 0,
30986 Pragma_Prefix_Exception_Messages
=> 0,
30988 Pragma_Postcondition
=> -1,
30989 Pragma_Post_Class
=> -1,
30991 Pragma_Precondition
=> -1,
30992 Pragma_Predicate
=> -1,
30993 Pragma_Predicate_Failure
=> -1,
30994 Pragma_Preelaborable_Initialization
=> -1,
30995 Pragma_Preelaborate
=> 0,
30996 Pragma_Pre_Class
=> -1,
30997 Pragma_Priority
=> -1,
30998 Pragma_Priority_Specific_Dispatching
=> 0,
30999 Pragma_Profile
=> 0,
31000 Pragma_Profile_Warnings
=> 0,
31001 Pragma_Propagate_Exceptions
=> 0,
31002 Pragma_Provide_Shift_Operators
=> 0,
31003 Pragma_Psect_Object
=> 0,
31005 Pragma_Pure_Function
=> 0,
31006 Pragma_Queuing_Policy
=> 0,
31007 Pragma_Rational
=> 0,
31008 Pragma_Ravenscar
=> 0,
31009 Pragma_Refined_Depends
=> -1,
31010 Pragma_Refined_Global
=> -1,
31011 Pragma_Refined_Post
=> -1,
31012 Pragma_Refined_State
=> -1,
31013 Pragma_Relative_Deadline
=> 0,
31014 Pragma_Rename_Pragma
=> 0,
31015 Pragma_Remote_Access_Type
=> -1,
31016 Pragma_Remote_Call_Interface
=> -1,
31017 Pragma_Remote_Types
=> -1,
31018 Pragma_Restricted_Run_Time
=> 0,
31019 Pragma_Restriction_Warnings
=> 0,
31020 Pragma_Restrictions
=> 0,
31021 Pragma_Reviewable
=> -1,
31022 Pragma_Secondary_Stack_Size
=> -1,
31023 Pragma_Short_Circuit_And_Or
=> 0,
31024 Pragma_Share_Generic
=> 0,
31025 Pragma_Shared
=> 0,
31026 Pragma_Shared_Passive
=> 0,
31027 Pragma_Short_Descriptors
=> 0,
31028 Pragma_Simple_Storage_Pool_Type
=> 0,
31029 Pragma_Source_File_Name
=> 0,
31030 Pragma_Source_File_Name_Project
=> 0,
31031 Pragma_Source_Reference
=> 0,
31032 Pragma_SPARK_Mode
=> 0,
31033 Pragma_Storage_Size
=> -1,
31034 Pragma_Storage_Unit
=> 0,
31035 Pragma_Static_Elaboration_Desired
=> 0,
31036 Pragma_Stream_Convert
=> 0,
31037 Pragma_Style_Checks
=> 0,
31038 Pragma_Subtitle
=> 0,
31039 Pragma_Suppress
=> 0,
31040 Pragma_Suppress_Exception_Locations
=> 0,
31041 Pragma_Suppress_All
=> 0,
31042 Pragma_Suppress_Debug_Info
=> 0,
31043 Pragma_Suppress_Initialization
=> 0,
31044 Pragma_System_Name
=> 0,
31045 Pragma_Task_Dispatching_Policy
=> 0,
31046 Pragma_Task_Info
=> -1,
31047 Pragma_Task_Name
=> -1,
31048 Pragma_Task_Storage
=> -1,
31049 Pragma_Test_Case
=> -1,
31050 Pragma_Thread_Local_Storage
=> -1,
31051 Pragma_Time_Slice
=> -1,
31053 Pragma_Type_Invariant
=> -1,
31054 Pragma_Type_Invariant_Class
=> -1,
31055 Pragma_Unchecked_Union
=> 0,
31056 Pragma_Unevaluated_Use_Of_Old
=> 0,
31057 Pragma_Unimplemented_Unit
=> 0,
31058 Pragma_Universal_Aliasing
=> 0,
31059 Pragma_Universal_Data
=> 0,
31060 Pragma_Unmodified
=> 0,
31061 Pragma_Unreferenced
=> 0,
31062 Pragma_Unreferenced_Objects
=> 0,
31063 Pragma_Unreserve_All_Interrupts
=> 0,
31064 Pragma_Unsuppress
=> 0,
31065 Pragma_Unused
=> 0,
31066 Pragma_Use_VADS_Size
=> 0,
31067 Pragma_Validity_Checks
=> 0,
31068 Pragma_Volatile
=> 0,
31069 Pragma_Volatile_Components
=> 0,
31070 Pragma_Volatile_Full_Access
=> 0,
31071 Pragma_Volatile_Function
=> 0,
31072 Pragma_Warning_As_Error
=> 0,
31073 Pragma_Warnings
=> 0,
31074 Pragma_Weak_External
=> 0,
31075 Pragma_Wide_Character_Encoding
=> 0,
31076 Unknown_Pragma
=> 0);
31078 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
31084 function Arg_No
return Nat
;
31085 -- Returns an integer showing what argument we are in. A value of
31086 -- zero means we are not in any of the arguments.
31092 function Arg_No
return Nat
is
31097 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
31111 -- Start of processing for Non_Significant_Pragma_Reference
31116 if Nkind
(P
) /= N_Pragma_Argument_Association
then
31120 Id
:= Get_Pragma_Id
(Parent
(P
));
31121 C
:= Sig_Flags
(Id
);
31136 return AN
< (C
- 90);
31142 end Is_Non_Significant_Pragma_Reference
;
31144 ------------------------------
31145 -- Is_Pragma_String_Literal --
31146 ------------------------------
31148 -- This function returns true if the corresponding pragma argument is a
31149 -- static string expression. These are the only cases in which string
31150 -- literals can appear as pragma arguments. We also allow a string literal
31151 -- as the first argument to pragma Assert (although it will of course
31152 -- always generate a type error).
31154 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
31155 Pragn
: constant Node_Id
:= Parent
(Par
);
31156 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
31157 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
31163 N
:= First
(Assoc
);
31170 if Pname
= Name_Assert
then
31173 elsif Pname
= Name_Export
then
31176 elsif Pname
= Name_Ident
then
31179 elsif Pname
= Name_Import
then
31182 elsif Pname
= Name_Interface_Name
then
31185 elsif Pname
= Name_Linker_Alias
then
31188 elsif Pname
= Name_Linker_Section
then
31191 elsif Pname
= Name_Machine_Attribute
then
31194 elsif Pname
= Name_Source_File_Name
then
31197 elsif Pname
= Name_Source_Reference
then
31200 elsif Pname
= Name_Title
then
31203 elsif Pname
= Name_Subtitle
then
31209 end Is_Pragma_String_Literal
;
31211 ---------------------------
31212 -- Is_Private_SPARK_Mode --
31213 ---------------------------
31215 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
31218 (Nkind
(N
) = N_Pragma
31219 and then Pragma_Name
(N
) = Name_SPARK_Mode
31220 and then Is_List_Member
(N
));
31222 -- For pragma SPARK_Mode to be private, it has to appear in the private
31223 -- declarations of a package.
31226 Present
(Parent
(N
))
31227 and then Nkind
(Parent
(N
)) = N_Package_Specification
31228 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
31229 end Is_Private_SPARK_Mode
;
31231 -------------------------------------
31232 -- Is_Unconstrained_Or_Tagged_Item --
31233 -------------------------------------
31235 function Is_Unconstrained_Or_Tagged_Item
31236 (Item
: Entity_Id
) return Boolean
31238 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
31239 -- Determine whether record type Typ has at least one unconstrained
31242 ---------------------------------
31243 -- Has_Unconstrained_Component --
31244 ---------------------------------
31246 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
31250 Comp
:= First_Component
(Typ
);
31251 while Present
(Comp
) loop
31252 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
31256 Next_Component
(Comp
);
31260 end Has_Unconstrained_Component
;
31264 Typ
: constant Entity_Id
:= Etype
(Item
);
31266 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31269 if Is_Tagged_Type
(Typ
) then
31272 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
31275 elsif Is_Record_Type
(Typ
) then
31276 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
31279 return Has_Unconstrained_Component
(Typ
);
31282 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
31288 end Is_Unconstrained_Or_Tagged_Item
;
31290 -----------------------------
31291 -- Is_Valid_Assertion_Kind --
31292 -----------------------------
31294 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
31301 | Name_Assertion_Policy
31302 | Name_Static_Predicate
31303 | Name_Dynamic_Predicate
31308 | Name_Type_Invariant
31309 | Name_uType_Invariant
31313 | Name_Assert_And_Cut
31315 | Name_Contract_Cases
31317 | Name_Default_Initial_Condition
31319 | Name_Initial_Condition
31322 | Name_Loop_Invariant
31323 | Name_Loop_Variant
31324 | Name_Postcondition
31325 | Name_Precondition
31327 | Name_Refined_Post
31328 | Name_Statement_Assertions
31335 end Is_Valid_Assertion_Kind
;
31337 --------------------------------------
31338 -- Process_Compilation_Unit_Pragmas --
31339 --------------------------------------
31341 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
31343 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31344 -- strange because it comes at the end of the unit. Rational has the
31345 -- same name for a pragma, but treats it as a program unit pragma, In
31346 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31347 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31348 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31349 -- the context clause to ensure the correct processing.
31351 if Has_Pragma_Suppress_All
(N
) then
31352 Prepend_To
(Context_Items
(N
),
31353 Make_Pragma
(Sloc
(N
),
31354 Chars
=> Name_Suppress
,
31355 Pragma_Argument_Associations
=> New_List
(
31356 Make_Pragma_Argument_Association
(Sloc
(N
),
31357 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
31360 -- Nothing else to do at the current time
31362 end Process_Compilation_Unit_Pragmas
;
31364 -------------------------------------------
31365 -- Process_Compile_Time_Warning_Or_Error --
31366 -------------------------------------------
31368 procedure Process_Compile_Time_Warning_Or_Error
31372 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
31373 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
31374 Arg2
: constant Node_Id
:= Next
(Arg1
);
31377 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
31379 if Compile_Time_Known_Value
(Arg1x
) then
31380 if Is_True
(Expr_Value
(Arg1x
)) then
31382 -- We have already verified that the second argument is a static
31383 -- string expression. Its string value must be retrieved
31384 -- explicitly if it is a declared constant, otherwise it has
31385 -- been constant-folded previously.
31388 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
31389 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
31390 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
31391 Str
: constant String_Id
:=
31392 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
31393 Str_Len
: constant Nat
:= String_Length
(Str
);
31395 Force
: constant Boolean :=
31396 Prag_Id
= Pragma_Compile_Time_Warning
31397 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
31398 and then (Ekind
(Cent
) /= E_Package
31399 or else not In_Private_Part
(Cent
));
31400 -- Set True if this is the warning case, and we are in the
31401 -- visible part of a package spec, or in a subprogram spec,
31402 -- in which case we want to force the client to see the
31403 -- warning, even though it is not in the main unit.
31411 -- Loop through segments of message separated by line feeds.
31412 -- We output these segments as separate messages with
31413 -- continuation marks for all but the first.
31418 Error_Msg_Strlen
:= 0;
31420 -- Loop to copy characters from argument to error message
31424 exit when Ptr
> Str_Len
;
31425 CC
:= Get_String_Char
(Str
, Ptr
);
31428 -- Ignore wide chars ??? else store character
31430 if In_Character_Range
(CC
) then
31431 C
:= Get_Character
(CC
);
31432 exit when C
= ASCII
.LF
;
31433 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
31434 Error_Msg_String
(Error_Msg_Strlen
) := C
;
31438 -- Here with one line ready to go
31440 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
31442 -- If this is a warning in a spec, then we want clients
31443 -- to see the warning, so mark the message with the
31444 -- special sequence !! to force the warning. In the case
31445 -- of a package spec, we do not force this if we are in
31446 -- the private part of the spec.
31449 if Cont
= False then
31450 Error_Msg
("<<~!!", Eloc
);
31453 Error_Msg
("\<<~!!", Eloc
);
31456 -- Error, rather than warning, or in a body, so we do not
31457 -- need to force visibility for client (error will be
31458 -- output in any case, and this is the situation in which
31459 -- we do not want a client to get a warning, since the
31460 -- warning is in the body or the spec private part).
31463 if Cont
= False then
31464 Error_Msg
("<<~", Eloc
);
31467 Error_Msg
("\<<~", Eloc
);
31471 exit when Ptr
> Str_Len
;
31476 end Process_Compile_Time_Warning_Or_Error
;
31478 ------------------------------------
31479 -- Record_Possible_Body_Reference --
31480 ------------------------------------
31482 procedure Record_Possible_Body_Reference
31483 (State_Id
: Entity_Id
;
31487 Spec_Id
: Entity_Id
;
31490 -- Ensure that we are dealing with a reference to a state
31492 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
31494 -- Climb the tree starting from the reference looking for a package body
31495 -- whose spec declares the referenced state. This criteria automatically
31496 -- excludes references in package specs which are legal. Note that it is
31497 -- not wise to emit an error now as the package body may lack pragma
31498 -- Refined_State or the referenced state may not be mentioned in the
31499 -- refinement. This approach avoids the generation of misleading errors.
31502 while Present
(Context
) loop
31503 if Nkind
(Context
) = N_Package_Body
then
31504 Spec_Id
:= Corresponding_Spec
(Context
);
31506 if Present
(Abstract_States
(Spec_Id
))
31507 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
31509 if No
(Body_References
(State_Id
)) then
31510 Set_Body_References
(State_Id
, New_Elmt_List
);
31513 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
31518 Context
:= Parent
(Context
);
31520 end Record_Possible_Body_Reference
;
31522 ------------------------------------------
31523 -- Relocate_Pragmas_To_Anonymous_Object --
31524 ------------------------------------------
31526 procedure Relocate_Pragmas_To_Anonymous_Object
31527 (Typ_Decl
: Node_Id
;
31528 Obj_Decl
: Node_Id
)
31532 Next_Decl
: Node_Id
;
31535 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
31536 Def
:= Protected_Definition
(Typ_Decl
);
31538 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
31539 Def
:= Task_Definition
(Typ_Decl
);
31542 -- The concurrent definition has a visible declaration list. Inspect it
31543 -- and relocate all canidate pragmas.
31545 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
31546 Decl
:= First
(Visible_Declarations
(Def
));
31547 while Present
(Decl
) loop
31549 -- Preserve the following declaration for iteration purposes due
31550 -- to possible relocation of a pragma.
31552 Next_Decl
:= Next
(Decl
);
31554 if Nkind
(Decl
) = N_Pragma
31555 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
31558 Insert_After
(Obj_Decl
, Decl
);
31560 -- Skip internally generated code
31562 elsif not Comes_From_Source
(Decl
) then
31565 -- No candidate pragmas are available for relocation
31574 end Relocate_Pragmas_To_Anonymous_Object
;
31576 ------------------------------
31577 -- Relocate_Pragmas_To_Body --
31578 ------------------------------
31580 procedure Relocate_Pragmas_To_Body
31581 (Subp_Body
: Node_Id
;
31582 Target_Body
: Node_Id
:= Empty
)
31584 procedure Relocate_Pragma
(Prag
: Node_Id
);
31585 -- Remove a single pragma from its current list and add it to the
31586 -- declarations of the proper body (either Subp_Body or Target_Body).
31588 ---------------------
31589 -- Relocate_Pragma --
31590 ---------------------
31592 procedure Relocate_Pragma
(Prag
: Node_Id
) is
31597 -- When subprogram stubs or expression functions are involves, the
31598 -- destination declaration list belongs to the proper body.
31600 if Present
(Target_Body
) then
31601 Target
:= Target_Body
;
31603 Target
:= Subp_Body
;
31606 Decls
:= Declarations
(Target
);
31610 Set_Declarations
(Target
, Decls
);
31613 -- Unhook the pragma from its current list
31616 Prepend
(Prag
, Decls
);
31617 end Relocate_Pragma
;
31621 Body_Id
: constant Entity_Id
:=
31622 Defining_Unit_Name
(Specification
(Subp_Body
));
31623 Next_Stmt
: Node_Id
;
31626 -- Start of processing for Relocate_Pragmas_To_Body
31629 -- Do not process a body that comes from a separate unit as no construct
31630 -- can possibly follow it.
31632 if not Is_List_Member
(Subp_Body
) then
31635 -- Do not relocate pragmas that follow a stub if the stub does not have
31638 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
31639 and then No
(Target_Body
)
31643 -- Do not process internally generated routine _Postconditions
31645 elsif Ekind
(Body_Id
) = E_Procedure
31646 and then Chars
(Body_Id
) = Name_uPostconditions
31651 -- Look at what is following the body. We are interested in certain kind
31652 -- of pragmas (either from source or byproducts of expansion) that can
31653 -- apply to a body [stub].
31655 Stmt
:= Next
(Subp_Body
);
31656 while Present
(Stmt
) loop
31658 -- Preserve the following statement for iteration purposes due to a
31659 -- possible relocation of a pragma.
31661 Next_Stmt
:= Next
(Stmt
);
31663 -- Move a candidate pragma following the body to the declarations of
31666 if Nkind
(Stmt
) = N_Pragma
31667 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
31670 -- If a source pragma Warnings follows the body, it applies to
31671 -- following statements and does not belong in the body.
31673 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
31674 and then Comes_From_Source
(Stmt
)
31678 Relocate_Pragma
(Stmt
);
31681 -- Skip internally generated code
31683 elsif not Comes_From_Source
(Stmt
) then
31686 -- No candidate pragmas are available for relocation
31694 end Relocate_Pragmas_To_Body
;
31696 -------------------
31697 -- Resolve_State --
31698 -------------------
31700 procedure Resolve_State
(N
: Node_Id
) is
31705 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
31706 Func
:= Entity
(N
);
31708 -- Handle overloading of state names by functions. Traverse the
31709 -- homonym chain looking for an abstract state.
31711 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
31712 pragma Assert
(Is_Overloaded
(N
));
31714 State
:= Homonym
(Func
);
31715 while Present
(State
) loop
31716 if Ekind
(State
) = E_Abstract_State
then
31718 -- Resolve the overloading by setting the proper entity of
31719 -- the reference to that of the state.
31721 Set_Etype
(N
, Standard_Void_Type
);
31722 Set_Entity
(N
, State
);
31723 Set_Is_Overloaded
(N
, False);
31725 Generate_Reference
(State
, N
);
31729 State
:= Homonym
(State
);
31732 -- A function can never act as a state. If the homonym chain does
31733 -- not contain a corresponding state, then something went wrong in
31734 -- the overloading mechanism.
31736 raise Program_Error
;
31741 ----------------------------
31742 -- Rewrite_Assertion_Kind --
31743 ----------------------------
31745 procedure Rewrite_Assertion_Kind
31747 From_Policy
: Boolean := False)
31753 if Nkind
(N
) = N_Attribute_Reference
31754 and then Attribute_Name
(N
) = Name_Class
31755 and then Nkind
(Prefix
(N
)) = N_Identifier
31757 case Chars
(Prefix
(N
)) is
31764 when Name_Type_Invariant
=>
31765 Nam
:= Name_uType_Invariant
;
31767 when Name_Invariant
=>
31768 Nam
:= Name_uInvariant
;
31774 -- Recommend standard use of aspect names Pre/Post
31776 elsif Nkind
(N
) = N_Identifier
31777 and then From_Policy
31778 and then Serious_Errors_Detected
= 0
31779 and then not ASIS_Mode
31781 if Chars
(N
) = Name_Precondition
31782 or else Chars
(N
) = Name_Postcondition
31784 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
31786 ("\use Assertion_Policy and aspect names Pre/Post for "
31787 & "Ada2012 conformance?", N
);
31793 if Nam
/= No_Name
then
31794 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
31796 end Rewrite_Assertion_Kind
;
31804 Dummy
:= Dummy
+ 1;
31807 --------------------------------
31808 -- Set_Encoded_Interface_Name --
31809 --------------------------------
31811 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
31812 Str
: constant String_Id
:= Strval
(S
);
31813 Len
: constant Nat
:= String_Length
(Str
);
31818 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
31821 -- Stores encoded value of character code CC. The encoding we use an
31822 -- underscore followed by four lower case hex digits.
31828 procedure Encode
is
31830 Store_String_Char
(Get_Char_Code
('_'));
31832 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
31834 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
31836 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
31838 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
31841 -- Start of processing for Set_Encoded_Interface_Name
31844 -- If first character is asterisk, this is a link name, and we leave it
31845 -- completely unmodified. We also ignore null strings (the latter case
31846 -- happens only in error cases).
31849 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
31851 Set_Interface_Name
(E
, S
);
31856 CC
:= Get_String_Char
(Str
, J
);
31858 exit when not In_Character_Range
(CC
);
31860 C
:= Get_Character
(CC
);
31862 exit when C
/= '_' and then C
/= '$'
31863 and then C
not in '0' .. '9'
31864 and then C
not in 'a' .. 'z'
31865 and then C
not in 'A' .. 'Z';
31868 Set_Interface_Name
(E
, S
);
31876 -- Here we need to encode. The encoding we use as follows:
31877 -- three underscores + four hex digits (lower case)
31881 for J
in 1 .. String_Length
(Str
) loop
31882 CC
:= Get_String_Char
(Str
, J
);
31884 if not In_Character_Range
(CC
) then
31887 C
:= Get_Character
(CC
);
31889 if C
= '_' or else C
= '$'
31890 or else C
in '0' .. '9'
31891 or else C
in 'a' .. 'z'
31892 or else C
in 'A' .. 'Z'
31894 Store_String_Char
(CC
);
31901 Set_Interface_Name
(E
,
31902 Make_String_Literal
(Sloc
(S
),
31903 Strval
=> End_String
));
31905 end Set_Encoded_Interface_Name
;
31907 ------------------------
31908 -- Set_Elab_Unit_Name --
31909 ------------------------
31911 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
31916 if Nkind
(N
) = N_Identifier
31917 and then Nkind
(With_Item
) = N_Identifier
31919 Set_Entity
(N
, Entity
(With_Item
));
31921 elsif Nkind
(N
) = N_Selected_Component
then
31922 Change_Selected_Component_To_Expanded_Name
(N
);
31923 Set_Entity
(N
, Entity
(With_Item
));
31924 Set_Entity
(Selector_Name
(N
), Entity
(N
));
31926 Pref
:= Prefix
(N
);
31927 Scop
:= Scope
(Entity
(N
));
31928 while Nkind
(Pref
) = N_Selected_Component
loop
31929 Change_Selected_Component_To_Expanded_Name
(Pref
);
31930 Set_Entity
(Selector_Name
(Pref
), Scop
);
31931 Set_Entity
(Pref
, Scop
);
31932 Pref
:= Prefix
(Pref
);
31933 Scop
:= Scope
(Scop
);
31936 Set_Entity
(Pref
, Scop
);
31939 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
31940 end Set_Elab_Unit_Name
;
31942 -------------------
31943 -- Test_Case_Arg --
31944 -------------------
31946 function Test_Case_Arg
31949 From_Aspect
: Boolean := False) return Node_Id
31951 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
31956 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
31961 -- The caller requests the aspect argument
31963 if From_Aspect
then
31964 if Present
(Aspect
)
31965 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
31967 Args
:= Expression
(Aspect
);
31969 -- "Name" and "Mode" may appear without an identifier as a
31970 -- positional association.
31972 if Present
(Expressions
(Args
)) then
31973 Arg
:= First
(Expressions
(Args
));
31975 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31983 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31988 -- Some or all arguments may appear as component associatons
31990 if Present
(Component_Associations
(Args
)) then
31991 Arg
:= First
(Component_Associations
(Args
));
31992 while Present
(Arg
) loop
31993 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
32002 -- Otherwise retrieve the argument directly from the pragma
32005 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
32007 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32011 -- Skip argument "Name"
32015 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32019 -- Skip argument "Mode"
32023 -- Arguments "Requires" and "Ensures" are optional and may not be
32026 while Present
(Arg
) loop
32027 if Chars
(Arg
) = Arg_Nam
then