1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2018, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Contracts
; use Contracts
;
37 with Csets
; use Csets
;
38 with Debug
; use Debug
;
39 with Einfo
; use Einfo
;
40 with Elists
; use Elists
;
41 with Errout
; use Errout
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Ghost
; use Ghost
;
46 with Gnatvsn
; use Gnatvsn
;
48 with Lib
.Writ
; use Lib
.Writ
;
49 with Lib
.Xref
; use Lib
.Xref
;
50 with Namet
.Sp
; use Namet
.Sp
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
53 with Output
; use Output
;
54 with Par_SCO
; use Par_SCO
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Ch3
; use Sem_Ch3
;
61 with Sem_Ch6
; use Sem_Ch6
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Ch12
; use Sem_Ch12
;
64 with Sem_Ch13
; use Sem_Ch13
;
65 with Sem_Disp
; use Sem_Disp
;
66 with Sem_Dist
; use Sem_Dist
;
67 with Sem_Elab
; use Sem_Elab
;
68 with Sem_Elim
; use Sem_Elim
;
69 with Sem_Eval
; use Sem_Eval
;
70 with Sem_Intr
; use Sem_Intr
;
71 with Sem_Mech
; use Sem_Mech
;
72 with Sem_Res
; use Sem_Res
;
73 with Sem_Type
; use Sem_Type
;
74 with Sem_Util
; use Sem_Util
;
75 with Sem_Warn
; use Sem_Warn
;
76 with Stand
; use Stand
;
77 with Sinfo
; use Sinfo
;
78 with Sinfo
.CN
; use Sinfo
.CN
;
79 with Sinput
; use Sinput
;
80 with Stringt
; use Stringt
;
81 with Stylesw
; use Stylesw
;
83 with Targparm
; use Targparm
;
84 with Tbuild
; use Tbuild
;
86 with Uintp
; use Uintp
;
87 with Uname
; use Uname
;
88 with Urealp
; use Urealp
;
89 with Validsw
; use Validsw
;
90 with Warnsw
; use Warnsw
;
92 with System
.Case_Util
;
94 package body Sem_Prag
is
96 ----------------------------------------------
97 -- Common Handling of Import-Export Pragmas --
98 ----------------------------------------------
100 -- In the following section, a number of Import_xxx and Export_xxx pragmas
101 -- are defined by GNAT. These are compatible with the DEC pragmas of the
102 -- same name, and all have the following common form and processing:
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
110 -- [Internal =>] LOCAL_NAME
111 -- [, [External =>] EXTERNAL_SYMBOL]
112 -- [, other optional parameters ]);
114 -- EXTERNAL_SYMBOL ::=
116 -- | static_string_EXPRESSION
118 -- The internal LOCAL_NAME designates the entity that is imported or
119 -- exported, and must refer to an entity in the current declarative
120 -- part (as required by the rules for LOCAL_NAME).
122 -- The external linker name is designated by the External parameter if
123 -- given, or the Internal parameter if not (if there is no External
124 -- parameter, the External parameter is a copy of the Internal name).
126 -- If the External parameter is given as a string, then this string is
127 -- treated as an external name (exactly as though it had been given as an
128 -- External_Name parameter for a normal Import pragma).
130 -- If the External parameter is given as an identifier (or there is no
131 -- External parameter, so that the Internal identifier is used), then
132 -- the external name is the characters of the identifier, translated
133 -- to all lower case letters.
135 -- Note: the external name specified or implied by any of these special
136 -- Import_xxx or Export_xxx pragmas override an external or link name
137 -- specified in a previous Import or Export pragma.
139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
140 -- named notation, following the standard rules for subprogram calls, i.e.
141 -- parameters can be given in any order if named notation is used, and
142 -- positional and named notation can be mixed, subject to the rule that all
143 -- positional parameters must appear first.
145 -- Note: All these pragmas are implemented exactly following the DEC design
146 -- and implementation and are intended to be fully compatible with the use
147 -- of these pragmas in the DEC Ada compiler.
149 --------------------------------------------
150 -- Checking for Duplicated External Names --
151 --------------------------------------------
153 -- It is suspicious if two separate Export pragmas use the same external
154 -- name. The following table is used to diagnose this situation so that
155 -- an appropriate warning can be issued.
157 -- The Node_Id stored is for the N_String_Literal node created to hold
158 -- the value of the external name. The Sloc of this node is used to
159 -- cross-reference the location of the duplication.
161 package Externals
is new Table
.Table
(
162 Table_Component_Type
=> Node_Id
,
163 Table_Index_Type
=> Int
,
164 Table_Low_Bound
=> 0,
165 Table_Initial
=> 100,
166 Table_Increment
=> 100,
167 Table_Name
=> "Name_Externals");
169 -------------------------------------
170 -- Local Subprograms and Variables --
171 -------------------------------------
173 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
174 -- This routine is used for possible casing adjustment of an explicit
175 -- external name supplied as a string literal (the node N), according to
176 -- the casing requirement of Opt.External_Name_Casing. If this is set to
177 -- As_Is, then the string literal is returned unchanged, but if it is set
178 -- to Uppercase or Lowercase, then a new string literal with appropriate
179 -- casing is constructed.
181 procedure Analyze_Part_Of
185 Encap_Id
: out Entity_Id
;
186 Legal
: out Boolean);
187 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
188 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
189 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
190 -- package instantiation. Encap denotes the encapsulating state or single
191 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
192 -- the indicator is legal.
194 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
195 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
196 -- Query whether a particular item appears in a mixed list of nodes and
197 -- entities. It is assumed that all nodes in the list have entities.
199 procedure Check_Postcondition_Use_In_Inlined_Subprogram
201 Spec_Id
: Entity_Id
);
202 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
203 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
204 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
205 -- and assertions are enabled.
207 procedure Check_State_And_Constituent_Use
211 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
212 -- Global and Initializes. Determine whether a state from list States and a
213 -- corresponding constituent from list Constits (if any) appear in the same
214 -- context denoted by Context. If this is the case, emit an error.
216 procedure Contract_Freeze_Error
217 (Contract_Id
: Entity_Id
;
218 Freeze_Id
: Entity_Id
);
219 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
220 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
221 -- of a body which caused contract freezing and Contract_Id denotes the
222 -- entity of the affected contstruct.
224 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
225 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
226 -- Prag that duplicates previous pragma Prev.
228 function Find_Encapsulating_State
230 Constit_Id
: Entity_Id
) return Entity_Id
;
231 -- Given the entity of a constituent Constit_Id, find the corresponding
232 -- encapsulating state which appears in States. The routine returns Empty
233 -- if no such state is found.
235 function Find_Related_Context
237 Do_Checks
: Boolean := False) return Node_Id
;
238 -- Subsidiary to the analysis of pragmas
241 -- Constant_After_Elaboration
245 -- Find the first source declaration or statement found while traversing
246 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
247 -- set, the routine reports duplicate pragmas. The routine returns Empty
248 -- when reaching the start of the node chain.
250 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
251 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
252 -- original one, following the renaming chain) is returned. Otherwise the
253 -- entity is returned unchanged. Should be in Einfo???
255 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
256 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
257 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
258 -- value of type SPARK_Mode_Type.
260 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
261 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
262 -- Determine whether dependency clause Clause is surrounded by extra
263 -- parentheses. If this is the case, issue an error message.
265 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
266 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
267 -- pragma Depends. Determine whether the type of dependency item Item is
268 -- tagged, unconstrained array, unconstrained record or a record with at
269 -- least one unconstrained component.
271 procedure Record_Possible_Body_Reference
272 (State_Id
: Entity_Id
;
274 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
275 -- Global. Given an abstract state denoted by State_Id and a reference Ref
276 -- to it, determine whether the reference appears in a package body that
277 -- will eventually refine the state. If this is the case, record the
278 -- reference for future checks (see Analyze_Refined_State_In_Decls).
280 procedure Resolve_State
(N
: Node_Id
);
281 -- Handle the overloading of state names by functions. When N denotes a
282 -- function, this routine finds the corresponding state and sets the entity
283 -- of N to that of the state.
285 procedure Rewrite_Assertion_Kind
287 From_Policy
: Boolean := False);
288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
289 -- then it is rewritten as an identifier with the corresponding special
290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
291 -- and Check_Policy. If the names are Precondition or Postcondition, this
292 -- combination is deprecated in favor of Assertion_Policy and Ada2012
293 -- Aspect names. The parameter From_Policy indicates that the pragma
294 -- is the old non-standard Check_Policy and not a rewritten pragma.
296 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
297 -- Place semantic information on the argument of an Elaborate/Elaborate_All
298 -- pragma. Entity name for unit and its parents is taken from item in
299 -- previous with_clause that mentions the unit.
301 Dummy
: Integer := 0;
302 pragma Volatile
(Dummy
);
303 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
306 pragma No_Inline
(ip
);
307 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
308 -- is just to help debugging the front end. If a pragma Inspection_Point
309 -- is added to a source program, then breaking on ip will get you to that
310 -- point in the program.
313 pragma No_Inline
(rv
);
314 -- This is a dummy function called by the processing for pragma Reviewable.
315 -- It is there for assisting front end debugging. By placing a Reviewable
316 -- pragma in the source program, a breakpoint on rv catches this place in
317 -- the source, allowing convenient stepping to the point of interest.
319 -------------------------------
320 -- Adjust_External_Name_Case --
321 -------------------------------
323 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
327 -- Adjust case of literal if required
329 if Opt
.External_Name_Exp_Casing
= As_Is
then
333 -- Copy existing string
339 for J
in 1 .. String_Length
(Strval
(N
)) loop
340 CC
:= Get_String_Char
(Strval
(N
), J
);
342 if Opt
.External_Name_Exp_Casing
= Uppercase
343 and then CC
>= Get_Char_Code
('a')
344 and then CC
<= Get_Char_Code
('z')
346 Store_String_Char
(CC
- 32);
348 elsif Opt
.External_Name_Exp_Casing
= Lowercase
349 and then CC
>= Get_Char_Code
('A')
350 and then CC
<= Get_Char_Code
('Z')
352 Store_String_Char
(CC
+ 32);
355 Store_String_Char
(CC
);
360 Make_String_Literal
(Sloc
(N
),
361 Strval
=> End_String
);
363 end Adjust_External_Name_Case
;
365 -----------------------------------------
366 -- Analyze_Contract_Cases_In_Decl_Part --
367 -----------------------------------------
369 -- WARNING: This routine manages Ghost regions. Return statements must be
370 -- replaced by gotos which jump to the end of the routine and restore the
373 procedure Analyze_Contract_Cases_In_Decl_Part
375 Freeze_Id
: Entity_Id
:= Empty
)
377 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
378 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
380 Others_Seen
: Boolean := False;
381 -- This flag is set when an "others" choice is encountered. It is used
382 -- to detect multiple illegal occurrences of "others".
384 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
385 -- Verify the legality of a single contract case
387 ---------------------------
388 -- Analyze_Contract_Case --
389 ---------------------------
391 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
392 Case_Guard
: Node_Id
;
395 Extra_Guard
: Node_Id
;
398 if Nkind
(CCase
) = N_Component_Association
then
399 Case_Guard
:= First
(Choices
(CCase
));
400 Conseq
:= Expression
(CCase
);
402 -- Each contract case must have exactly one case guard
404 Extra_Guard
:= Next
(Case_Guard
);
406 if Present
(Extra_Guard
) then
408 ("contract case must have exactly one case guard",
412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
414 if Nkind
(Case_Guard
) = N_Others_Choice
then
417 ("only one others choice allowed in contract cases",
423 elsif Others_Seen
then
425 ("others must be the last choice in contract cases", N
);
428 -- Preanalyze the case guard and consequence
430 if Nkind
(Case_Guard
) /= N_Others_Choice
then
431 Errors
:= Serious_Errors_Detected
;
432 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
434 -- Emit a clarification message when the case guard contains
435 -- at least one undefined reference, possibly due to contract
438 if Errors
/= Serious_Errors_Detected
439 and then Present
(Freeze_Id
)
440 and then Has_Undefined_Reference
(Case_Guard
)
442 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
446 Errors
:= Serious_Errors_Detected
;
447 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
449 -- Emit a clarification message when the consequence contains
450 -- at least one undefined reference, possibly due to contract
453 if Errors
/= Serious_Errors_Detected
454 and then Present
(Freeze_Id
)
455 and then Has_Undefined_Reference
(Conseq
)
457 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
460 -- The contract case is malformed
463 Error_Msg_N
("wrong syntax in contract case", CCase
);
465 end Analyze_Contract_Case
;
469 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
471 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
472 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
473 -- Save the Ghost-related attributes to restore on exit
476 Restore_Scope
: Boolean := False;
478 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
481 -- Do not analyze the pragma multiple times
483 if Is_Analyzed_Pragma
(N
) then
487 -- Set the Ghost mode in effect from the pragma. Due to the delayed
488 -- analysis of the pragma, the Ghost mode at point of declaration and
489 -- point of analysis may not necessarily be the same. Use the mode in
490 -- effect at the point of declaration.
494 -- Single and multiple contract cases must appear in aggregate form. If
495 -- this is not the case, then either the parser of the analysis of the
496 -- pragma failed to produce an aggregate.
498 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
500 if Present
(Component_Associations
(CCases
)) then
502 -- Ensure that the formal parameters are visible when analyzing all
503 -- clauses. This falls out of the general rule of aspects pertaining
504 -- to subprogram declarations.
506 if not In_Open_Scopes
(Spec_Id
) then
507 Restore_Scope
:= True;
508 Push_Scope
(Spec_Id
);
510 if Is_Generic_Subprogram
(Spec_Id
) then
511 Install_Generic_Formals
(Spec_Id
);
513 Install_Formals
(Spec_Id
);
517 CCase
:= First
(Component_Associations
(CCases
));
518 while Present
(CCase
) loop
519 Analyze_Contract_Case
(CCase
);
523 if Restore_Scope
then
527 -- Currently it is not possible to inline pre/postconditions on a
528 -- subprogram subject to pragma Inline_Always.
530 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
532 -- Otherwise the pragma is illegal
535 Error_Msg_N
("wrong syntax for constract cases", N
);
538 Set_Is_Analyzed_Pragma
(N
);
540 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
541 end Analyze_Contract_Cases_In_Decl_Part
;
543 ----------------------------------
544 -- Analyze_Depends_In_Decl_Part --
545 ----------------------------------
547 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
548 Loc
: constant Source_Ptr
:= Sloc
(N
);
549 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
550 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
552 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
553 -- A list containing the entities of all the inputs processed so far.
554 -- The list is populated with unique entities because the same input
555 -- may appear in multiple input lists.
557 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
558 -- A list containing the entities of all the outputs processed so far.
559 -- The list is populated with unique entities because output items are
560 -- unique in a dependence relation.
562 Constits_Seen
: Elist_Id
:= No_Elist
;
563 -- A list containing the entities of all constituents processed so far.
564 -- It aids in detecting illegal usage of a state and a corresponding
565 -- constituent in pragma [Refinde_]Depends.
567 Global_Seen
: Boolean := False;
568 -- A flag set when pragma Global has been processed
570 Null_Output_Seen
: Boolean := False;
571 -- A flag used to track the legality of a null output
573 Result_Seen
: Boolean := False;
574 -- A flag set when Spec_Id'Result is processed
576 States_Seen
: Elist_Id
:= No_Elist
;
577 -- A list containing the entities of all states processed so far. It
578 -- helps in detecting illegal usage of a state and a corresponding
579 -- constituent in pragma [Refined_]Depends.
581 Subp_Inputs
: Elist_Id
:= No_Elist
;
582 Subp_Outputs
: Elist_Id
:= No_Elist
;
583 -- Two lists containing the full set of inputs and output of the related
584 -- subprograms. Note that these lists contain both nodes and entities.
586 Task_Input_Seen
: Boolean := False;
587 Task_Output_Seen
: Boolean := False;
588 -- Flags used to track the implicit dependence of a task unit on itself
590 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
591 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
592 -- to the name buffer. The individual kinds are as follows:
593 -- E_Abstract_State - "state"
594 -- E_Constant - "constant"
595 -- E_Generic_In_Out_Parameter - "generic parameter"
596 -- E_Generic_In_Parameter - "generic parameter"
597 -- E_In_Parameter - "parameter"
598 -- E_In_Out_Parameter - "parameter"
599 -- E_Loop_Parameter - "loop parameter"
600 -- E_Out_Parameter - "parameter"
601 -- E_Protected_Type - "current instance of protected type"
602 -- E_Task_Type - "current instance of task type"
603 -- E_Variable - "global"
605 procedure Analyze_Dependency_Clause
608 -- Verify the legality of a single dependency clause. Flag Is_Last
609 -- denotes whether Clause is the last clause in the relation.
611 procedure Check_Function_Return
;
612 -- Verify that Funtion'Result appears as one of the outputs
613 -- (SPARK RM 6.1.5(10)).
620 -- Ensure that an item fulfills its designated input and/or output role
621 -- as specified by pragma Global (if any) or the enclosing context. If
622 -- this is not the case, emit an error. Item and Item_Id denote the
623 -- attributes of an item. Flag Is_Input should be set when item comes
624 -- from an input list. Flag Self_Ref should be set when the item is an
625 -- output and the dependency clause has operator "+".
627 procedure Check_Usage
628 (Subp_Items
: Elist_Id
;
629 Used_Items
: Elist_Id
;
631 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
632 -- error if this is not the case.
634 procedure Normalize_Clause
(Clause
: Node_Id
);
635 -- Remove a self-dependency "+" from the input list of a clause
637 -----------------------------
638 -- Add_Item_To_Name_Buffer --
639 -----------------------------
641 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
643 if Ekind
(Item_Id
) = E_Abstract_State
then
644 Add_Str_To_Name_Buffer
("state");
646 elsif Ekind
(Item_Id
) = E_Constant
then
647 Add_Str_To_Name_Buffer
("constant");
649 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
650 E_Generic_In_Parameter
)
652 Add_Str_To_Name_Buffer
("generic parameter");
654 elsif Is_Formal
(Item_Id
) then
655 Add_Str_To_Name_Buffer
("parameter");
657 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
658 Add_Str_To_Name_Buffer
("loop parameter");
660 elsif Ekind
(Item_Id
) = E_Protected_Type
661 or else Is_Single_Protected_Object
(Item_Id
)
663 Add_Str_To_Name_Buffer
("current instance of protected type");
665 elsif Ekind
(Item_Id
) = E_Task_Type
666 or else Is_Single_Task_Object
(Item_Id
)
668 Add_Str_To_Name_Buffer
("current instance of task type");
670 elsif Ekind
(Item_Id
) = E_Variable
then
671 Add_Str_To_Name_Buffer
("global");
673 -- The routine should not be called with non-SPARK items
678 end Add_Item_To_Name_Buffer
;
680 -------------------------------
681 -- Analyze_Dependency_Clause --
682 -------------------------------
684 procedure Analyze_Dependency_Clause
688 procedure Analyze_Input_List
(Inputs
: Node_Id
);
689 -- Verify the legality of a single input list
691 procedure Analyze_Input_Output
696 Seen
: in out Elist_Id
;
697 Null_Seen
: in out Boolean;
698 Non_Null_Seen
: in out Boolean);
699 -- Verify the legality of a single input or output item. Flag
700 -- Is_Input should be set whenever Item is an input, False when it
701 -- denotes an output. Flag Self_Ref should be set when the item is an
702 -- output and the dependency clause has a "+". Flag Top_Level should
703 -- be set whenever Item appears immediately within an input or output
704 -- list. Seen is a collection of all abstract states, objects and
705 -- formals processed so far. Flag Null_Seen denotes whether a null
706 -- input or output has been encountered. Flag Non_Null_Seen denotes
707 -- whether a non-null input or output has been encountered.
709 ------------------------
710 -- Analyze_Input_List --
711 ------------------------
713 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
714 Inputs_Seen
: Elist_Id
:= No_Elist
;
715 -- A list containing the entities of all inputs that appear in the
716 -- current input list.
718 Non_Null_Input_Seen
: Boolean := False;
719 Null_Input_Seen
: Boolean := False;
720 -- Flags used to check the legality of an input list
725 -- Multiple inputs appear as an aggregate
727 if Nkind
(Inputs
) = N_Aggregate
then
728 if Present
(Component_Associations
(Inputs
)) then
730 ("nested dependency relations not allowed", Inputs
);
732 elsif Present
(Expressions
(Inputs
)) then
733 Input
:= First
(Expressions
(Inputs
));
734 while Present
(Input
) loop
741 Null_Seen
=> Null_Input_Seen
,
742 Non_Null_Seen
=> Non_Null_Input_Seen
);
747 -- Syntax error, always report
750 Error_Msg_N
("malformed input dependency list", Inputs
);
753 -- Process a solitary input
762 Null_Seen
=> Null_Input_Seen
,
763 Non_Null_Seen
=> Non_Null_Input_Seen
);
766 -- Detect an illegal dependency clause of the form
770 if Null_Output_Seen
and then Null_Input_Seen
then
772 ("null dependency clause cannot have a null input list",
775 end Analyze_Input_List
;
777 --------------------------
778 -- Analyze_Input_Output --
779 --------------------------
781 procedure Analyze_Input_Output
786 Seen
: in out Elist_Id
;
787 Null_Seen
: in out Boolean;
788 Non_Null_Seen
: in out Boolean)
790 procedure Current_Task_Instance_Seen
;
791 -- Set the appropriate global flag when the current instance of a
792 -- task unit is encountered.
794 --------------------------------
795 -- Current_Task_Instance_Seen --
796 --------------------------------
798 procedure Current_Task_Instance_Seen
is
801 Task_Input_Seen
:= True;
803 Task_Output_Seen
:= True;
805 end Current_Task_Instance_Seen
;
809 Is_Output
: constant Boolean := not Is_Input
;
813 -- Start of processing for Analyze_Input_Output
816 -- Multiple input or output items appear as an aggregate
818 if Nkind
(Item
) = N_Aggregate
then
819 if not Top_Level
then
820 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
822 elsif Present
(Component_Associations
(Item
)) then
824 ("nested dependency relations not allowed", Item
);
826 -- Recursively analyze the grouped items
828 elsif Present
(Expressions
(Item
)) then
829 Grouped
:= First
(Expressions
(Item
));
830 while Present
(Grouped
) loop
833 Is_Input
=> Is_Input
,
834 Self_Ref
=> Self_Ref
,
837 Null_Seen
=> Null_Seen
,
838 Non_Null_Seen
=> Non_Null_Seen
);
843 -- Syntax error, always report
846 Error_Msg_N
("malformed dependency list", Item
);
849 -- Process attribute 'Result in the context of a dependency clause
851 elsif Is_Attribute_Result
(Item
) then
852 Non_Null_Seen
:= True;
856 -- Attribute 'Result is allowed to appear on the output side of
857 -- a dependency clause (SPARK RM 6.1.5(6)).
860 SPARK_Msg_N
("function result cannot act as input", Item
);
864 ("cannot mix null and non-null dependency items", Item
);
870 -- Detect multiple uses of null in a single dependency list or
871 -- throughout the whole relation. Verify the placement of a null
872 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
874 elsif Nkind
(Item
) = N_Null
then
877 ("multiple null dependency relations not allowed", Item
);
879 elsif Non_Null_Seen
then
881 ("cannot mix null and non-null dependency items", Item
);
889 ("null output list must be the last clause in a "
890 & "dependency relation", Item
);
892 -- Catch a useless dependence of the form:
897 ("useless dependence, null depends on itself", Item
);
905 Non_Null_Seen
:= True;
908 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
912 Resolve_State
(Item
);
914 -- Find the entity of the item. If this is a renaming, climb
915 -- the renaming chain to reach the root object. Renamings of
916 -- non-entire objects do not yield an entity (Empty).
918 Item_Id
:= Entity_Of
(Item
);
920 if Present
(Item_Id
) then
924 if Ekind_In
(Item_Id
, E_Constant
, E_Loop_Parameter
)
927 -- Current instances of concurrent types
929 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
934 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
935 E_Generic_In_Parameter
,
943 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
945 -- A [generic] function is not allowed to have Output
946 -- items in its dependency relations. Note that "null"
947 -- and attribute 'Result are still valid items.
949 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
950 and then not Is_Input
953 ("output item is not applicable to function", Item
);
956 -- The item denotes a concurrent type. Note that single
957 -- protected/task types are not considered here because
958 -- they behave as objects in the context of pragma
959 -- [Refined_]Depends.
961 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
963 -- This use is legal as long as the concurrent type is
964 -- the current instance of an enclosing type.
966 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
968 -- The dependence of a task unit on itself is
969 -- implicit and may or may not be explicitly
970 -- specified (SPARK RM 6.1.4).
972 if Ekind
(Item_Id
) = E_Task_Type
then
973 Current_Task_Instance_Seen
;
976 -- Otherwise this is not the current instance
980 ("invalid use of subtype mark in dependency "
984 -- The dependency of a task unit on itself is implicit
985 -- and may or may not be explicitly specified
988 elsif Is_Single_Task_Object
(Item_Id
)
989 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
991 Current_Task_Instance_Seen
;
994 -- Ensure that the item fulfills its role as input and/or
995 -- output as specified by pragma Global or the enclosing
998 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1000 -- Detect multiple uses of the same state, variable or
1001 -- formal parameter. If this is not the case, add the
1002 -- item to the list of processed relations.
1004 if Contains
(Seen
, Item_Id
) then
1006 ("duplicate use of item &", Item
, Item_Id
);
1008 Append_New_Elmt
(Item_Id
, Seen
);
1011 -- Detect illegal use of an input related to a null
1012 -- output. Such input items cannot appear in other
1013 -- input lists (SPARK RM 6.1.5(13)).
1016 and then Null_Output_Seen
1017 and then Contains
(All_Inputs_Seen
, Item_Id
)
1020 ("input of a null output list cannot appear in "
1021 & "multiple input lists", Item
);
1024 -- Add an input or a self-referential output to the list
1025 -- of all processed inputs.
1027 if Is_Input
or else Self_Ref
then
1028 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1031 -- State related checks (SPARK RM 6.1.5(3))
1033 if Ekind
(Item_Id
) = E_Abstract_State
then
1035 -- Package and subprogram bodies are instantiated
1036 -- individually in a separate compiler pass. Due to
1037 -- this mode of instantiation, the refinement of a
1038 -- state may no longer be visible when a subprogram
1039 -- body contract is instantiated. Since the generic
1040 -- template is legal, do not perform this check in
1041 -- the instance to circumvent this oddity.
1043 if Is_Generic_Instance
(Spec_Id
) then
1046 -- An abstract state with visible refinement cannot
1047 -- appear in pragma [Refined_]Depends as its place
1048 -- must be taken by some of its constituents
1049 -- (SPARK RM 6.1.4(7)).
1051 elsif Has_Visible_Refinement
(Item_Id
) then
1053 ("cannot mention state & in dependence relation",
1055 SPARK_Msg_N
("\use its constituents instead", Item
);
1058 -- If the reference to the abstract state appears in
1059 -- an enclosing package body that will eventually
1060 -- refine the state, record the reference for future
1064 Record_Possible_Body_Reference
1065 (State_Id
=> Item_Id
,
1070 -- When the item renames an entire object, replace the
1071 -- item with a reference to the object.
1073 if Entity
(Item
) /= Item_Id
then
1075 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1079 -- Add the entity of the current item to the list of
1082 if Ekind
(Item_Id
) = E_Abstract_State
then
1083 Append_New_Elmt
(Item_Id
, States_Seen
);
1085 -- The variable may eventually become a constituent of a
1086 -- single protected/task type. Record the reference now
1087 -- and verify its legality when analyzing the contract of
1088 -- the variable (SPARK RM 9.3).
1090 elsif Ekind
(Item_Id
) = E_Variable
then
1091 Record_Possible_Part_Of_Reference
1096 if Ekind_In
(Item_Id
, E_Abstract_State
,
1099 and then Present
(Encapsulating_State
(Item_Id
))
1101 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1104 -- All other input/output items are illegal
1105 -- (SPARK RM 6.1.5(1)).
1109 ("item must denote parameter, variable, state or "
1110 & "current instance of concurrent type", Item
);
1113 -- All other input/output items are illegal
1114 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1118 ("item must denote parameter, variable, state or current "
1119 & "instance of concurrent type", Item
);
1122 end Analyze_Input_Output
;
1130 Non_Null_Output_Seen
: Boolean := False;
1131 -- Flag used to check the legality of an output list
1133 -- Start of processing for Analyze_Dependency_Clause
1136 Inputs
:= Expression
(Clause
);
1139 -- An input list with a self-dependency appears as operator "+" where
1140 -- the actuals inputs are the right operand.
1142 if Nkind
(Inputs
) = N_Op_Plus
then
1143 Inputs
:= Right_Opnd
(Inputs
);
1147 -- Process the output_list of a dependency_clause
1149 Output
:= First
(Choices
(Clause
));
1150 while Present
(Output
) loop
1151 Analyze_Input_Output
1154 Self_Ref
=> Self_Ref
,
1156 Seen
=> All_Outputs_Seen
,
1157 Null_Seen
=> Null_Output_Seen
,
1158 Non_Null_Seen
=> Non_Null_Output_Seen
);
1163 -- Process the input_list of a dependency_clause
1165 Analyze_Input_List
(Inputs
);
1166 end Analyze_Dependency_Clause
;
1168 ---------------------------
1169 -- Check_Function_Return --
1170 ---------------------------
1172 procedure Check_Function_Return
is
1174 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1175 and then not Result_Seen
1178 ("result of & must appear in exactly one output list",
1181 end Check_Function_Return
;
1187 procedure Check_Role
1189 Item_Id
: Entity_Id
;
1194 (Item_Is_Input
: out Boolean;
1195 Item_Is_Output
: out Boolean);
1196 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1197 -- Item_Is_Output are set depending on the role.
1199 procedure Role_Error
1200 (Item_Is_Input
: Boolean;
1201 Item_Is_Output
: Boolean);
1202 -- Emit an error message concerning the incorrect use of Item in
1203 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1204 -- denote whether the item is an input and/or an output.
1211 (Item_Is_Input
: out Boolean;
1212 Item_Is_Output
: out Boolean)
1215 case Ekind
(Item_Id
) is
1219 when E_Abstract_State
=>
1221 -- When pragma Global is present it determines the mode of
1222 -- the abstract state.
1225 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1226 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1228 -- Otherwise the state has a default IN OUT mode, because it
1229 -- behaves as a variable.
1232 Item_Is_Input
:= True;
1233 Item_Is_Output
:= True;
1236 -- Constants and IN parameters
1239 | E_Generic_In_Parameter
1243 -- When pragma Global is present it determines the mode
1244 -- of constant objects as inputs (and such objects cannot
1245 -- appear as outputs in the Global contract).
1248 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1250 Item_Is_Input
:= True;
1253 Item_Is_Output
:= False;
1255 -- Variables and IN OUT parameters
1257 when E_Generic_In_Out_Parameter
1258 | E_In_Out_Parameter
1261 -- When pragma Global is present it determines the mode of
1266 -- A variable has mode IN when its type is unconstrained
1267 -- or tagged because array bounds, discriminants or tags
1271 Appears_In
(Subp_Inputs
, Item_Id
)
1272 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1274 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1276 -- Otherwise the variable has a default IN OUT mode
1279 Item_Is_Input
:= True;
1280 Item_Is_Output
:= True;
1283 when E_Out_Parameter
=>
1285 -- An OUT parameter of the related subprogram; it cannot
1286 -- appear in Global.
1288 if Scope
(Item_Id
) = Spec_Id
then
1290 -- The parameter has mode IN if its type is unconstrained
1291 -- or tagged because array bounds, discriminants or tags
1295 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1297 Item_Is_Output
:= True;
1299 -- An OUT parameter of an enclosing subprogram; it can
1300 -- appear in Global and behaves as a read-write variable.
1303 -- When pragma Global is present it determines the mode
1308 -- A variable has mode IN when its type is
1309 -- unconstrained or tagged because array
1310 -- bounds, discriminants or tags can be read.
1313 Appears_In
(Subp_Inputs
, Item_Id
)
1314 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1316 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1318 -- Otherwise the variable has a default IN OUT mode
1321 Item_Is_Input
:= True;
1322 Item_Is_Output
:= True;
1328 when E_Protected_Type
=>
1331 -- A variable has mode IN when its type is unconstrained
1332 -- or tagged because array bounds, discriminants or tags
1336 Appears_In
(Subp_Inputs
, Item_Id
)
1337 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1339 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1342 -- A protected type acts as a formal parameter of mode IN
1343 -- when it applies to a protected function.
1345 if Ekind
(Spec_Id
) = E_Function
then
1346 Item_Is_Input
:= True;
1347 Item_Is_Output
:= False;
1349 -- Otherwise the protected type acts as a formal of mode
1353 Item_Is_Input
:= True;
1354 Item_Is_Output
:= True;
1362 -- When pragma Global is present it determines the mode of
1367 Appears_In
(Subp_Inputs
, Item_Id
)
1368 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1370 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1372 -- Otherwise task types act as IN OUT parameters
1375 Item_Is_Input
:= True;
1376 Item_Is_Output
:= True;
1380 raise Program_Error
;
1388 procedure Role_Error
1389 (Item_Is_Input
: Boolean;
1390 Item_Is_Output
: Boolean)
1392 Error_Msg
: Name_Id
;
1397 -- When the item is not part of the input and the output set of
1398 -- the related subprogram, then it appears as extra in pragma
1399 -- [Refined_]Depends.
1401 if not Item_Is_Input
and then not Item_Is_Output
then
1402 Add_Item_To_Name_Buffer
(Item_Id
);
1403 Add_Str_To_Name_Buffer
1404 (" & cannot appear in dependence relation");
1406 Error_Msg
:= Name_Find
;
1407 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1409 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1411 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1412 & "set of subprogram %"), Item
, Item_Id
);
1414 -- The mode of the item and its role in pragma [Refined_]Depends
1415 -- are in conflict. Construct a detailed message explaining the
1416 -- illegality (SPARK RM 6.1.5(5-6)).
1419 if Item_Is_Input
then
1420 Add_Str_To_Name_Buffer
("read-only");
1422 Add_Str_To_Name_Buffer
("write-only");
1425 Add_Char_To_Name_Buffer
(' ');
1426 Add_Item_To_Name_Buffer
(Item_Id
);
1427 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1429 if Item_Is_Input
then
1430 Add_Str_To_Name_Buffer
("output");
1432 Add_Str_To_Name_Buffer
("input");
1435 Add_Str_To_Name_Buffer
(" in dependence relation");
1436 Error_Msg
:= Name_Find
;
1437 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1443 Item_Is_Input
: Boolean;
1444 Item_Is_Output
: Boolean;
1446 -- Start of processing for Check_Role
1449 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1454 if not Item_Is_Input
then
1455 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1458 -- Self-referential item
1461 if not Item_Is_Input
or else not Item_Is_Output
then
1462 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1467 elsif not Item_Is_Output
then
1468 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1476 procedure Check_Usage
1477 (Subp_Items
: Elist_Id
;
1478 Used_Items
: Elist_Id
;
1481 procedure Usage_Error
(Item_Id
: Entity_Id
);
1482 -- Emit an error concerning the illegal usage of an item
1488 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1489 Error_Msg
: Name_Id
;
1496 -- Unconstrained and tagged items are not part of the explicit
1497 -- input set of the related subprogram, they do not have to be
1498 -- present in a dependence relation and should not be flagged
1499 -- (SPARK RM 6.1.5(5)).
1501 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1504 Add_Item_To_Name_Buffer
(Item_Id
);
1505 Add_Str_To_Name_Buffer
1506 (" & is missing from input dependence list");
1508 Error_Msg
:= Name_Find
;
1509 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1511 ("\add `null ='> &` dependency to ignore this input",
1515 -- Output case (SPARK RM 6.1.5(10))
1520 Add_Item_To_Name_Buffer
(Item_Id
);
1521 Add_Str_To_Name_Buffer
1522 (" & is missing from output dependence list");
1524 Error_Msg
:= Name_Find
;
1525 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1533 Item_Id
: Entity_Id
;
1535 -- Start of processing for Check_Usage
1538 if No
(Subp_Items
) then
1542 -- Each input or output of the subprogram must appear in a dependency
1545 Elmt
:= First_Elmt
(Subp_Items
);
1546 while Present
(Elmt
) loop
1547 Item
:= Node
(Elmt
);
1549 if Nkind
(Item
) = N_Defining_Identifier
then
1552 Item_Id
:= Entity_Of
(Item
);
1555 -- The item does not appear in a dependency
1557 if Present
(Item_Id
)
1558 and then not Contains
(Used_Items
, Item_Id
)
1560 if Is_Formal
(Item_Id
) then
1561 Usage_Error
(Item_Id
);
1563 -- The current instance of a protected type behaves as a formal
1564 -- parameter (SPARK RM 6.1.4).
1566 elsif Ekind
(Item_Id
) = E_Protected_Type
1567 or else Is_Single_Protected_Object
(Item_Id
)
1569 Usage_Error
(Item_Id
);
1571 -- The current instance of a task type behaves as a formal
1572 -- parameter (SPARK RM 6.1.4).
1574 elsif Ekind
(Item_Id
) = E_Task_Type
1575 or else Is_Single_Task_Object
(Item_Id
)
1577 -- The dependence of a task unit on itself is implicit and
1578 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1579 -- Emit an error if only one input/output is present.
1581 if Task_Input_Seen
/= Task_Output_Seen
then
1582 Usage_Error
(Item_Id
);
1585 -- States and global objects are not used properly only when
1586 -- the subprogram is subject to pragma Global.
1588 elsif Global_Seen
then
1589 Usage_Error
(Item_Id
);
1597 ----------------------
1598 -- Normalize_Clause --
1599 ----------------------
1601 procedure Normalize_Clause
(Clause
: Node_Id
) is
1602 procedure Create_Or_Modify_Clause
1608 Multiple
: Boolean);
1609 -- Create a brand new clause to represent the self-reference or
1610 -- modify the input and/or output lists of an existing clause. Output
1611 -- denotes a self-referencial output. Outputs is the output list of a
1612 -- clause. Inputs is the input list of a clause. After denotes the
1613 -- clause after which the new clause is to be inserted. Flag In_Place
1614 -- should be set when normalizing the last output of an output list.
1615 -- Flag Multiple should be set when Output comes from a list with
1618 -----------------------------
1619 -- Create_Or_Modify_Clause --
1620 -----------------------------
1622 procedure Create_Or_Modify_Clause
1630 procedure Propagate_Output
1633 -- Handle the various cases of output propagation to the input
1634 -- list. Output denotes a self-referencial output item. Inputs
1635 -- is the input list of a clause.
1637 ----------------------
1638 -- Propagate_Output --
1639 ----------------------
1641 procedure Propagate_Output
1645 function In_Input_List
1647 Inputs
: List_Id
) return Boolean;
1648 -- Determine whether a particulat item appears in the input
1649 -- list of a clause.
1655 function In_Input_List
1657 Inputs
: List_Id
) return Boolean
1662 Elmt
:= First
(Inputs
);
1663 while Present
(Elmt
) loop
1664 if Entity_Of
(Elmt
) = Item
then
1676 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1679 -- Start of processing for Propagate_Output
1682 -- The clause is of the form:
1684 -- (Output =>+ null)
1686 -- Remove null input and replace it with a copy of the output:
1688 -- (Output => Output)
1690 if Nkind
(Inputs
) = N_Null
then
1691 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1693 -- The clause is of the form:
1695 -- (Output =>+ (Input1, ..., InputN))
1697 -- Determine whether the output is not already mentioned in the
1698 -- input list and if not, add it to the list of inputs:
1700 -- (Output => (Output, Input1, ..., InputN))
1702 elsif Nkind
(Inputs
) = N_Aggregate
then
1703 Grouped
:= Expressions
(Inputs
);
1705 if not In_Input_List
1709 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1712 -- The clause is of the form:
1714 -- (Output =>+ Input)
1716 -- If the input does not mention the output, group the two
1719 -- (Output => (Output, Input))
1721 elsif Entity_Of
(Inputs
) /= Output_Id
then
1723 Make_Aggregate
(Loc
,
1724 Expressions
=> New_List
(
1725 New_Copy_Tree
(Output
),
1726 New_Copy_Tree
(Inputs
))));
1728 end Propagate_Output
;
1732 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1733 New_Clause
: Node_Id
;
1735 -- Start of processing for Create_Or_Modify_Clause
1738 -- A null output depending on itself does not require any
1741 if Nkind
(Output
) = N_Null
then
1744 -- A function result cannot depend on itself because it cannot
1745 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1747 elsif Is_Attribute_Result
(Output
) then
1748 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1752 -- When performing the transformation in place, simply add the
1753 -- output to the list of inputs (if not already there). This
1754 -- case arises when dealing with the last output of an output
1755 -- list. Perform the normalization in place to avoid generating
1756 -- a malformed tree.
1759 Propagate_Output
(Output
, Inputs
);
1761 -- A list with multiple outputs is slowly trimmed until only
1762 -- one element remains. When this happens, replace aggregate
1763 -- with the element itself.
1767 Rewrite
(Outputs
, Output
);
1773 -- Unchain the output from its output list as it will appear in
1774 -- a new clause. Note that we cannot simply rewrite the output
1775 -- as null because this will violate the semantics of pragma
1780 -- Generate a new clause of the form:
1781 -- (Output => Inputs)
1784 Make_Component_Association
(Loc
,
1785 Choices
=> New_List
(Output
),
1786 Expression
=> New_Copy_Tree
(Inputs
));
1788 -- The new clause contains replicated content that has already
1789 -- been analyzed. There is not need to reanalyze or renormalize
1792 Set_Analyzed
(New_Clause
);
1795 (Output
=> First
(Choices
(New_Clause
)),
1796 Inputs
=> Expression
(New_Clause
));
1798 Insert_After
(After
, New_Clause
);
1800 end Create_Or_Modify_Clause
;
1804 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1806 Last_Output
: Node_Id
;
1807 Next_Output
: Node_Id
;
1810 -- Start of processing for Normalize_Clause
1813 -- A self-dependency appears as operator "+". Remove the "+" from the
1814 -- tree by moving the real inputs to their proper place.
1816 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1817 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1818 Inputs
:= Expression
(Clause
);
1820 -- Multiple outputs appear as an aggregate
1822 if Nkind
(Outputs
) = N_Aggregate
then
1823 Last_Output
:= Last
(Expressions
(Outputs
));
1825 Output
:= First
(Expressions
(Outputs
));
1826 while Present
(Output
) loop
1828 -- Normalization may remove an output from its list,
1829 -- preserve the subsequent output now.
1831 Next_Output
:= Next
(Output
);
1833 Create_Or_Modify_Clause
1838 In_Place
=> Output
= Last_Output
,
1841 Output
:= Next_Output
;
1847 Create_Or_Modify_Clause
1856 end Normalize_Clause
;
1860 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1861 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1865 Last_Clause
: Node_Id
;
1866 Restore_Scope
: Boolean := False;
1868 -- Start of processing for Analyze_Depends_In_Decl_Part
1871 -- Do not analyze the pragma multiple times
1873 if Is_Analyzed_Pragma
(N
) then
1877 -- Empty dependency list
1879 if Nkind
(Deps
) = N_Null
then
1881 -- Gather all states, objects and formal parameters that the
1882 -- subprogram may depend on. These items are obtained from the
1883 -- parameter profile or pragma [Refined_]Global (if available).
1885 Collect_Subprogram_Inputs_Outputs
1886 (Subp_Id
=> Subp_Id
,
1887 Subp_Inputs
=> Subp_Inputs
,
1888 Subp_Outputs
=> Subp_Outputs
,
1889 Global_Seen
=> Global_Seen
);
1891 -- Verify that every input or output of the subprogram appear in a
1894 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1895 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1896 Check_Function_Return
;
1898 -- Dependency clauses appear as component associations of an aggregate
1900 elsif Nkind
(Deps
) = N_Aggregate
then
1902 -- Do not attempt to perform analysis of a syntactically illegal
1903 -- clause as this will lead to misleading errors.
1905 if Has_Extra_Parentheses
(Deps
) then
1909 if Present
(Component_Associations
(Deps
)) then
1910 Last_Clause
:= Last
(Component_Associations
(Deps
));
1912 -- Gather all states, objects and formal parameters that the
1913 -- subprogram may depend on. These items are obtained from the
1914 -- parameter profile or pragma [Refined_]Global (if available).
1916 Collect_Subprogram_Inputs_Outputs
1917 (Subp_Id
=> Subp_Id
,
1918 Subp_Inputs
=> Subp_Inputs
,
1919 Subp_Outputs
=> Subp_Outputs
,
1920 Global_Seen
=> Global_Seen
);
1922 -- When pragma [Refined_]Depends appears on a single concurrent
1923 -- type, it is relocated to the anonymous object.
1925 if Is_Single_Concurrent_Object
(Spec_Id
) then
1928 -- Ensure that the formal parameters are visible when analyzing
1929 -- all clauses. This falls out of the general rule of aspects
1930 -- pertaining to subprogram declarations.
1932 elsif not In_Open_Scopes
(Spec_Id
) then
1933 Restore_Scope
:= True;
1934 Push_Scope
(Spec_Id
);
1936 if Ekind
(Spec_Id
) = E_Task_Type
then
1937 if Has_Discriminants
(Spec_Id
) then
1938 Install_Discriminants
(Spec_Id
);
1941 elsif Is_Generic_Subprogram
(Spec_Id
) then
1942 Install_Generic_Formals
(Spec_Id
);
1945 Install_Formals
(Spec_Id
);
1949 Clause
:= First
(Component_Associations
(Deps
));
1950 while Present
(Clause
) loop
1951 Errors
:= Serious_Errors_Detected
;
1953 -- The normalization mechanism may create extra clauses that
1954 -- contain replicated input and output names. There is no need
1955 -- to reanalyze them.
1957 if not Analyzed
(Clause
) then
1958 Set_Analyzed
(Clause
);
1960 Analyze_Dependency_Clause
1962 Is_Last
=> Clause
= Last_Clause
);
1965 -- Do not normalize a clause if errors were detected (count
1966 -- of Serious_Errors has increased) because the inputs and/or
1967 -- outputs may denote illegal items. Normalization is disabled
1968 -- in ASIS mode as it alters the tree by introducing new nodes
1969 -- similar to expansion.
1971 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1972 Normalize_Clause
(Clause
);
1978 if Restore_Scope
then
1982 -- Verify that every input or output of the subprogram appear in a
1985 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1986 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1987 Check_Function_Return
;
1989 -- The dependency list is malformed. This is a syntax error, always
1993 Error_Msg_N
("malformed dependency relation", Deps
);
1997 -- The top level dependency relation is malformed. This is a syntax
1998 -- error, always report.
2001 Error_Msg_N
("malformed dependency relation", Deps
);
2005 -- Ensure that a state and a corresponding constituent do not appear
2006 -- together in pragma [Refined_]Depends.
2008 Check_State_And_Constituent_Use
2009 (States
=> States_Seen
,
2010 Constits
=> Constits_Seen
,
2014 Set_Is_Analyzed_Pragma
(N
);
2015 end Analyze_Depends_In_Decl_Part
;
2017 --------------------------------------------
2018 -- Analyze_External_Property_In_Decl_Part --
2019 --------------------------------------------
2021 procedure Analyze_External_Property_In_Decl_Part
2023 Expr_Val
: out Boolean)
2025 Arg1
: constant Node_Id
:=
2026 First
(Pragma_Argument_Associations
(N
));
2027 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2028 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2034 -- Do not analyze the pragma multiple times
2036 if Is_Analyzed_Pragma
(N
) then
2040 Error_Msg_Name_1
:= Pragma_Name
(N
);
2042 -- An external property pragma must apply to an effectively volatile
2043 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2044 -- The check is performed at the end of the declarative region due to a
2045 -- possible out-of-order arrangement of pragmas:
2048 -- pragma Async_Readers (Obj);
2049 -- pragma Volatile (Obj);
2051 if not Is_Effectively_Volatile
(Obj_Id
) then
2053 ("external property % must apply to a volatile object", N
);
2056 -- Ensure that the Boolean expression (if present) is static. A missing
2057 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2061 if Present
(Arg1
) then
2062 Expr
:= Get_Pragma_Arg
(Arg1
);
2064 if Is_OK_Static_Expression
(Expr
) then
2065 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2069 Set_Is_Analyzed_Pragma
(N
);
2070 end Analyze_External_Property_In_Decl_Part
;
2072 ---------------------------------
2073 -- Analyze_Global_In_Decl_Part --
2074 ---------------------------------
2076 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2077 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2078 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2079 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2081 Constits_Seen
: Elist_Id
:= No_Elist
;
2082 -- A list containing the entities of all constituents processed so far.
2083 -- It aids in detecting illegal usage of a state and a corresponding
2084 -- constituent in pragma [Refinde_]Global.
2086 Seen
: Elist_Id
:= No_Elist
;
2087 -- A list containing the entities of all the items processed so far. It
2088 -- plays a role in detecting distinct entities.
2090 States_Seen
: Elist_Id
:= No_Elist
;
2091 -- A list containing the entities of all states processed so far. It
2092 -- helps in detecting illegal usage of a state and a corresponding
2093 -- constituent in pragma [Refined_]Global.
2095 In_Out_Seen
: Boolean := False;
2096 Input_Seen
: Boolean := False;
2097 Output_Seen
: Boolean := False;
2098 Proof_Seen
: Boolean := False;
2099 -- Flags used to verify the consistency of modes
2101 procedure Analyze_Global_List
2103 Global_Mode
: Name_Id
:= Name_Input
);
2104 -- Verify the legality of a single global list declaration. Global_Mode
2105 -- denotes the current mode in effect.
2107 -------------------------
2108 -- Analyze_Global_List --
2109 -------------------------
2111 procedure Analyze_Global_List
2113 Global_Mode
: Name_Id
:= Name_Input
)
2115 procedure Analyze_Global_Item
2117 Global_Mode
: Name_Id
);
2118 -- Verify the legality of a single global item declaration denoted by
2119 -- Item. Global_Mode denotes the current mode in effect.
2121 procedure Check_Duplicate_Mode
2123 Status
: in out Boolean);
2124 -- Flag Status denotes whether a particular mode has been seen while
2125 -- processing a global list. This routine verifies that Mode is not a
2126 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2128 procedure Check_Mode_Restriction_In_Enclosing_Context
2130 Item_Id
: Entity_Id
);
2131 -- Verify that an item of mode In_Out or Output does not appear as
2132 -- an input in the Global aspect of an enclosing subprogram or task
2133 -- unit. If this is the case, emit an error. Item and Item_Id are
2134 -- respectively the item and its entity.
2136 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2137 -- Mode denotes either In_Out or Output. Depending on the kind of the
2138 -- related subprogram, emit an error if those two modes apply to a
2139 -- function (SPARK RM 6.1.4(10)).
2141 -------------------------
2142 -- Analyze_Global_Item --
2143 -------------------------
2145 procedure Analyze_Global_Item
2147 Global_Mode
: Name_Id
)
2149 Item_Id
: Entity_Id
;
2152 -- Detect one of the following cases
2154 -- with Global => (null, Name)
2155 -- with Global => (Name_1, null, Name_2)
2156 -- with Global => (Name, null)
2158 if Nkind
(Item
) = N_Null
then
2159 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2164 Resolve_State
(Item
);
2166 -- Find the entity of the item. If this is a renaming, climb the
2167 -- renaming chain to reach the root object. Renamings of non-
2168 -- entire objects do not yield an entity (Empty).
2170 Item_Id
:= Entity_Of
(Item
);
2172 if Present
(Item_Id
) then
2174 -- A global item may denote a formal parameter of an enclosing
2175 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2176 -- provide a better error diagnostic.
2178 if Is_Formal
(Item_Id
) then
2179 if Scope
(Item_Id
) = Spec_Id
then
2181 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2182 & "parameter of subprogram &"), Item
, Spec_Id
);
2186 -- A global item may denote a concurrent type as long as it is
2187 -- the current instance of an enclosing protected or task type
2188 -- (SPARK RM 6.1.4).
2190 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2191 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2193 -- Pragma [Refined_]Global associated with a protected
2194 -- subprogram cannot mention the current instance of a
2195 -- protected type because the instance behaves as a
2196 -- formal parameter.
2198 if Ekind
(Item_Id
) = E_Protected_Type
then
2199 if Scope
(Spec_Id
) = Item_Id
then
2200 Error_Msg_Name_1
:= Chars
(Item_Id
);
2202 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2203 & "cannot reference current instance of "
2204 & "protected type %"), Item
, Spec_Id
);
2208 -- Pragma [Refined_]Global associated with a task type
2209 -- cannot mention the current instance of a task type
2210 -- because the instance behaves as a formal parameter.
2212 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2213 if Spec_Id
= Item_Id
then
2214 Error_Msg_Name_1
:= Chars
(Item_Id
);
2216 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2217 & "cannot reference current instance of task "
2218 & "type %"), Item
, Spec_Id
);
2223 -- Otherwise the global item denotes a subtype mark that is
2224 -- not a current instance.
2228 ("invalid use of subtype mark in global list", Item
);
2232 -- A global item may denote the anonymous object created for a
2233 -- single protected/task type as long as the current instance
2234 -- is the same single type (SPARK RM 6.1.4).
2236 elsif Is_Single_Concurrent_Object
(Item_Id
)
2237 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2239 -- Pragma [Refined_]Global associated with a protected
2240 -- subprogram cannot mention the current instance of a
2241 -- protected type because the instance behaves as a formal
2244 if Is_Single_Protected_Object
(Item_Id
) then
2245 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2246 Error_Msg_Name_1
:= Chars
(Item_Id
);
2248 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2249 & "cannot reference current instance of protected "
2250 & "type %"), Item
, Spec_Id
);
2254 -- Pragma [Refined_]Global associated with a task type
2255 -- cannot mention the current instance of a task type
2256 -- because the instance behaves as a formal parameter.
2258 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2259 if Spec_Id
= Item_Id
then
2260 Error_Msg_Name_1
:= Chars
(Item_Id
);
2262 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2263 & "cannot reference current instance of task "
2264 & "type %"), Item
, Spec_Id
);
2269 -- A formal object may act as a global item inside a generic
2271 elsif Is_Formal_Object
(Item_Id
) then
2274 -- The only legal references are those to abstract states,
2275 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2277 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2283 ("global item must denote object, state or current "
2284 & "instance of concurrent type", Item
);
2288 -- State related checks
2290 if Ekind
(Item_Id
) = E_Abstract_State
then
2292 -- Package and subprogram bodies are instantiated
2293 -- individually in a separate compiler pass. Due to this
2294 -- mode of instantiation, the refinement of a state may
2295 -- no longer be visible when a subprogram body contract
2296 -- is instantiated. Since the generic template is legal,
2297 -- do not perform this check in the instance to circumvent
2300 if Is_Generic_Instance
(Spec_Id
) then
2303 -- An abstract state with visible refinement cannot appear
2304 -- in pragma [Refined_]Global as its place must be taken by
2305 -- some of its constituents (SPARK RM 6.1.4(7)).
2307 elsif Has_Visible_Refinement
(Item_Id
) then
2309 ("cannot mention state & in global refinement",
2311 SPARK_Msg_N
("\use its constituents instead", Item
);
2314 -- An external state cannot appear as a global item of a
2315 -- nonvolatile function (SPARK RM 7.1.3(8)).
2317 elsif Is_External_State
(Item_Id
)
2318 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2319 and then not Is_Volatile_Function
(Spec_Id
)
2322 ("external state & cannot act as global item of "
2323 & "nonvolatile function", Item
, Item_Id
);
2326 -- If the reference to the abstract state appears in an
2327 -- enclosing package body that will eventually refine the
2328 -- state, record the reference for future checks.
2331 Record_Possible_Body_Reference
2332 (State_Id
=> Item_Id
,
2336 -- Constant related checks
2338 elsif Ekind
(Item_Id
) = E_Constant
then
2340 -- A constant is a read-only item, therefore it cannot act
2343 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2345 ("constant & cannot act as output", Item
, Item_Id
);
2349 -- Loop parameter related checks
2351 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2353 -- A loop parameter is a read-only item, therefore it cannot
2354 -- act as an output.
2356 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2358 ("loop parameter & cannot act as output",
2363 -- Variable related checks. These are only relevant when
2364 -- SPARK_Mode is on as they are not standard Ada legality
2367 elsif SPARK_Mode
= On
2368 and then Ekind
(Item_Id
) = E_Variable
2369 and then Is_Effectively_Volatile
(Item_Id
)
2371 -- An effectively volatile object cannot appear as a global
2372 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2374 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2375 and then not Is_Volatile_Function
(Spec_Id
)
2378 ("volatile object & cannot act as global item of a "
2379 & "function", Item
, Item_Id
);
2382 -- An effectively volatile object with external property
2383 -- Effective_Reads set to True must have mode Output or
2384 -- In_Out (SPARK RM 7.1.3(10)).
2386 elsif Effective_Reads_Enabled
(Item_Id
)
2387 and then Global_Mode
= Name_Input
2390 ("volatile object & with property Effective_Reads must "
2391 & "have mode In_Out or Output", Item
, Item_Id
);
2396 -- When the item renames an entire object, replace the item
2397 -- with a reference to the object.
2399 if Entity
(Item
) /= Item_Id
then
2400 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2404 -- Some form of illegal construct masquerading as a name
2405 -- (SPARK RM 6.1.4(4)).
2409 ("global item must denote object, state or current instance "
2410 & "of concurrent type", Item
);
2414 -- Verify that an output does not appear as an input in an
2415 -- enclosing subprogram.
2417 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2418 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2421 -- The same entity might be referenced through various way.
2422 -- Check the entity of the item rather than the item itself
2423 -- (SPARK RM 6.1.4(10)).
2425 if Contains
(Seen
, Item_Id
) then
2426 SPARK_Msg_N
("duplicate global item", Item
);
2428 -- Add the entity of the current item to the list of processed
2432 Append_New_Elmt
(Item_Id
, Seen
);
2434 if Ekind
(Item_Id
) = E_Abstract_State
then
2435 Append_New_Elmt
(Item_Id
, States_Seen
);
2437 -- The variable may eventually become a constituent of a single
2438 -- protected/task type. Record the reference now and verify its
2439 -- legality when analyzing the contract of the variable
2442 elsif Ekind
(Item_Id
) = E_Variable
then
2443 Record_Possible_Part_Of_Reference
2448 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2449 and then Present
(Encapsulating_State
(Item_Id
))
2451 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2454 end Analyze_Global_Item
;
2456 --------------------------
2457 -- Check_Duplicate_Mode --
2458 --------------------------
2460 procedure Check_Duplicate_Mode
2462 Status
: in out Boolean)
2466 SPARK_Msg_N
("duplicate global mode", Mode
);
2470 end Check_Duplicate_Mode
;
2472 -------------------------------------------------
2473 -- Check_Mode_Restriction_In_Enclosing_Context --
2474 -------------------------------------------------
2476 procedure Check_Mode_Restriction_In_Enclosing_Context
2478 Item_Id
: Entity_Id
)
2480 Context
: Entity_Id
;
2482 Inputs
: Elist_Id
:= No_Elist
;
2483 Outputs
: Elist_Id
:= No_Elist
;
2486 -- Traverse the scope stack looking for enclosing subprograms or
2487 -- tasks subject to pragma [Refined_]Global.
2489 Context
:= Scope
(Subp_Id
);
2490 while Present
(Context
) and then Context
/= Standard_Standard
loop
2492 -- For a single task type, retrieve the corresponding object to
2493 -- which pragma [Refined_]Global is attached.
2495 if Ekind
(Context
) = E_Task_Type
2496 and then Is_Single_Concurrent_Type
(Context
)
2498 Context
:= Anonymous_Object
(Context
);
2501 if (Is_Subprogram
(Context
)
2502 or else Ekind
(Context
) = E_Task_Type
2503 or else Is_Single_Task_Object
(Context
))
2505 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2507 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2509 Collect_Subprogram_Inputs_Outputs
2510 (Subp_Id
=> Context
,
2511 Subp_Inputs
=> Inputs
,
2512 Subp_Outputs
=> Outputs
,
2513 Global_Seen
=> Dummy
);
2515 -- The item is classified as In_Out or Output but appears as
2516 -- an Input in an enclosing subprogram or task unit (SPARK
2519 if Appears_In
(Inputs
, Item_Id
)
2520 and then not Appears_In
(Outputs
, Item_Id
)
2523 ("global item & cannot have mode In_Out or Output",
2526 if Is_Subprogram
(Context
) then
2528 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2529 & "of subprogram &"), Item
, Context
);
2532 (Fix_Msg
(Subp_Id
, "\item already appears as input "
2533 & "of task &"), Item
, Context
);
2536 -- Stop the traversal once an error has been detected
2542 Context
:= Scope
(Context
);
2544 end Check_Mode_Restriction_In_Enclosing_Context
;
2546 ----------------------------------------
2547 -- Check_Mode_Restriction_In_Function --
2548 ----------------------------------------
2550 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2552 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2554 ("global mode & is not applicable to functions", Mode
);
2556 end Check_Mode_Restriction_In_Function
;
2564 -- Start of processing for Analyze_Global_List
2567 if Nkind
(List
) = N_Null
then
2568 Set_Analyzed
(List
);
2570 -- Single global item declaration
2572 elsif Nkind_In
(List
, N_Expanded_Name
,
2574 N_Selected_Component
)
2576 Analyze_Global_Item
(List
, Global_Mode
);
2578 -- Simple global list or moded global list declaration
2580 elsif Nkind
(List
) = N_Aggregate
then
2581 Set_Analyzed
(List
);
2583 -- The declaration of a simple global list appear as a collection
2586 if Present
(Expressions
(List
)) then
2587 if Present
(Component_Associations
(List
)) then
2589 ("cannot mix moded and non-moded global lists", List
);
2592 Item
:= First
(Expressions
(List
));
2593 while Present
(Item
) loop
2594 Analyze_Global_Item
(Item
, Global_Mode
);
2598 -- The declaration of a moded global list appears as a collection
2599 -- of component associations where individual choices denote
2602 elsif Present
(Component_Associations
(List
)) then
2603 if Present
(Expressions
(List
)) then
2605 ("cannot mix moded and non-moded global lists", List
);
2608 Assoc
:= First
(Component_Associations
(List
));
2609 while Present
(Assoc
) loop
2610 Mode
:= First
(Choices
(Assoc
));
2612 if Nkind
(Mode
) = N_Identifier
then
2613 if Chars
(Mode
) = Name_In_Out
then
2614 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2615 Check_Mode_Restriction_In_Function
(Mode
);
2617 elsif Chars
(Mode
) = Name_Input
then
2618 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2620 elsif Chars
(Mode
) = Name_Output
then
2621 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2622 Check_Mode_Restriction_In_Function
(Mode
);
2624 elsif Chars
(Mode
) = Name_Proof_In
then
2625 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2628 SPARK_Msg_N
("invalid mode selector", Mode
);
2632 SPARK_Msg_N
("invalid mode selector", Mode
);
2635 -- Items in a moded list appear as a collection of
2636 -- expressions. Reuse the existing machinery to analyze
2640 (List
=> Expression
(Assoc
),
2641 Global_Mode
=> Chars
(Mode
));
2649 raise Program_Error
;
2652 -- Any other attempt to declare a global item is illegal. This is a
2653 -- syntax error, always report.
2656 Error_Msg_N
("malformed global list", List
);
2658 end Analyze_Global_List
;
2662 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2664 Restore_Scope
: Boolean := False;
2666 -- Start of processing for Analyze_Global_In_Decl_Part
2669 -- Do not analyze the pragma multiple times
2671 if Is_Analyzed_Pragma
(N
) then
2675 -- There is nothing to be done for a null global list
2677 if Nkind
(Items
) = N_Null
then
2678 Set_Analyzed
(Items
);
2680 -- Analyze the various forms of global lists and items. Note that some
2681 -- of these may be malformed in which case the analysis emits error
2685 -- When pragma [Refined_]Global appears on a single concurrent type,
2686 -- it is relocated to the anonymous object.
2688 if Is_Single_Concurrent_Object
(Spec_Id
) then
2691 -- Ensure that the formal parameters are visible when processing an
2692 -- item. This falls out of the general rule of aspects pertaining to
2693 -- subprogram declarations.
2695 elsif not In_Open_Scopes
(Spec_Id
) then
2696 Restore_Scope
:= True;
2697 Push_Scope
(Spec_Id
);
2699 if Ekind
(Spec_Id
) = E_Task_Type
then
2700 if Has_Discriminants
(Spec_Id
) then
2701 Install_Discriminants
(Spec_Id
);
2704 elsif Is_Generic_Subprogram
(Spec_Id
) then
2705 Install_Generic_Formals
(Spec_Id
);
2708 Install_Formals
(Spec_Id
);
2712 Analyze_Global_List
(Items
);
2714 if Restore_Scope
then
2719 -- Ensure that a state and a corresponding constituent do not appear
2720 -- together in pragma [Refined_]Global.
2722 Check_State_And_Constituent_Use
2723 (States
=> States_Seen
,
2724 Constits
=> Constits_Seen
,
2727 Set_Is_Analyzed_Pragma
(N
);
2728 end Analyze_Global_In_Decl_Part
;
2730 --------------------------------------------
2731 -- Analyze_Initial_Condition_In_Decl_Part --
2732 --------------------------------------------
2734 -- WARNING: This routine manages Ghost regions. Return statements must be
2735 -- replaced by gotos which jump to the end of the routine and restore the
2738 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2739 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2740 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2741 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2743 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2744 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
2745 -- Save the Ghost-related attributes to restore on exit
2748 -- Do not analyze the pragma multiple times
2750 if Is_Analyzed_Pragma
(N
) then
2754 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2755 -- analysis of the pragma, the Ghost mode at point of declaration and
2756 -- point of analysis may not necessarily be the same. Use the mode in
2757 -- effect at the point of declaration.
2761 -- The expression is preanalyzed because it has not been moved to its
2762 -- final place yet. A direct analysis may generate side effects and this
2763 -- is not desired at this point.
2765 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2766 Set_Is_Analyzed_Pragma
(N
);
2768 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
2769 end Analyze_Initial_Condition_In_Decl_Part
;
2771 --------------------------------------
2772 -- Analyze_Initializes_In_Decl_Part --
2773 --------------------------------------
2775 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2776 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2777 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2779 Constits_Seen
: Elist_Id
:= No_Elist
;
2780 -- A list containing the entities of all constituents processed so far.
2781 -- It aids in detecting illegal usage of a state and a corresponding
2782 -- constituent in pragma Initializes.
2784 Items_Seen
: Elist_Id
:= No_Elist
;
2785 -- A list of all initialization items processed so far. This list is
2786 -- used to detect duplicate items.
2788 States_And_Objs
: Elist_Id
:= No_Elist
;
2789 -- A list of all abstract states and objects declared in the visible
2790 -- declarations of the related package. This list is used to detect the
2791 -- legality of initialization items.
2793 States_Seen
: Elist_Id
:= No_Elist
;
2794 -- A list containing the entities of all states processed so far. It
2795 -- helps in detecting illegal usage of a state and a corresponding
2796 -- constituent in pragma Initializes.
2798 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2799 -- Verify the legality of a single initialization item
2801 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2802 -- Verify the legality of a single initialization item followed by a
2803 -- list of input items.
2805 procedure Collect_States_And_Objects
;
2806 -- Inspect the visible declarations of the related package and gather
2807 -- the entities of all abstract states and objects in States_And_Objs.
2809 ---------------------------------
2810 -- Analyze_Initialization_Item --
2811 ---------------------------------
2813 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2814 Item_Id
: Entity_Id
;
2818 Resolve_State
(Item
);
2820 if Is_Entity_Name
(Item
) then
2821 Item_Id
:= Entity_Of
(Item
);
2823 if Present
(Item_Id
)
2824 and then Ekind_In
(Item_Id
, E_Abstract_State
,
2828 -- When the initialization item is undefined, it appears as
2829 -- Any_Id. Do not continue with the analysis of the item.
2831 if Item_Id
= Any_Id
then
2834 -- The state or variable must be declared in the visible
2835 -- declarations of the package (SPARK RM 7.1.5(7)).
2837 elsif not Contains
(States_And_Objs
, Item_Id
) then
2838 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2840 ("initialization item & must appear in the visible "
2841 & "declarations of package %", Item
, Item_Id
);
2843 -- Detect a duplicate use of the same initialization item
2844 -- (SPARK RM 7.1.5(5)).
2846 elsif Contains
(Items_Seen
, Item_Id
) then
2847 SPARK_Msg_N
("duplicate initialization item", Item
);
2849 -- The item is legal, add it to the list of processed states
2853 Append_New_Elmt
(Item_Id
, Items_Seen
);
2855 if Ekind
(Item_Id
) = E_Abstract_State
then
2856 Append_New_Elmt
(Item_Id
, States_Seen
);
2859 if Present
(Encapsulating_State
(Item_Id
)) then
2860 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2864 -- The item references something that is not a state or object
2865 -- (SPARK RM 7.1.5(3)).
2869 ("initialization item must denote object or state", Item
);
2872 -- Some form of illegal construct masquerading as a name
2873 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2877 ("initialization item must denote object or state", Item
);
2879 end Analyze_Initialization_Item
;
2881 ---------------------------------------------
2882 -- Analyze_Initialization_Item_With_Inputs --
2883 ---------------------------------------------
2885 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2886 Inputs_Seen
: Elist_Id
:= No_Elist
;
2887 -- A list of all inputs processed so far. This list is used to detect
2888 -- duplicate uses of an input.
2890 Non_Null_Seen
: Boolean := False;
2891 Null_Seen
: Boolean := False;
2892 -- Flags used to check the legality of an input list
2894 procedure Analyze_Input_Item
(Input
: Node_Id
);
2895 -- Verify the legality of a single input item
2897 ------------------------
2898 -- Analyze_Input_Item --
2899 ------------------------
2901 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2902 Input_Id
: Entity_Id
;
2907 if Nkind
(Input
) = N_Null
then
2910 ("multiple null initializations not allowed", Item
);
2912 elsif Non_Null_Seen
then
2914 ("cannot mix null and non-null initialization item", Item
);
2922 Non_Null_Seen
:= True;
2926 ("cannot mix null and non-null initialization item", Item
);
2930 Resolve_State
(Input
);
2932 if Is_Entity_Name
(Input
) then
2933 Input_Id
:= Entity_Of
(Input
);
2935 if Present
(Input_Id
)
2936 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2938 E_Generic_In_Out_Parameter
,
2939 E_Generic_In_Parameter
,
2947 -- The input cannot denote states or objects declared
2948 -- within the related package (SPARK RM 7.1.5(4)).
2950 if Within_Scope
(Input_Id
, Current_Scope
) then
2952 -- Do not consider generic formal parameters or their
2953 -- respective mappings to generic formals. Even though
2954 -- the formals appear within the scope of the package,
2955 -- it is allowed for an initialization item to depend
2956 -- on an input item.
2958 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2959 E_Generic_In_Parameter
)
2963 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2964 and then Present
(Corresponding_Generic_Association
2965 (Declaration_Node
(Input_Id
)))
2970 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2972 ("input item & cannot denote a visible object or "
2973 & "state of package %", Input
, Input_Id
);
2978 -- Detect a duplicate use of the same input item
2979 -- (SPARK RM 7.1.5(5)).
2981 if Contains
(Inputs_Seen
, Input_Id
) then
2982 SPARK_Msg_N
("duplicate input item", Input
);
2986 -- At this point it is known that the input is legal. Add
2987 -- it to the list of processed inputs.
2989 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2991 if Ekind
(Input_Id
) = E_Abstract_State
then
2992 Append_New_Elmt
(Input_Id
, States_Seen
);
2995 if Ekind_In
(Input_Id
, E_Abstract_State
,
2998 and then Present
(Encapsulating_State
(Input_Id
))
3000 Append_New_Elmt
(Input_Id
, Constits_Seen
);
3003 -- The input references something that is not a state or an
3004 -- object (SPARK RM 7.1.5(3)).
3008 ("input item must denote object or state", Input
);
3011 -- Some form of illegal construct masquerading as a name
3012 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3016 ("input item must denote object or state", Input
);
3019 end Analyze_Input_Item
;
3023 Inputs
: constant Node_Id
:= Expression
(Item
);
3027 Name_Seen
: Boolean := False;
3028 -- A flag used to detect multiple item names
3030 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3033 -- Inspect the name of an item with inputs
3035 Elmt
:= First
(Choices
(Item
));
3036 while Present
(Elmt
) loop
3038 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3041 Analyze_Initialization_Item
(Elmt
);
3047 -- Multiple input items appear as an aggregate
3049 if Nkind
(Inputs
) = N_Aggregate
then
3050 if Present
(Expressions
(Inputs
)) then
3051 Input
:= First
(Expressions
(Inputs
));
3052 while Present
(Input
) loop
3053 Analyze_Input_Item
(Input
);
3058 if Present
(Component_Associations
(Inputs
)) then
3060 ("inputs must appear in named association form", Inputs
);
3063 -- Single input item
3066 Analyze_Input_Item
(Inputs
);
3068 end Analyze_Initialization_Item_With_Inputs
;
3070 --------------------------------
3071 -- Collect_States_And_Objects --
3072 --------------------------------
3074 procedure Collect_States_And_Objects
is
3075 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3079 -- Collect the abstract states defined in the package (if any)
3081 if Present
(Abstract_States
(Pack_Id
)) then
3082 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3085 -- Collect all objects that appear in the visible declarations of the
3088 if Present
(Visible_Declarations
(Pack_Spec
)) then
3089 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3090 while Present
(Decl
) loop
3091 if Comes_From_Source
(Decl
)
3092 and then Nkind_In
(Decl
, N_Object_Declaration
,
3093 N_Object_Renaming_Declaration
)
3095 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3097 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3099 (Anonymous_Object
(Defining_Entity
(Decl
)),
3106 end Collect_States_And_Objects
;
3110 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3113 -- Start of processing for Analyze_Initializes_In_Decl_Part
3116 -- Do not analyze the pragma multiple times
3118 if Is_Analyzed_Pragma
(N
) then
3122 -- Nothing to do when the initialization list is empty
3124 if Nkind
(Inits
) = N_Null
then
3128 -- Single and multiple initialization clauses appear as an aggregate. If
3129 -- this is not the case, then either the parser or the analysis of the
3130 -- pragma failed to produce an aggregate.
3132 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3134 -- Initialize the various lists used during analysis
3136 Collect_States_And_Objects
;
3138 if Present
(Expressions
(Inits
)) then
3139 Init
:= First
(Expressions
(Inits
));
3140 while Present
(Init
) loop
3141 Analyze_Initialization_Item
(Init
);
3146 if Present
(Component_Associations
(Inits
)) then
3147 Init
:= First
(Component_Associations
(Inits
));
3148 while Present
(Init
) loop
3149 Analyze_Initialization_Item_With_Inputs
(Init
);
3154 -- Ensure that a state and a corresponding constituent do not appear
3155 -- together in pragma Initializes.
3157 Check_State_And_Constituent_Use
3158 (States
=> States_Seen
,
3159 Constits
=> Constits_Seen
,
3162 Set_Is_Analyzed_Pragma
(N
);
3163 end Analyze_Initializes_In_Decl_Part
;
3165 ---------------------
3166 -- Analyze_Part_Of --
3167 ---------------------
3169 procedure Analyze_Part_Of
3171 Item_Id
: Entity_Id
;
3173 Encap_Id
: out Entity_Id
;
3174 Legal
: out Boolean)
3176 procedure Check_Part_Of_Abstract_State
;
3177 pragma Inline
(Check_Part_Of_Abstract_State
);
3178 -- Verify the legality of indicator Part_Of when the encapsulator is an
3181 procedure Check_Part_Of_Concurrent_Type
;
3182 pragma Inline
(Check_Part_Of_Concurrent_Type
);
3183 -- Verify the legality of indicator Part_Of when the encapsulator is a
3184 -- single concurrent type.
3186 ----------------------------------
3187 -- Check_Part_Of_Abstract_State --
3188 ----------------------------------
3190 procedure Check_Part_Of_Abstract_State
is
3191 Pack_Id
: Entity_Id
;
3192 Placement
: State_Space_Kind
;
3193 Parent_Unit
: Entity_Id
;
3196 -- Determine where the object, package instantiation or state lives
3197 -- with respect to the enclosing packages or package bodies.
3199 Find_Placement_In_State_Space
3200 (Item_Id
=> Item_Id
,
3201 Placement
=> Placement
,
3202 Pack_Id
=> Pack_Id
);
3204 -- The item appears in a non-package construct with a declarative
3205 -- part (subprogram, block, etc). As such, the item is not allowed
3206 -- to be a part of an encapsulating state because the item is not
3209 if Placement
= Not_In_Package
then
3211 ("indicator Part_Of cannot appear in this context "
3212 & "(SPARK RM 7.2.6(5))", Indic
);
3214 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3216 ("\& is not part of the hidden state of package %",
3220 -- The item appears in the visible state space of some package. In
3221 -- general this scenario does not warrant Part_Of except when the
3222 -- package is a nongeneric private child unit and the encapsulating
3223 -- state is declared in a parent unit or a public descendant of that
3226 elsif Placement
= Visible_State_Space
then
3227 if Is_Child_Unit
(Pack_Id
)
3228 and then not Is_Generic_Unit
(Pack_Id
)
3229 and then Is_Private_Descendant
(Pack_Id
)
3231 -- A variable or state abstraction which is part of the visible
3232 -- state of a nongeneric private child unit or its public
3233 -- descendants must have its Part_Of indicator specified. The
3234 -- Part_Of indicator must denote a state declared by either the
3235 -- parent unit of the private unit or by a public descendant of
3236 -- that parent unit.
3238 -- Find the nearest private ancestor (which can be the current
3241 Parent_Unit
:= Pack_Id
;
3242 while Present
(Parent_Unit
) loop
3245 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3246 Parent_Unit
:= Scope
(Parent_Unit
);
3249 Parent_Unit
:= Scope
(Parent_Unit
);
3251 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3253 ("indicator Part_Of must denote abstract state of & or of "
3254 & "its public descendant (SPARK RM 7.2.6(3))",
3255 Indic
, Parent_Unit
);
3258 elsif Scope
(Encap_Id
) = Parent_Unit
3260 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3261 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3267 ("indicator Part_Of must denote abstract state of & or of "
3268 & "its public descendant (SPARK RM 7.2.6(3))",
3269 Indic
, Parent_Unit
);
3273 -- Indicator Part_Of is not needed when the related package is
3274 -- not a nongeneric private child unit or a public descendant
3279 ("indicator Part_Of cannot appear in this context "
3280 & "(SPARK RM 7.2.6(5))", Indic
);
3282 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3284 ("\& is declared in the visible part of package %",
3289 -- When the item appears in the private state space of a package, the
3290 -- encapsulating state must be declared in the same package.
3292 elsif Placement
= Private_State_Space
then
3293 if Scope
(Encap_Id
) /= Pack_Id
then
3295 ("indicator Part_Of must denote an abstract state of "
3296 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3298 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3300 ("\& is declared in the private part of package %",
3305 -- Items declared in the body state space of a package do not need
3306 -- Part_Of indicators as the refinement has already been seen.
3310 ("indicator Part_Of cannot appear in this context "
3311 & "(SPARK RM 7.2.6(5))", Indic
);
3313 if Scope
(Encap_Id
) = Pack_Id
then
3314 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3316 ("\& is declared in the body of package %", Indic
, Item_Id
);
3322 -- At this point it is known that the Part_Of indicator is legal
3325 end Check_Part_Of_Abstract_State
;
3327 -----------------------------------
3328 -- Check_Part_Of_Concurrent_Type --
3329 -----------------------------------
3331 procedure Check_Part_Of_Concurrent_Type
is
3332 function In_Proper_Order
3334 Second
: Node_Id
) return Boolean;
3335 pragma Inline
(In_Proper_Order
);
3336 -- Determine whether node First precedes node Second
3338 procedure Placement_Error
;
3339 pragma Inline
(Placement_Error
);
3340 -- Emit an error concerning the illegal placement of the item with
3341 -- respect to the single concurrent type.
3343 ---------------------
3344 -- In_Proper_Order --
3345 ---------------------
3347 function In_Proper_Order
3349 Second
: Node_Id
) return Boolean
3354 if List_Containing
(First
) = List_Containing
(Second
) then
3356 while Present
(N
) loop
3366 end In_Proper_Order
;
3368 ---------------------
3369 -- Placement_Error --
3370 ---------------------
3372 procedure Placement_Error
is
3375 ("indicator Part_Of must denote a previously declared single "
3376 & "protected type or single task type", Encap
);
3377 end Placement_Error
;
3381 Conc_Typ
: constant Entity_Id
:= Etype
(Encap_Id
);
3382 Encap_Decl
: constant Node_Id
:= Declaration_Node
(Encap_Id
);
3383 Encap_Context
: constant Node_Id
:= Parent
(Encap_Decl
);
3385 Item_Context
: Node_Id
;
3386 Item_Decl
: Node_Id
;
3387 Prv_Decls
: List_Id
;
3388 Vis_Decls
: List_Id
;
3390 -- Start of processing for Check_Part_Of_Concurrent_Type
3393 -- Only abstract states and variables can act as constituents of an
3394 -- encapsulating single concurrent type.
3396 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3399 -- The constituent is a constant
3401 elsif Ekind
(Item_Id
) = E_Constant
then
3402 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3404 (Fix_Msg
(Conc_Typ
, "constant & cannot act as constituent of "
3405 & "single protected type %"), Indic
, Item_Id
);
3408 -- The constituent is a package instantiation
3411 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3413 (Fix_Msg
(Conc_Typ
, "package instantiation & cannot act as "
3414 & "constituent of single protected type %"), Indic
, Item_Id
);
3418 -- When the item denotes an abstract state of a nested package, use
3419 -- the declaration of the package to detect proper placement.
3424 -- with Abstract_State => (State with Part_Of => T)
3426 if Ekind
(Item_Id
) = E_Abstract_State
then
3427 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3429 Item_Decl
:= Declaration_Node
(Item_Id
);
3432 Item_Context
:= Parent
(Item_Decl
);
3434 -- The item and the single concurrent type must appear in the same
3435 -- declarative region, with the item following the declaration of
3436 -- the single concurrent type (SPARK RM 9(3)).
3438 if Item_Context
= Encap_Context
then
3439 if Nkind_In
(Item_Context
, N_Package_Specification
,
3440 N_Protected_Definition
,
3443 Prv_Decls
:= Private_Declarations
(Item_Context
);
3444 Vis_Decls
:= Visible_Declarations
(Item_Context
);
3446 -- The placement is OK when the single concurrent type appears
3447 -- within the visible declarations and the item in the private
3453 -- Constit : ... with Part_Of => PO;
3456 if List_Containing
(Encap_Decl
) = Vis_Decls
3457 and then List_Containing
(Item_Decl
) = Prv_Decls
3461 -- The placement is illegal when the item appears within the
3462 -- visible declarations and the single concurrent type is in
3463 -- the private declarations.
3466 -- Constit : ... with Part_Of => PO;
3471 elsif List_Containing
(Item_Decl
) = Vis_Decls
3472 and then List_Containing
(Encap_Decl
) = Prv_Decls
3477 -- Otherwise both the item and the single concurrent type are
3478 -- in the same list. Ensure that the declaration of the single
3479 -- concurrent type precedes that of the item.
3481 elsif not In_Proper_Order
3482 (First
=> Encap_Decl
,
3483 Second
=> Item_Decl
)
3489 -- Otherwise both the item and the single concurrent type are
3490 -- in the same list. Ensure that the declaration of the single
3491 -- concurrent type precedes that of the item.
3493 elsif not In_Proper_Order
3494 (First
=> Encap_Decl
,
3495 Second
=> Item_Decl
)
3501 -- Otherwise the item and the single concurrent type reside within
3502 -- unrelated regions.
3505 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3507 (Fix_Msg
(Conc_Typ
, "constituent & must be declared "
3508 & "immediately within the same region as single protected "
3509 & "type %"), Indic
, Item_Id
);
3513 -- At this point it is known that the Part_Of indicator is legal
3516 end Check_Part_Of_Concurrent_Type
;
3518 -- Start of processing for Analyze_Part_Of
3521 -- Assume that the indicator is illegal
3526 if Nkind_In
(Encap
, N_Expanded_Name
,
3528 N_Selected_Component
)
3531 Resolve_State
(Encap
);
3533 Encap_Id
:= Entity
(Encap
);
3535 -- The encapsulator is an abstract state
3537 if Ekind
(Encap_Id
) = E_Abstract_State
then
3540 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3542 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3545 -- Otherwise the encapsulator is not a legal choice
3549 ("indicator Part_Of must denote abstract state, single "
3550 & "protected type or single task type", Encap
);
3554 -- This is a syntax error, always report
3558 ("indicator Part_Of must denote abstract state, single protected "
3559 & "type or single task type", Encap
);
3563 -- Catch a case where indicator Part_Of denotes the abstract view of a
3564 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3566 if From_Limited_With
(Encap_Id
)
3567 and then Present
(Non_Limited_View
(Encap_Id
))
3568 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3570 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3571 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3575 -- The encapsulator is an abstract state
3577 if Ekind
(Encap_Id
) = E_Abstract_State
then
3578 Check_Part_Of_Abstract_State
;
3580 -- The encapsulator is a single concurrent type
3583 Check_Part_Of_Concurrent_Type
;
3585 end Analyze_Part_Of
;
3587 ----------------------------------
3588 -- Analyze_Part_Of_In_Decl_Part --
3589 ----------------------------------
3591 procedure Analyze_Part_Of_In_Decl_Part
3593 Freeze_Id
: Entity_Id
:= Empty
)
3595 Encap
: constant Node_Id
:=
3596 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3597 Errors
: constant Nat
:= Serious_Errors_Detected
;
3598 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3599 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3600 Constits
: Elist_Id
;
3601 Encap_Id
: Entity_Id
;
3605 -- Detect any discrepancies between the placement of the variable with
3606 -- respect to general state space and the encapsulating state or single
3613 Encap_Id
=> Encap_Id
,
3616 -- The Part_Of indicator turns the variable into a constituent of the
3617 -- encapsulating state or single concurrent type.
3620 pragma Assert
(Present
(Encap_Id
));
3621 Constits
:= Part_Of_Constituents
(Encap_Id
);
3623 if No
(Constits
) then
3624 Constits
:= New_Elmt_List
;
3625 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3628 Append_Elmt
(Var_Id
, Constits
);
3629 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3631 -- A Part_Of constituent partially refines an abstract state. This
3632 -- property does not apply to protected or task units.
3634 if Ekind
(Encap_Id
) = E_Abstract_State
then
3635 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3639 -- Emit a clarification message when the encapsulator is undefined,
3640 -- possibly due to contract freezing.
3642 if Errors
/= Serious_Errors_Detected
3643 and then Present
(Freeze_Id
)
3644 and then Has_Undefined_Reference
(Encap
)
3646 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3648 end Analyze_Part_Of_In_Decl_Part
;
3650 --------------------
3651 -- Analyze_Pragma --
3652 --------------------
3654 procedure Analyze_Pragma
(N
: Node_Id
) is
3655 Loc
: constant Source_Ptr
:= Sloc
(N
);
3657 Pname
: Name_Id
:= Pragma_Name
(N
);
3658 -- Name of the source pragma, or name of the corresponding aspect for
3659 -- pragmas which originate in a source aspect. In the latter case, the
3660 -- name may be different from the pragma name.
3662 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3664 Pragma_Exit
: exception;
3665 -- This exception is used to exit pragma processing completely. It
3666 -- is used when an error is detected, and no further processing is
3667 -- required. It is also used if an earlier error has left the tree in
3668 -- a state where the pragma should not be processed.
3671 -- Number of pragma argument associations
3677 -- First four pragma arguments (pragma argument association nodes, or
3678 -- Empty if the corresponding argument does not exist).
3680 type Name_List
is array (Natural range <>) of Name_Id
;
3681 type Args_List
is array (Natural range <>) of Node_Id
;
3682 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3684 -----------------------
3685 -- Local Subprograms --
3686 -----------------------
3688 function Acc_First
(N
: Node_Id
) return Node_Id
;
3689 -- Helper function to iterate over arguments given to OpenAcc pragmas
3691 function Acc_Next
(N
: Node_Id
) return Node_Id
;
3692 -- Helper function to iterate over arguments given to OpenAcc pragmas
3694 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3695 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3696 -- get the given string argument, and place it in Name_Buffer, adding
3697 -- leading and trailing asterisks if they are not already present. The
3698 -- caller has already checked that Arg is a static string expression.
3700 procedure Ada_2005_Pragma
;
3701 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3702 -- Ada 95 mode, these are implementation defined pragmas, so should be
3703 -- caught by the No_Implementation_Pragmas restriction.
3705 procedure Ada_2012_Pragma
;
3706 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3707 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3708 -- should be caught by the No_Implementation_Pragmas restriction.
3710 procedure Analyze_Depends_Global
3711 (Spec_Id
: out Entity_Id
;
3712 Subp_Decl
: out Node_Id
;
3713 Legal
: out Boolean);
3714 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3715 -- legality of the placement and related context of the pragma. Spec_Id
3716 -- is the entity of the related subprogram. Subp_Decl is the declaration
3717 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3719 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3720 -- Inspect the remainder of the list containing pragma N and look for
3721 -- a pragma that matches Id. If found, analyze the pragma.
3723 procedure Analyze_Pre_Post_Condition
;
3724 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3726 procedure Analyze_Refined_Depends_Global_Post
3727 (Spec_Id
: out Entity_Id
;
3728 Body_Id
: out Entity_Id
;
3729 Legal
: out Boolean);
3730 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3731 -- Refined_Global and Refined_Post. Verify the legality of the placement
3732 -- and related context of the pragma. Spec_Id is the entity of the
3733 -- related subprogram. Body_Id is the entity of the subprogram body.
3734 -- Flag Legal is set when the pragma is legal.
3736 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3737 -- Perform full analysis of pragma Unmodified and the write aspect of
3738 -- pragma Unused. Flag Is_Unused should be set when verifying the
3739 -- semantics of pragma Unused.
3741 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3742 -- Perform full analysis of pragma Unreferenced and the read aspect of
3743 -- pragma Unused. Flag Is_Unused should be set when verifying the
3744 -- semantics of pragma Unused.
3746 procedure Check_Ada_83_Warning
;
3747 -- Issues a warning message for the current pragma if operating in Ada
3748 -- 83 mode (used for language pragmas that are not a standard part of
3749 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3752 procedure Check_Arg_Count
(Required
: Nat
);
3753 -- Check argument count for pragma is equal to given parameter. If not,
3754 -- then issue an error message and raise Pragma_Exit.
3756 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3757 -- Arg which can either be a pragma argument association, in which case
3758 -- the check is applied to the expression of the association or an
3759 -- expression directly.
3761 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3762 -- Check that an argument has the right form for an EXTERNAL_NAME
3763 -- parameter of an extended import/export pragma. The rule is that the
3764 -- name must be an identifier or string literal (in Ada 83 mode) or a
3765 -- static string expression (in Ada 95 mode).
3767 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3768 -- Check the specified argument Arg to make sure that it is an
3769 -- identifier. If not give error and raise Pragma_Exit.
3771 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3772 -- Check the specified argument Arg to make sure that it is an integer
3773 -- literal. If not give error and raise Pragma_Exit.
3775 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3776 -- Check the specified argument Arg to make sure that it has the proper
3777 -- syntactic form for a local name and meets the semantic requirements
3778 -- for a local name. The local name is analyzed as part of the
3779 -- processing for this call. In addition, the local name is required
3780 -- to represent an entity at the library level.
3782 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3783 -- Check the specified argument Arg to make sure that it has the proper
3784 -- syntactic form for a local name and meets the semantic requirements
3785 -- for a local name. The local name is analyzed as part of the
3786 -- processing for this call.
3788 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3789 -- Check the specified argument Arg to make sure that it is a valid
3790 -- locking policy name. If not give error and raise Pragma_Exit.
3792 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3793 -- Check the specified argument Arg to make sure that it is a valid
3794 -- elaboration policy name. If not give error and raise Pragma_Exit.
3796 procedure Check_Arg_Is_One_Of
3799 procedure Check_Arg_Is_One_Of
3801 N1
, N2
, N3
: Name_Id
);
3802 procedure Check_Arg_Is_One_Of
3804 N1
, N2
, N3
, N4
: Name_Id
);
3805 procedure Check_Arg_Is_One_Of
3807 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3808 -- Check the specified argument Arg to make sure that it is an
3809 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3810 -- present). If not then give error and raise Pragma_Exit.
3812 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3813 -- Check the specified argument Arg to make sure that it is a valid
3814 -- queuing policy name. If not give error and raise Pragma_Exit.
3816 procedure Check_Arg_Is_OK_Static_Expression
3818 Typ
: Entity_Id
:= Empty
);
3819 -- Check the specified argument Arg to make sure that it is a static
3820 -- expression of the given type (i.e. it will be analyzed and resolved
3821 -- using this type, which can be any valid argument to Resolve, e.g.
3822 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3823 -- Typ is left Empty, then any static expression is allowed. Includes
3824 -- checking that the argument does not raise Constraint_Error.
3826 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3827 -- Check the specified argument Arg to make sure that it is a valid task
3828 -- dispatching policy name. If not give error and raise Pragma_Exit.
3830 procedure Check_Arg_Order
(Names
: Name_List
);
3831 -- Checks for an instance of two arguments with identifiers for the
3832 -- current pragma which are not in the sequence indicated by Names,
3833 -- and if so, generates a fatal message about bad order of arguments.
3835 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3836 -- Check there are at least N arguments present
3838 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3839 -- Check there are no more than N arguments present
3841 procedure Check_Component
3844 In_Variant_Part
: Boolean := False);
3845 -- Examine an Unchecked_Union component for correct use of per-object
3846 -- constrained subtypes, and for restrictions on finalizable components.
3847 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3848 -- should be set when Comp comes from a record variant.
3850 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3851 -- Check if a rep item of the same name as the current pragma is already
3852 -- chained as a rep pragma to the given entity. If so give a message
3853 -- about the duplicate, and then raise Pragma_Exit so does not return.
3854 -- Note that if E is a type, then this routine avoids flagging a pragma
3855 -- which applies to a parent type from which E is derived.
3857 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3858 -- Nam is an N_String_Literal node containing the external name set by
3859 -- an Import or Export pragma (or extended Import or Export pragma).
3860 -- This procedure checks for possible duplications if this is the export
3861 -- case, and if found, issues an appropriate error message.
3863 procedure Check_Expr_Is_OK_Static_Expression
3865 Typ
: Entity_Id
:= Empty
);
3866 -- Check the specified expression Expr to make sure that it is a static
3867 -- expression of the given type (i.e. it will be analyzed and resolved
3868 -- using this type, which can be any valid argument to Resolve, e.g.
3869 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3870 -- Typ is left Empty, then any static expression is allowed. Includes
3871 -- checking that the expression does not raise Constraint_Error.
3873 procedure Check_First_Subtype
(Arg
: Node_Id
);
3874 -- Checks that Arg, whose expression is an entity name, references a
3877 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3878 -- Checks that the given argument has an identifier, and if so, requires
3879 -- it to match the given identifier name. If there is no identifier, or
3880 -- a non-matching identifier, then an error message is given and
3881 -- Pragma_Exit is raised.
3883 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3884 -- Checks that the given argument has an identifier, and if so, requires
3885 -- it to match one of the given identifier names. If there is no
3886 -- identifier, or a non-matching identifier, then an error message is
3887 -- given and Pragma_Exit is raised.
3889 procedure Check_In_Main_Program
;
3890 -- Common checks for pragmas that appear within a main program
3891 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3893 procedure Check_Interrupt_Or_Attach_Handler
;
3894 -- Common processing for first argument of pragma Interrupt_Handler or
3895 -- pragma Attach_Handler.
3897 procedure Check_Loop_Pragma_Placement
;
3898 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3899 -- appear immediately within a construct restricted to loops, and that
3900 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3902 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3903 -- Check that pragma appears in a declarative part, or in a package
3904 -- specification, i.e. that it does not occur in a statement sequence
3907 procedure Check_No_Identifier
(Arg
: Node_Id
);
3908 -- Checks that the given argument does not have an identifier. If
3909 -- an identifier is present, then an error message is issued, and
3910 -- Pragma_Exit is raised.
3912 procedure Check_No_Identifiers
;
3913 -- Checks that none of the arguments to the pragma has an identifier.
3914 -- If any argument has an identifier, then an error message is issued,
3915 -- and Pragma_Exit is raised.
3917 procedure Check_No_Link_Name
;
3918 -- Checks that no link name is specified
3920 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3921 -- Checks if the given argument has an identifier, and if so, requires
3922 -- it to match the given identifier name. If there is a non-matching
3923 -- identifier, then an error message is given and Pragma_Exit is raised.
3925 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3926 -- Checks if the given argument has an identifier, and if so, requires
3927 -- it to match the given identifier name. If there is a non-matching
3928 -- identifier, then an error message is given and Pragma_Exit is raised.
3929 -- In this version of the procedure, the identifier name is given as
3930 -- a string with lower case letters.
3932 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3933 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3934 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3935 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3936 -- is an OK static boolean expression. Emit an error if this is not the
3939 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3940 -- Constr is a constraint from an N_Subtype_Indication node from a
3941 -- component constraint in an Unchecked_Union type. This routine checks
3942 -- that the constraint is static as required by the restrictions for
3945 procedure Check_Valid_Configuration_Pragma
;
3946 -- Legality checks for placement of a configuration pragma
3948 procedure Check_Valid_Library_Unit_Pragma
;
3949 -- Legality checks for library unit pragmas. A special case arises for
3950 -- pragmas in generic instances that come from copies of the original
3951 -- library unit pragmas in the generic templates. In the case of other
3952 -- than library level instantiations these can appear in contexts which
3953 -- would normally be invalid (they only apply to the original template
3954 -- and to library level instantiations), and they are simply ignored,
3955 -- which is implemented by rewriting them as null statements.
3957 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3958 -- Check an Unchecked_Union variant for lack of nested variants and
3959 -- presence of at least one component. UU_Typ is the related Unchecked_
3962 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3963 -- Subsidiary routine to the processing of pragmas Abstract_State,
3964 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3965 -- Refined_Global and Refined_State. Transform argument Arg into
3966 -- an aggregate if not one already. N_Null is never transformed.
3967 -- Arg may denote an aspect specification or a pragma argument
3970 procedure Error_Pragma
(Msg
: String);
3971 pragma No_Return
(Error_Pragma
);
3972 -- Outputs error message for current pragma. The message contains a %
3973 -- that will be replaced with the pragma name, and the flag is placed
3974 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3975 -- calls Fix_Error (see spec of that procedure for details).
3977 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3978 pragma No_Return
(Error_Pragma_Arg
);
3979 -- Outputs error message for current pragma. The message may contain
3980 -- a % that will be replaced with the pragma name. The parameter Arg
3981 -- may either be a pragma argument association, in which case the flag
3982 -- is placed on the expression of this association, or an expression,
3983 -- in which case the flag is placed directly on the expression. The
3984 -- message is placed using Error_Msg_N, so the message may also contain
3985 -- an & insertion character which will reference the given Arg value.
3986 -- After placing the message, Pragma_Exit is raised. Note: this routine
3987 -- calls Fix_Error (see spec of that procedure for details).
3989 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3990 pragma No_Return
(Error_Pragma_Arg
);
3991 -- Similar to above form of Error_Pragma_Arg except that two messages
3992 -- are provided, the second is a continuation comment starting with \.
3994 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3995 pragma No_Return
(Error_Pragma_Arg_Ident
);
3996 -- Outputs error message for current pragma. The message may contain a %
3997 -- that will be replaced with the pragma name. The parameter Arg must be
3998 -- a pragma argument association with a non-empty identifier (i.e. its
3999 -- Chars field must be set), and the error message is placed on the
4000 -- identifier. The message is placed using Error_Msg_N so the message
4001 -- may also contain an & insertion character which will reference
4002 -- the identifier. After placing the message, Pragma_Exit is raised.
4003 -- Note: this routine calls Fix_Error (see spec of that procedure for
4006 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
4007 pragma No_Return
(Error_Pragma_Ref
);
4008 -- Outputs error message for current pragma. The message may contain
4009 -- a % that will be replaced with the pragma name. The parameter Ref
4010 -- must be an entity whose name can be referenced by & and sloc by #.
4011 -- After placing the message, Pragma_Exit is raised. Note: this routine
4012 -- calls Fix_Error (see spec of that procedure for details).
4014 function Find_Lib_Unit_Name
return Entity_Id
;
4015 -- Used for a library unit pragma to find the entity to which the
4016 -- library unit pragma applies, returns the entity found.
4018 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
4019 -- If the pragma is a compilation unit pragma, the id must denote the
4020 -- compilation unit in the same compilation, and the pragma must appear
4021 -- in the list of preceding or trailing pragmas. If it is a program
4022 -- unit pragma that is not a compilation unit pragma, then the
4023 -- identifier must be visible.
4025 function Find_Unique_Parameterless_Procedure
4027 Arg
: Node_Id
) return Entity_Id
;
4028 -- Used for a procedure pragma to find the unique parameterless
4029 -- procedure identified by Name, returns it if it exists, otherwise
4030 -- errors out and uses Arg as the pragma argument for the message.
4032 function Fix_Error
(Msg
: String) return String;
4033 -- This is called prior to issuing an error message. Msg is the normal
4034 -- error message issued in the pragma case. This routine checks for the
4035 -- case of a pragma coming from an aspect in the source, and returns a
4036 -- message suitable for the aspect case as follows:
4038 -- Each substring "pragma" is replaced by "aspect"
4040 -- If "argument of" is at the start of the error message text, it is
4041 -- replaced by "entity for".
4043 -- If "argument" is at the start of the error message text, it is
4044 -- replaced by "entity".
4046 -- So for example, "argument of pragma X must be discrete type"
4047 -- returns "entity for aspect X must be a discrete type".
4049 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
4050 -- be different from the pragma name). If the current pragma results
4051 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
4052 -- original pragma name.
4054 procedure Gather_Associations
4056 Args
: out Args_List
);
4057 -- This procedure is used to gather the arguments for a pragma that
4058 -- permits arbitrary ordering of parameters using the normal rules
4059 -- for named and positional parameters. The Names argument is a list
4060 -- of Name_Id values that corresponds to the allowed pragma argument
4061 -- association identifiers in order. The result returned in Args is
4062 -- a list of corresponding expressions that are the pragma arguments.
4063 -- Note that this is a list of expressions, not of pragma argument
4064 -- associations (Gather_Associations has completely checked all the
4065 -- optional identifiers when it returns). An entry in Args is Empty
4066 -- on return if the corresponding argument is not present.
4068 procedure GNAT_Pragma
;
4069 -- Called for all GNAT defined pragmas to check the relevant restriction
4070 -- (No_Implementation_Pragmas).
4072 function Is_Before_First_Decl
4073 (Pragma_Node
: Node_Id
;
4074 Decls
: List_Id
) return Boolean;
4075 -- Return True if Pragma_Node is before the first declarative item in
4076 -- Decls where Decls is the list of declarative items.
4078 function Is_Configuration_Pragma
return Boolean;
4079 -- Determines if the placement of the current pragma is appropriate
4080 -- for a configuration pragma.
4082 function Is_In_Context_Clause
return Boolean;
4083 -- Returns True if pragma appears within the context clause of a unit,
4084 -- and False for any other placement (does not generate any messages).
4086 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
4087 -- Analyzes the argument, and determines if it is a static string
4088 -- expression, returns True if so, False if non-static or not String.
4089 -- A special case is that a string literal returns True in Ada 83 mode
4090 -- (which has no such thing as static string expressions). Note that
4091 -- the call analyzes its argument, so this cannot be used for the case
4092 -- where an identifier might not be declared.
4094 procedure Pragma_Misplaced
;
4095 pragma No_Return
(Pragma_Misplaced
);
4096 -- Issue fatal error message for misplaced pragma
4098 procedure Process_Atomic_Independent_Shared_Volatile
;
4099 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
4100 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
4101 -- and treated as being identical in effect to pragma Atomic.
4103 procedure Process_Compile_Time_Warning_Or_Error
;
4104 -- Common processing for Compile_Time_Error and Compile_Time_Warning
4106 procedure Process_Convention
4107 (C
: out Convention_Id
;
4108 Ent
: out Entity_Id
);
4109 -- Common processing for Convention, Interface, Import and Export.
4110 -- Checks first two arguments of pragma, and sets the appropriate
4111 -- convention value in the specified entity or entities. On return
4112 -- C is the convention, Ent is the referenced entity.
4114 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
4115 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
4116 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
4118 procedure Process_Extended_Import_Export_Object_Pragma
4119 (Arg_Internal
: Node_Id
;
4120 Arg_External
: Node_Id
;
4121 Arg_Size
: Node_Id
);
4122 -- Common processing for the pragmas Import/Export_Object. The three
4123 -- arguments correspond to the three named parameters of the pragmas. An
4124 -- argument is empty if the corresponding parameter is not present in
4127 procedure Process_Extended_Import_Export_Internal_Arg
4128 (Arg_Internal
: Node_Id
:= Empty
);
4129 -- Common processing for all extended Import and Export pragmas. The
4130 -- argument is the pragma parameter for the Internal argument. If
4131 -- Arg_Internal is empty or inappropriate, an error message is posted.
4132 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4133 -- set to identify the referenced entity.
4135 procedure Process_Extended_Import_Export_Subprogram_Pragma
4136 (Arg_Internal
: Node_Id
;
4137 Arg_External
: Node_Id
;
4138 Arg_Parameter_Types
: Node_Id
;
4139 Arg_Result_Type
: Node_Id
:= Empty
;
4140 Arg_Mechanism
: Node_Id
;
4141 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4142 -- Common processing for all extended Import and Export pragmas applying
4143 -- to subprograms. The caller omits any arguments that do not apply to
4144 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4145 -- only in the Import_Function and Export_Function cases). The argument
4146 -- names correspond to the allowed pragma association identifiers.
4148 procedure Process_Generic_List
;
4149 -- Common processing for Share_Generic and Inline_Generic
4151 procedure Process_Import_Or_Interface
;
4152 -- Common processing for Import or Interface
4154 procedure Process_Import_Predefined_Type
;
4155 -- Processing for completing a type with pragma Import. This is used
4156 -- to declare types that match predefined C types, especially for cases
4157 -- without corresponding Ada predefined type.
4159 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4160 -- Inline status of a subprogram, indicated as follows:
4161 -- Suppressed: inlining is suppressed for the subprogram
4162 -- Disabled: no inlining is requested for the subprogram
4163 -- Enabled: inlining is requested/required for the subprogram
4165 procedure Process_Inline
(Status
: Inline_Status
);
4166 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4167 -- indicates the inline status specified by the pragma.
4169 procedure Process_Interface_Name
4170 (Subprogram_Def
: Entity_Id
;
4174 -- Given the last two arguments of pragma Import, pragma Export, or
4175 -- pragma Interface_Name, performs validity checks and sets the
4176 -- Interface_Name field of the given subprogram entity to the
4177 -- appropriate external or link name, depending on the arguments given.
4178 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4179 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4180 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4181 -- nor Link_Arg is present, the interface name is set to the default
4182 -- from the subprogram name. In addition, the pragma itself is passed
4183 -- to analyze any expressions in the case the pragma came from an aspect
4186 procedure Process_Interrupt_Or_Attach_Handler
;
4187 -- Common processing for Interrupt and Attach_Handler pragmas
4189 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4190 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4191 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4192 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4193 -- is not set in the Restrictions case.
4195 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4196 -- Common processing for Suppress and Unsuppress. The boolean parameter
4197 -- Suppress_Case is True for the Suppress case, and False for the
4200 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4201 -- Subsidiary to the analysis of pragmas Independent[_Components].
4202 -- Record such a pragma N applied to entity E for future checks.
4204 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4205 -- This procedure sets the Is_Exported flag for the given entity,
4206 -- checking that the entity was not previously imported. Arg is
4207 -- the argument that specified the entity. A check is also made
4208 -- for exporting inappropriate entities.
4210 procedure Set_Extended_Import_Export_External_Name
4211 (Internal_Ent
: Entity_Id
;
4212 Arg_External
: Node_Id
);
4213 -- Common processing for all extended import export pragmas. The first
4214 -- argument, Internal_Ent, is the internal entity, which has already
4215 -- been checked for validity by the caller. Arg_External is from the
4216 -- Import or Export pragma, and may be null if no External parameter
4217 -- was present. If Arg_External is present and is a non-null string
4218 -- (a null string is treated as the default), then the Interface_Name
4219 -- field of Internal_Ent is set appropriately.
4221 procedure Set_Imported
(E
: Entity_Id
);
4222 -- This procedure sets the Is_Imported flag for the given entity,
4223 -- checking that it is not previously exported or imported.
4225 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4226 -- Mech is a parameter passing mechanism (see Import_Function syntax
4227 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4228 -- has the right form, and if not issues an error message. If the
4229 -- argument has the right form then the Mechanism field of Ent is
4230 -- set appropriately.
4232 procedure Set_Rational_Profile
;
4233 -- Activate the set of configuration pragmas and permissions that make
4234 -- up the Rational profile.
4236 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4237 -- Activate the set of configuration pragmas and restrictions that make
4238 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4239 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4240 -- which is used for error messages on any constructs violating the
4243 procedure Validate_Acc_Condition_Clause
(Clause
: Node_Id
);
4244 -- Make sure the argument of a given Acc_If clause is a Boolean
4246 procedure Validate_Acc_Data_Clause
(Clause
: Node_Id
);
4247 -- Make sure the argument of an OpenAcc data clause (e.g. Copy, Copyin,
4248 -- Copyout...) is an identifier or an aggregate of identifiers.
4250 procedure Validate_Acc_Int_Expr_Clause
(Clause
: Node_Id
);
4251 -- Make sure the argument of an OpenAcc clause is an Integer expression
4253 procedure Validate_Acc_Int_Expr_List_Clause
(Clause
: Node_Id
);
4254 -- Make sure the argument of an OpenAcc clause is an Integer expression
4255 -- or a list of Integer expressions.
4257 procedure Validate_Acc_Loop_Collapse
(Clause
: Node_Id
);
4258 -- Make sure that the parent loop of the Acc_Loop(Collapse => N) pragma
4259 -- contains at least N-1 nested loops.
4261 procedure Validate_Acc_Loop_Gang
(Clause
: Node_Id
);
4262 -- Make sure the argument of the Gang clause of a Loop directive is
4263 -- either an integer expression or a (Static => integer expressions)
4266 procedure Validate_Acc_Loop_Vector
(Clause
: Node_Id
);
4267 -- When this procedure is called in a construct offloaded by an
4268 -- Acc_Kernels pragma, makes sure that a Vector_Length clause does
4269 -- not exist on said pragma. In all cases, make sure the argument
4270 -- is an Integer expression.
4272 procedure Validate_Acc_Loop_Worker
(Clause
: Node_Id
);
4273 -- When this procedure is called in a construct offloaded by an
4274 -- Acc_Parallel pragma, makes sure that no argument has been given.
4275 -- When this procedure is called in a construct offloaded by an
4276 -- Acc_Kernels pragma and if Loop_Worker was given an argument,
4277 -- makes sure that the Num_Workers clause does not appear on the
4278 -- Acc_Kernels pragma and that the argument is an integer.
4280 procedure Validate_Acc_Name_Reduction
(Clause
: Node_Id
);
4281 -- Make sure the reduction clause is an aggregate made of a string
4282 -- representing a supported reduction operation (i.e. "+", "*", "and",
4283 -- "or", "min" or "max") and either an identifier or aggregate of
4286 procedure Validate_Acc_Size_Expressions
(Clause
: Node_Id
);
4287 -- Makes sure that Clause is either an integer expression or an
4288 -- association with a Static as name and a list of integer expressions
4289 -- or "*" strings on the right hand side.
4295 function Acc_First
(N
: Node_Id
) return Node_Id
is
4297 if Nkind
(N
) = N_Aggregate
then
4298 if Present
(Expressions
(N
)) then
4299 return First
(Expressions
(N
));
4301 elsif Present
(Component_Associations
(N
)) then
4302 return Expression
(First
(Component_Associations
(N
)));
4313 function Acc_Next
(N
: Node_Id
) return Node_Id
is
4315 if Nkind
(Parent
(N
)) = N_Component_Association
then
4316 return Expression
(Next
(Parent
(N
)));
4318 elsif Nkind
(Parent
(N
)) = N_Aggregate
then
4326 ----------------------------------
4327 -- Acquire_Warning_Match_String --
4328 ----------------------------------
4330 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4332 String_To_Name_Buffer
4333 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4335 -- Add asterisk at start if not already there
4337 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4338 Name_Buffer
(2 .. Name_Len
+ 1) :=
4339 Name_Buffer
(1 .. Name_Len
);
4340 Name_Buffer
(1) := '*';
4341 Name_Len
:= Name_Len
+ 1;
4344 -- Add asterisk at end if not already there
4346 if Name_Buffer
(Name_Len
) /= '*' then
4347 Name_Len
:= Name_Len
+ 1;
4348 Name_Buffer
(Name_Len
) := '*';
4350 end Acquire_Warning_Match_String
;
4352 ---------------------
4353 -- Ada_2005_Pragma --
4354 ---------------------
4356 procedure Ada_2005_Pragma
is
4358 if Ada_Version
<= Ada_95
then
4359 Check_Restriction
(No_Implementation_Pragmas
, N
);
4361 end Ada_2005_Pragma
;
4363 ---------------------
4364 -- Ada_2012_Pragma --
4365 ---------------------
4367 procedure Ada_2012_Pragma
is
4369 if Ada_Version
<= Ada_2005
then
4370 Check_Restriction
(No_Implementation_Pragmas
, N
);
4372 end Ada_2012_Pragma
;
4374 ----------------------------
4375 -- Analyze_Depends_Global --
4376 ----------------------------
4378 procedure Analyze_Depends_Global
4379 (Spec_Id
: out Entity_Id
;
4380 Subp_Decl
: out Node_Id
;
4381 Legal
: out Boolean)
4384 -- Assume that the pragma is illegal
4391 Check_Arg_Count
(1);
4393 -- Ensure the proper placement of the pragma. Depends/Global must be
4394 -- associated with a subprogram declaration or a body that acts as a
4397 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4401 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4404 -- Generic subprogram
4406 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4409 -- Object declaration of a single concurrent type
4411 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4412 and then Is_Single_Concurrent_Object
4413 (Unique_Defining_Entity
(Subp_Decl
))
4419 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4422 -- Subprogram body acts as spec
4424 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4425 and then No
(Corresponding_Spec
(Subp_Decl
))
4429 -- Subprogram body stub acts as spec
4431 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4432 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4436 -- Subprogram declaration
4438 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4443 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4451 -- If we get here, then the pragma is legal
4454 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4456 -- When the related context is an entry, the entry must belong to a
4457 -- protected unit (SPARK RM 6.1.4(6)).
4459 if Is_Entry_Declaration
(Spec_Id
)
4460 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4465 -- When the related context is an anonymous object created for a
4466 -- simple concurrent type, the type must be a task
4467 -- (SPARK RM 6.1.4(6)).
4469 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4470 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4476 -- A pragma that applies to a Ghost entity becomes Ghost for the
4477 -- purposes of legality checks and removal of ignored Ghost code.
4479 Mark_Ghost_Pragma
(N
, Spec_Id
);
4480 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4481 end Analyze_Depends_Global
;
4483 ------------------------
4484 -- Analyze_If_Present --
4485 ------------------------
4487 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4491 pragma Assert
(Is_List_Member
(N
));
4493 -- Inspect the declarations or statements following pragma N looking
4494 -- for another pragma whose Id matches the caller's request. If it is
4495 -- available, analyze it.
4498 while Present
(Stmt
) loop
4499 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4500 Analyze_Pragma
(Stmt
);
4503 -- The first source declaration or statement immediately following
4504 -- N ends the region where a pragma may appear.
4506 elsif Comes_From_Source
(Stmt
) then
4512 end Analyze_If_Present
;
4514 --------------------------------
4515 -- Analyze_Pre_Post_Condition --
4516 --------------------------------
4518 procedure Analyze_Pre_Post_Condition
is
4519 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4520 Subp_Decl
: Node_Id
;
4521 Subp_Id
: Entity_Id
;
4523 Duplicates_OK
: Boolean := False;
4524 -- Flag set when a pre/postcondition allows multiple pragmas of the
4527 In_Body_OK
: Boolean := False;
4528 -- Flag set when a pre/postcondition is allowed to appear on a body
4529 -- even though the subprogram may have a spec.
4531 Is_Pre_Post
: Boolean := False;
4532 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4535 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4536 -- Implement rules in AI12-0131: an overriding operation can have
4537 -- a class-wide precondition only if one of its ancestors has an
4538 -- explicit class-wide precondition.
4540 -----------------------------
4541 -- Inherits_Class_Wide_Pre --
4542 -----------------------------
4544 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4545 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4548 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4551 -- Check ancestors on the overriding operation to examine the
4552 -- preconditions that may apply to them.
4554 while Present
(Prev
) loop
4555 Cont
:= Contract
(Prev
);
4556 if Present
(Cont
) then
4557 Prag
:= Pre_Post_Conditions
(Cont
);
4558 while Present
(Prag
) loop
4559 if Pragma_Name
(Prag
) = Name_Precondition
4560 and then Class_Present
(Prag
)
4565 Prag
:= Next_Pragma
(Prag
);
4569 -- For a type derived from a generic formal type, the operation
4570 -- inheriting the condition is a renaming, not an overriding of
4571 -- the operation of the formal. Ditto for an inherited
4572 -- operation which has no explicit contracts.
4574 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4575 or else not Comes_From_Source
(Prev
)
4577 Prev
:= Alias
(Prev
);
4579 Prev
:= Overridden_Operation
(Prev
);
4583 -- If the controlling type of the subprogram has progenitors, an
4584 -- interface operation implemented by the current operation may
4585 -- have a class-wide precondition.
4587 if Has_Interfaces
(Typ
) then
4592 Prim_Elmt
: Elmt_Id
;
4593 Prim_List
: Elist_Id
;
4596 Collect_Interfaces
(Typ
, Ints
);
4597 Elmt
:= First_Elmt
(Ints
);
4599 -- Iterate over the primitive operations of each interface
4601 while Present
(Elmt
) loop
4602 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4603 Prim_Elmt
:= First_Elmt
(Prim_List
);
4604 while Present
(Prim_Elmt
) loop
4605 Prim
:= Node
(Prim_Elmt
);
4606 if Chars
(Prim
) = Chars
(E
)
4607 and then Present
(Contract
(Prim
))
4608 and then Class_Present
4609 (Pre_Post_Conditions
(Contract
(Prim
)))
4614 Next_Elmt
(Prim_Elmt
);
4623 end Inherits_Class_Wide_Pre
;
4625 -- Start of processing for Analyze_Pre_Post_Condition
4628 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4629 -- offer uniformity among the various kinds of pre/postconditions by
4630 -- rewriting the pragma identifier. This allows the retrieval of the
4631 -- original pragma name by routine Original_Aspect_Pragma_Name.
4633 if Comes_From_Source
(N
) then
4634 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4635 Is_Pre_Post
:= True;
4636 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4637 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4639 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4640 Is_Pre_Post
:= True;
4641 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4642 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4646 -- Determine the semantics with respect to duplicates and placement
4647 -- in a body. Pragmas Precondition and Postcondition were introduced
4648 -- before aspects and are not subject to the same aspect-like rules.
4650 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4651 Duplicates_OK
:= True;
4657 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4658 -- argument without an identifier.
4661 Check_Arg_Count
(1);
4662 Check_No_Identifiers
;
4664 -- Pragmas Precondition and Postcondition have complex argument
4668 Check_At_Least_N_Arguments
(1);
4669 Check_At_Most_N_Arguments
(2);
4670 Check_Optional_Identifier
(Arg1
, Name_Check
);
4672 if Present
(Arg2
) then
4673 Check_Optional_Identifier
(Arg2
, Name_Message
);
4674 Preanalyze_Spec_Expression
4675 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4679 -- For a pragma PPC in the extended main source unit, record enabled
4681 -- ??? nothing checks that the pragma is in the main source unit
4683 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4684 Set_SCO_Pragma_Enabled
(Loc
);
4687 -- Ensure the proper placement of the pragma
4690 Find_Related_Declaration_Or_Body
4691 (N
, Do_Checks
=> not Duplicates_OK
);
4693 -- When a pre/postcondition pragma applies to an abstract subprogram,
4694 -- its original form must be an aspect with 'Class.
4696 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4697 if not From_Aspect_Specification
(N
) then
4699 ("pragma % cannot be applied to abstract subprogram");
4701 elsif not Class_Present
(N
) then
4703 ("aspect % requires ''Class for abstract subprogram");
4706 -- Entry declaration
4708 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4711 -- Generic subprogram declaration
4713 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4718 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4719 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4723 -- Subprogram body stub
4725 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4726 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4730 -- Subprogram declaration
4732 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4734 -- AI05-0230: When a pre/postcondition pragma applies to a null
4735 -- procedure, its original form must be an aspect with 'Class.
4737 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4738 and then Null_Present
(Specification
(Subp_Decl
))
4739 and then From_Aspect_Specification
(N
)
4740 and then not Class_Present
(N
)
4742 Error_Pragma
("aspect % requires ''Class for null procedure");
4745 -- Implement the legality checks mandated by AI12-0131:
4746 -- Pre'Class shall not be specified for an overriding primitive
4747 -- subprogram of a tagged type T unless the Pre'Class aspect is
4748 -- specified for the corresponding primitive subprogram of some
4752 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4755 if Class_Present
(N
)
4756 and then Pragma_Name
(N
) = Name_Precondition
4757 and then Present
(Overridden_Operation
(E
))
4758 and then not Inherits_Class_Wide_Pre
(E
)
4761 ("illegal class-wide precondition on overriding operation",
4762 Corresponding_Aspect
(N
));
4766 -- A renaming declaration may inherit a generated pragma, its
4767 -- placement comes from expansion, not from source.
4769 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4770 and then not Comes_From_Source
(N
)
4774 -- Otherwise the placement is illegal
4781 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4783 -- A pragma that applies to a Ghost entity becomes Ghost for the
4784 -- purposes of legality checks and removal of ignored Ghost code.
4786 Mark_Ghost_Pragma
(N
, Subp_Id
);
4788 -- Chain the pragma on the contract for further processing by
4789 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4791 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4793 -- Fully analyze the pragma when it appears inside an entry or
4794 -- subprogram body because it cannot benefit from forward references.
4796 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4798 N_Subprogram_Body_Stub
)
4800 -- The legality checks of pragmas Precondition and Postcondition
4801 -- are affected by the SPARK mode in effect and the volatility of
4802 -- the context. Analyze all pragmas in a specific order.
4804 Analyze_If_Present
(Pragma_SPARK_Mode
);
4805 Analyze_If_Present
(Pragma_Volatile_Function
);
4806 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4808 end Analyze_Pre_Post_Condition
;
4810 -----------------------------------------
4811 -- Analyze_Refined_Depends_Global_Post --
4812 -----------------------------------------
4814 procedure Analyze_Refined_Depends_Global_Post
4815 (Spec_Id
: out Entity_Id
;
4816 Body_Id
: out Entity_Id
;
4817 Legal
: out Boolean)
4819 Body_Decl
: Node_Id
;
4820 Spec_Decl
: Node_Id
;
4823 -- Assume that the pragma is illegal
4830 Check_Arg_Count
(1);
4831 Check_No_Identifiers
;
4833 -- Verify the placement of the pragma and check for duplicates. The
4834 -- pragma must apply to a subprogram body [stub].
4836 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4838 if not Nkind_In
(Body_Decl
, N_Entry_Body
,
4840 N_Subprogram_Body_Stub
,
4848 Body_Id
:= Defining_Entity
(Body_Decl
);
4849 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4851 -- The pragma must apply to the second declaration of a subprogram.
4852 -- In other words, the body [stub] cannot acts as a spec.
4854 if No
(Spec_Id
) then
4855 Error_Pragma
("pragma % cannot apply to a stand alone body");
4858 -- Catch the case where the subprogram body is a subunit and acts as
4859 -- the third declaration of the subprogram.
4861 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4862 Error_Pragma
("pragma % cannot apply to a subunit");
4866 -- A refined pragma can only apply to the body [stub] of a subprogram
4867 -- declared in the visible part of a package. Retrieve the context of
4868 -- the subprogram declaration.
4870 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4872 -- When dealing with protected entries or protected subprograms, use
4873 -- the enclosing protected type as the proper context.
4875 if Ekind_In
(Spec_Id
, E_Entry
,
4879 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4881 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4884 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4886 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4887 & "subprogram declared in a package specification"));
4891 -- If we get here, then the pragma is legal
4895 -- A pragma that applies to a Ghost entity becomes Ghost for the
4896 -- purposes of legality checks and removal of ignored Ghost code.
4898 Mark_Ghost_Pragma
(N
, Spec_Id
);
4900 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4901 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4903 end Analyze_Refined_Depends_Global_Post
;
4905 ----------------------------------
4906 -- Analyze_Unmodified_Or_Unused --
4907 ----------------------------------
4909 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4914 Ghost_Error_Posted
: Boolean := False;
4915 -- Flag set when an error concerning the illegal mix of Ghost and
4916 -- non-Ghost variables is emitted.
4918 Ghost_Id
: Entity_Id
:= Empty
;
4919 -- The entity of the first Ghost variable encountered while
4920 -- processing the arguments of the pragma.
4924 Check_At_Least_N_Arguments
(1);
4926 -- Loop through arguments
4929 while Present
(Arg
) loop
4930 Check_No_Identifier
(Arg
);
4932 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4933 -- in fact generate reference, so that the entity will have a
4934 -- reference, which will inhibit any warnings about it not
4935 -- being referenced, and also properly show up in the ali file
4936 -- as a reference. But this reference is recorded before the
4937 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4938 -- generated for this reference.
4940 Check_Arg_Is_Local_Name
(Arg
);
4941 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4943 if Is_Entity_Name
(Arg_Expr
) then
4944 Arg_Id
:= Entity
(Arg_Expr
);
4946 -- Skip processing the argument if already flagged
4948 if Is_Assignable
(Arg_Id
)
4949 and then not Has_Pragma_Unmodified
(Arg_Id
)
4950 and then not Has_Pragma_Unused
(Arg_Id
)
4952 Set_Has_Pragma_Unmodified
(Arg_Id
);
4955 Set_Has_Pragma_Unused
(Arg_Id
);
4958 -- A pragma that applies to a Ghost entity becomes Ghost for
4959 -- the purposes of legality checks and removal of ignored
4962 Mark_Ghost_Pragma
(N
, Arg_Id
);
4964 -- Capture the entity of the first Ghost variable being
4965 -- processed for error detection purposes.
4967 if Is_Ghost_Entity
(Arg_Id
) then
4968 if No
(Ghost_Id
) then
4972 -- Otherwise the variable is non-Ghost. It is illegal to mix
4973 -- references to Ghost and non-Ghost entities
4976 elsif Present
(Ghost_Id
)
4977 and then not Ghost_Error_Posted
4979 Ghost_Error_Posted
:= True;
4981 Error_Msg_Name_1
:= Pname
;
4983 ("pragma % cannot mention ghost and non-ghost "
4986 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4987 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4989 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4990 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4993 -- Warn if already flagged as Unused or Unmodified
4995 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4996 if Has_Pragma_Unused
(Arg_Id
) then
4998 ("??pragma Unused already given for &!", Arg_Expr
,
5002 ("??pragma Unmodified already given for &!", Arg_Expr
,
5006 -- Otherwise the pragma referenced an illegal entity
5010 ("pragma% can only be applied to a variable", Arg_Expr
);
5016 end Analyze_Unmodified_Or_Unused
;
5018 ------------------------------------
5019 -- Analyze_Unreferenced_Or_Unused --
5020 ------------------------------------
5022 procedure Analyze_Unreferenced_Or_Unused
5023 (Is_Unused
: Boolean := False)
5030 Ghost_Error_Posted
: Boolean := False;
5031 -- Flag set when an error concerning the illegal mix of Ghost and
5032 -- non-Ghost names is emitted.
5034 Ghost_Id
: Entity_Id
:= Empty
;
5035 -- The entity of the first Ghost name encountered while processing
5036 -- the arguments of the pragma.
5040 Check_At_Least_N_Arguments
(1);
5042 -- Check case of appearing within context clause
5044 if not Is_Unused
and then Is_In_Context_Clause
then
5046 -- The arguments must all be units mentioned in a with clause in
5047 -- the same context clause. Note that Par.Prag already checked
5048 -- that the arguments are either identifiers or selected
5052 while Present
(Arg
) loop
5053 Citem
:= First
(List_Containing
(N
));
5054 while Citem
/= N
loop
5055 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5057 if Nkind
(Citem
) = N_With_Clause
5058 and then Same_Name
(Name
(Citem
), Arg_Expr
)
5060 Set_Has_Pragma_Unreferenced
5063 (Library_Unit
(Citem
))));
5064 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
5073 ("argument of pragma% is not withed unit", Arg
);
5079 -- Case of not in list of context items
5083 while Present
(Arg
) loop
5084 Check_No_Identifier
(Arg
);
5086 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
5087 -- in fact generate reference, so that the entity will have a
5088 -- reference, which will inhibit any warnings about it not
5089 -- being referenced, and also properly show up in the ali file
5090 -- as a reference. But this reference is recorded before the
5091 -- Has_Pragma_Unreferenced flag is set, so that no warning is
5092 -- generated for this reference.
5094 Check_Arg_Is_Local_Name
(Arg
);
5095 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
5097 if Is_Entity_Name
(Arg_Expr
) then
5098 Arg_Id
:= Entity
(Arg_Expr
);
5100 -- Warn if already flagged as Unused or Unreferenced and
5101 -- skip processing the argument.
5103 if Has_Pragma_Unreferenced
(Arg_Id
) then
5104 if Has_Pragma_Unused
(Arg_Id
) then
5106 ("??pragma Unused already given for &!", Arg_Expr
,
5110 ("??pragma Unreferenced already given for &!",
5114 -- Apply Unreferenced to the entity
5117 -- If the entity is overloaded, the pragma applies to the
5118 -- most recent overloading, as documented. In this case,
5119 -- name resolution does not generate a reference, so it
5120 -- must be done here explicitly.
5122 if Is_Overloaded
(Arg_Expr
) then
5123 Generate_Reference
(Arg_Id
, N
);
5126 Set_Has_Pragma_Unreferenced
(Arg_Id
);
5129 Set_Has_Pragma_Unused
(Arg_Id
);
5132 -- A pragma that applies to a Ghost entity becomes Ghost
5133 -- for the purposes of legality checks and removal of
5134 -- ignored Ghost code.
5136 Mark_Ghost_Pragma
(N
, Arg_Id
);
5138 -- Capture the entity of the first Ghost name being
5139 -- processed for error detection purposes.
5141 if Is_Ghost_Entity
(Arg_Id
) then
5142 if No
(Ghost_Id
) then
5146 -- Otherwise the name is non-Ghost. It is illegal to mix
5147 -- references to Ghost and non-Ghost entities
5150 elsif Present
(Ghost_Id
)
5151 and then not Ghost_Error_Posted
5153 Ghost_Error_Posted
:= True;
5155 Error_Msg_Name_1
:= Pname
;
5157 ("pragma % cannot mention ghost and non-ghost "
5160 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
5162 ("\& # declared as ghost", N
, Ghost_Id
);
5164 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
5166 ("\& # declared as non-ghost", N
, Arg_Id
);
5174 end Analyze_Unreferenced_Or_Unused
;
5176 --------------------------
5177 -- Check_Ada_83_Warning --
5178 --------------------------
5180 procedure Check_Ada_83_Warning
is
5182 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
5183 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
5185 end Check_Ada_83_Warning
;
5187 ---------------------
5188 -- Check_Arg_Count --
5189 ---------------------
5191 procedure Check_Arg_Count
(Required
: Nat
) is
5193 if Arg_Count
/= Required
then
5194 Error_Pragma
("wrong number of arguments for pragma%");
5196 end Check_Arg_Count
;
5198 --------------------------------
5199 -- Check_Arg_Is_External_Name --
5200 --------------------------------
5202 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5203 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5206 if Nkind
(Argx
) = N_Identifier
then
5210 Analyze_And_Resolve
(Argx
, Standard_String
);
5212 if Is_OK_Static_Expression
(Argx
) then
5215 elsif Etype
(Argx
) = Any_Type
then
5218 -- An interesting special case, if we have a string literal and
5219 -- we are in Ada 83 mode, then we allow it even though it will
5220 -- not be flagged as static. This allows expected Ada 83 mode
5221 -- use of external names which are string literals, even though
5222 -- technically these are not static in Ada 83.
5224 elsif Ada_Version
= Ada_83
5225 and then Nkind
(Argx
) = N_String_Literal
5229 -- Here we have a real error (non-static expression)
5232 Error_Msg_Name_1
:= Pname
;
5233 Flag_Non_Static_Expr
5234 (Fix_Error
("argument for pragma% must be a identifier or "
5235 & "static string expression!"), Argx
);
5240 end Check_Arg_Is_External_Name
;
5242 -----------------------------
5243 -- Check_Arg_Is_Identifier --
5244 -----------------------------
5246 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5247 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5249 if Nkind
(Argx
) /= N_Identifier
then
5250 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5252 end Check_Arg_Is_Identifier
;
5254 ----------------------------------
5255 -- Check_Arg_Is_Integer_Literal --
5256 ----------------------------------
5258 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5259 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5261 if Nkind
(Argx
) /= N_Integer_Literal
then
5263 ("argument for pragma% must be integer literal", Argx
);
5265 end Check_Arg_Is_Integer_Literal
;
5267 -------------------------------------------
5268 -- Check_Arg_Is_Library_Level_Local_Name --
5269 -------------------------------------------
5273 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5274 -- | library_unit_NAME
5276 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5278 Check_Arg_Is_Local_Name
(Arg
);
5280 -- If it came from an aspect, we want to give the error just as if it
5281 -- came from source.
5283 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5284 and then (Comes_From_Source
(N
)
5285 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5288 ("argument for pragma% must be library level entity", Arg
);
5290 end Check_Arg_Is_Library_Level_Local_Name
;
5292 -----------------------------
5293 -- Check_Arg_Is_Local_Name --
5294 -----------------------------
5298 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5299 -- | library_unit_NAME
5301 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5302 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5305 -- If this pragma came from an aspect specification, we don't want to
5306 -- check for this error, because that would cause spurious errors, in
5307 -- case a type is frozen in a scope more nested than the type. The
5308 -- aspect itself of course can't be anywhere but on the declaration
5311 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5312 if From_Aspect_Specification
(Parent
(Arg
)) then
5316 -- Arg is the Expression of an N_Pragma_Argument_Association
5319 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5326 if Nkind
(Argx
) not in N_Direct_Name
5327 and then (Nkind
(Argx
) /= N_Attribute_Reference
5328 or else Present
(Expressions
(Argx
))
5329 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5330 and then (not Is_Entity_Name
(Argx
)
5331 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5333 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5336 -- No further check required if not an entity name
5338 if not Is_Entity_Name
(Argx
) then
5344 Ent
: constant Entity_Id
:= Entity
(Argx
);
5345 Scop
: constant Entity_Id
:= Scope
(Ent
);
5348 -- Case of a pragma applied to a compilation unit: pragma must
5349 -- occur immediately after the program unit in the compilation.
5351 if Is_Compilation_Unit
(Ent
) then
5353 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5356 -- Case of pragma placed immediately after spec
5358 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5361 -- Case of pragma placed immediately after body
5363 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5364 and then Present
(Corresponding_Body
(Decl
))
5368 (Parent
(Unit_Declaration_Node
5369 (Corresponding_Body
(Decl
))));
5371 -- All other cases are illegal
5378 -- Special restricted placement rule from 10.2.1(11.8/2)
5380 elsif Is_Generic_Formal
(Ent
)
5381 and then Prag_Id
= Pragma_Preelaborable_Initialization
5383 OK
:= List_Containing
(N
) =
5384 Generic_Formal_Declarations
5385 (Unit_Declaration_Node
(Scop
));
5387 -- If this is an aspect applied to a subprogram body, the
5388 -- pragma is inserted in its declarative part.
5390 elsif From_Aspect_Specification
(N
)
5391 and then Ent
= Current_Scope
5393 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5397 -- If the aspect is a predicate (possibly others ???) and the
5398 -- context is a record type, this is a discriminant expression
5399 -- within a type declaration, that freezes the predicated
5402 elsif From_Aspect_Specification
(N
)
5403 and then Prag_Id
= Pragma_Predicate
5404 and then Ekind
(Current_Scope
) = E_Record_Type
5405 and then Scop
= Scope
(Current_Scope
)
5409 -- Default case, just check that the pragma occurs in the scope
5410 -- of the entity denoted by the name.
5413 OK
:= Current_Scope
= Scop
;
5418 ("pragma% argument must be in same declarative part", Arg
);
5422 end Check_Arg_Is_Local_Name
;
5424 ---------------------------------
5425 -- Check_Arg_Is_Locking_Policy --
5426 ---------------------------------
5428 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5429 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5432 Check_Arg_Is_Identifier
(Argx
);
5434 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5435 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5437 end Check_Arg_Is_Locking_Policy
;
5439 -----------------------------------------------
5440 -- Check_Arg_Is_Partition_Elaboration_Policy --
5441 -----------------------------------------------
5443 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5444 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5447 Check_Arg_Is_Identifier
(Argx
);
5449 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5451 ("& is not a valid partition elaboration policy name", Argx
);
5453 end Check_Arg_Is_Partition_Elaboration_Policy
;
5455 -------------------------
5456 -- Check_Arg_Is_One_Of --
5457 -------------------------
5459 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5460 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5463 Check_Arg_Is_Identifier
(Argx
);
5465 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5466 Error_Msg_Name_2
:= N1
;
5467 Error_Msg_Name_3
:= N2
;
5468 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5470 end Check_Arg_Is_One_Of
;
5472 procedure Check_Arg_Is_One_Of
5474 N1
, N2
, N3
: Name_Id
)
5476 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5479 Check_Arg_Is_Identifier
(Argx
);
5481 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5482 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5484 end Check_Arg_Is_One_Of
;
5486 procedure Check_Arg_Is_One_Of
5488 N1
, N2
, N3
, N4
: Name_Id
)
5490 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5493 Check_Arg_Is_Identifier
(Argx
);
5495 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5496 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5498 end Check_Arg_Is_One_Of
;
5500 procedure Check_Arg_Is_One_Of
5502 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5504 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5507 Check_Arg_Is_Identifier
(Argx
);
5509 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5510 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5512 end Check_Arg_Is_One_Of
;
5514 ---------------------------------
5515 -- Check_Arg_Is_Queuing_Policy --
5516 ---------------------------------
5518 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5519 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5522 Check_Arg_Is_Identifier
(Argx
);
5524 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5525 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5527 end Check_Arg_Is_Queuing_Policy
;
5529 ---------------------------------------
5530 -- Check_Arg_Is_OK_Static_Expression --
5531 ---------------------------------------
5533 procedure Check_Arg_Is_OK_Static_Expression
5535 Typ
: Entity_Id
:= Empty
)
5538 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5539 end Check_Arg_Is_OK_Static_Expression
;
5541 ------------------------------------------
5542 -- Check_Arg_Is_Task_Dispatching_Policy --
5543 ------------------------------------------
5545 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5546 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5549 Check_Arg_Is_Identifier
(Argx
);
5551 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5553 ("& is not an allowed task dispatching policy name", Argx
);
5555 end Check_Arg_Is_Task_Dispatching_Policy
;
5557 ---------------------
5558 -- Check_Arg_Order --
5559 ---------------------
5561 procedure Check_Arg_Order
(Names
: Name_List
) is
5564 Highest_So_Far
: Natural := 0;
5565 -- Highest index in Names seen do far
5569 for J
in 1 .. Arg_Count
loop
5570 if Chars
(Arg
) /= No_Name
then
5571 for K
in Names
'Range loop
5572 if Chars
(Arg
) = Names
(K
) then
5573 if K
< Highest_So_Far
then
5574 Error_Msg_Name_1
:= Pname
;
5576 ("parameters out of order for pragma%", Arg
);
5577 Error_Msg_Name_1
:= Names
(K
);
5578 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5579 Error_Msg_N
("\% must appear before %", Arg
);
5583 Highest_So_Far
:= K
;
5591 end Check_Arg_Order
;
5593 --------------------------------
5594 -- Check_At_Least_N_Arguments --
5595 --------------------------------
5597 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5599 if Arg_Count
< N
then
5600 Error_Pragma
("too few arguments for pragma%");
5602 end Check_At_Least_N_Arguments
;
5604 -------------------------------
5605 -- Check_At_Most_N_Arguments --
5606 -------------------------------
5608 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5611 if Arg_Count
> N
then
5613 for J
in 1 .. N
loop
5615 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5618 end Check_At_Most_N_Arguments
;
5620 ---------------------
5621 -- Check_Component --
5622 ---------------------
5624 procedure Check_Component
5627 In_Variant_Part
: Boolean := False)
5629 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5630 Sindic
: constant Node_Id
:=
5631 Subtype_Indication
(Component_Definition
(Comp
));
5632 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5635 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5636 -- object constraint, then the component type shall be an Unchecked_
5639 if Nkind
(Sindic
) = N_Subtype_Indication
5640 and then Has_Per_Object_Constraint
(Comp_Id
)
5641 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5644 ("component subtype subject to per-object constraint "
5645 & "must be an Unchecked_Union", Comp
);
5647 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5648 -- the body of a generic unit, or within the body of any of its
5649 -- descendant library units, no part of the type of a component
5650 -- declared in a variant_part of the unchecked union type shall be of
5651 -- a formal private type or formal private extension declared within
5652 -- the formal part of the generic unit.
5654 elsif Ada_Version
>= Ada_2012
5655 and then In_Generic_Body
(UU_Typ
)
5656 and then In_Variant_Part
5657 and then Is_Private_Type
(Typ
)
5658 and then Is_Generic_Type
(Typ
)
5661 ("component of unchecked union cannot be of generic type", Comp
);
5663 elsif Needs_Finalization
(Typ
) then
5665 ("component of unchecked union cannot be controlled", Comp
);
5667 elsif Has_Task
(Typ
) then
5669 ("component of unchecked union cannot have tasks", Comp
);
5671 end Check_Component
;
5673 ----------------------------
5674 -- Check_Duplicate_Pragma --
5675 ----------------------------
5677 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5678 Id
: Entity_Id
:= E
;
5682 -- Nothing to do if this pragma comes from an aspect specification,
5683 -- since we could not be duplicating a pragma, and we dealt with the
5684 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5686 if From_Aspect_Specification
(N
) then
5690 -- Otherwise current pragma may duplicate previous pragma or a
5691 -- previously given aspect specification or attribute definition
5692 -- clause for the same pragma.
5694 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5698 -- If the entity is a type, then we have to make sure that the
5699 -- ostensible duplicate is not for a parent type from which this
5703 if Nkind
(P
) = N_Pragma
then
5705 Args
: constant List_Id
:=
5706 Pragma_Argument_Associations
(P
);
5709 and then Is_Entity_Name
(Expression
(First
(Args
)))
5710 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5711 and then Entity
(Expression
(First
(Args
))) /= E
5717 elsif Nkind
(P
) = N_Aspect_Specification
5718 and then Is_Type
(Entity
(P
))
5719 and then Entity
(P
) /= E
5725 -- Here we have a definite duplicate
5727 Error_Msg_Name_1
:= Pragma_Name
(N
);
5728 Error_Msg_Sloc
:= Sloc
(P
);
5730 -- For a single protected or a single task object, the error is
5731 -- issued on the original entity.
5733 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5734 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5737 if Nkind
(P
) = N_Aspect_Specification
5738 or else From_Aspect_Specification
(P
)
5740 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5742 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5747 end Check_Duplicate_Pragma
;
5749 ----------------------------------
5750 -- Check_Duplicated_Export_Name --
5751 ----------------------------------
5753 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5754 String_Val
: constant String_Id
:= Strval
(Nam
);
5757 -- We are only interested in the export case, and in the case of
5758 -- generics, it is the instance, not the template, that is the
5759 -- problem (the template will generate a warning in any case).
5761 if not Inside_A_Generic
5762 and then (Prag_Id
= Pragma_Export
5764 Prag_Id
= Pragma_Export_Procedure
5766 Prag_Id
= Pragma_Export_Valued_Procedure
5768 Prag_Id
= Pragma_Export_Function
)
5770 for J
in Externals
.First
.. Externals
.Last
loop
5771 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5772 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5773 Error_Msg_N
("external name duplicates name given#", Nam
);
5778 Externals
.Append
(Nam
);
5780 end Check_Duplicated_Export_Name
;
5782 ----------------------------------------
5783 -- Check_Expr_Is_OK_Static_Expression --
5784 ----------------------------------------
5786 procedure Check_Expr_Is_OK_Static_Expression
5788 Typ
: Entity_Id
:= Empty
)
5791 if Present
(Typ
) then
5792 Analyze_And_Resolve
(Expr
, Typ
);
5794 Analyze_And_Resolve
(Expr
);
5797 -- An expression cannot be considered static if its resolution failed
5798 -- or if it's erroneous. Stop the analysis of the related pragma.
5800 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5803 elsif Is_OK_Static_Expression
(Expr
) then
5806 -- An interesting special case, if we have a string literal and we
5807 -- are in Ada 83 mode, then we allow it even though it will not be
5808 -- flagged as static. This allows the use of Ada 95 pragmas like
5809 -- Import in Ada 83 mode. They will of course be flagged with
5810 -- warnings as usual, but will not cause errors.
5812 elsif Ada_Version
= Ada_83
5813 and then Nkind
(Expr
) = N_String_Literal
5817 -- Finally, we have a real error
5820 Error_Msg_Name_1
:= Pname
;
5821 Flag_Non_Static_Expr
5822 (Fix_Error
("argument for pragma% must be a static expression!"),
5826 end Check_Expr_Is_OK_Static_Expression
;
5828 -------------------------
5829 -- Check_First_Subtype --
5830 -------------------------
5832 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5833 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5834 Ent
: constant Entity_Id
:= Entity
(Argx
);
5837 if Is_First_Subtype
(Ent
) then
5840 elsif Is_Type
(Ent
) then
5842 ("pragma% cannot apply to subtype", Argx
);
5844 elsif Is_Object
(Ent
) then
5846 ("pragma% cannot apply to object, requires a type", Argx
);
5850 ("pragma% cannot apply to&, requires a type", Argx
);
5852 end Check_First_Subtype
;
5854 ----------------------
5855 -- Check_Identifier --
5856 ----------------------
5858 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5861 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5863 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5864 Error_Msg_Name_1
:= Pname
;
5865 Error_Msg_Name_2
:= Id
;
5866 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5870 end Check_Identifier
;
5872 --------------------------------
5873 -- Check_Identifier_Is_One_Of --
5874 --------------------------------
5876 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5879 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5881 if Chars
(Arg
) = No_Name
then
5882 Error_Msg_Name_1
:= Pname
;
5883 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5886 elsif Chars
(Arg
) /= N1
5887 and then Chars
(Arg
) /= N2
5889 Error_Msg_Name_1
:= Pname
;
5890 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5894 end Check_Identifier_Is_One_Of
;
5896 ---------------------------
5897 -- Check_In_Main_Program --
5898 ---------------------------
5900 procedure Check_In_Main_Program
is
5901 P
: constant Node_Id
:= Parent
(N
);
5904 -- Must be in subprogram body
5906 if Nkind
(P
) /= N_Subprogram_Body
then
5907 Error_Pragma
("% pragma allowed only in subprogram");
5909 -- Otherwise warn if obviously not main program
5911 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5912 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5914 Error_Msg_Name_1
:= Pname
;
5916 ("??pragma% is only effective in main program", N
);
5918 end Check_In_Main_Program
;
5920 ---------------------------------------
5921 -- Check_Interrupt_Or_Attach_Handler --
5922 ---------------------------------------
5924 procedure Check_Interrupt_Or_Attach_Handler
is
5925 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5926 Handler_Proc
, Proc_Scope
: Entity_Id
;
5931 if Prag_Id
= Pragma_Interrupt_Handler
then
5932 Check_Restriction
(No_Dynamic_Attachment
, N
);
5935 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5936 Proc_Scope
:= Scope
(Handler_Proc
);
5938 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5940 ("argument of pragma% must be protected procedure", Arg1
);
5943 -- For pragma case (as opposed to access case), check placement.
5944 -- We don't need to do that for aspects, because we have the
5945 -- check that they aspect applies an appropriate procedure.
5947 if not From_Aspect_Specification
(N
)
5948 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5950 Error_Pragma
("pragma% must be in protected definition");
5953 if not Is_Library_Level_Entity
(Proc_Scope
) then
5955 ("argument for pragma% must be library level entity", Arg1
);
5958 -- AI05-0033: A pragma cannot appear within a generic body, because
5959 -- instance can be in a nested scope. The check that protected type
5960 -- is itself a library-level declaration is done elsewhere.
5962 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5963 -- handle code prior to AI-0033. Analysis tools typically are not
5964 -- interested in this pragma in any case, so no need to worry too
5965 -- much about its placement.
5967 if Inside_A_Generic
then
5968 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5969 and then In_Package_Body
(Scope
(Current_Scope
))
5970 and then not Relaxed_RM_Semantics
5972 Error_Pragma
("pragma% cannot be used inside a generic");
5975 end Check_Interrupt_Or_Attach_Handler
;
5977 ---------------------------------
5978 -- Check_Loop_Pragma_Placement --
5979 ---------------------------------
5981 procedure Check_Loop_Pragma_Placement
is
5982 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5983 -- Verify whether the current pragma is properly grouped with other
5984 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5985 -- related loop where the pragma appears.
5987 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5988 -- Determine whether an arbitrary statement Stmt denotes pragma
5989 -- Loop_Invariant or Loop_Variant.
5991 procedure Placement_Error
(Constr
: Node_Id
);
5992 pragma No_Return
(Placement_Error
);
5993 -- Node Constr denotes the last loop restricted construct before we
5994 -- encountered an illegal relation between enclosing constructs. Emit
5995 -- an error depending on what Constr was.
5997 --------------------------------
5998 -- Check_Loop_Pragma_Grouping --
5999 --------------------------------
6001 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
6002 Stop_Search
: exception;
6003 -- This exception is used to terminate the recursive descent of
6004 -- routine Check_Grouping.
6006 procedure Check_Grouping
(L
: List_Id
);
6007 -- Find the first group of pragmas in list L and if successful,
6008 -- ensure that the current pragma is part of that group. The
6009 -- routine raises Stop_Search once such a check is performed to
6010 -- halt the recursive descent.
6012 procedure Grouping_Error
(Prag
: Node_Id
);
6013 pragma No_Return
(Grouping_Error
);
6014 -- Emit an error concerning the current pragma indicating that it
6015 -- should be placed after pragma Prag.
6017 --------------------
6018 -- Check_Grouping --
6019 --------------------
6021 procedure Check_Grouping
(L
: List_Id
) is
6024 Prag
: Node_Id
:= Empty
; -- init to avoid warning
6027 -- Inspect the list of declarations or statements looking for
6028 -- the first grouping of pragmas:
6031 -- pragma Loop_Invariant ...;
6032 -- pragma Loop_Variant ...;
6034 -- pragma Loop_Variant ...; -- current pragma
6036 -- If the current pragma is not in the grouping, then it must
6037 -- either appear in a different declarative or statement list
6038 -- or the construct at (1) is separating the pragma from the
6042 while Present
(Stmt
) loop
6044 -- First pragma of the first topmost grouping has been found
6046 if Is_Loop_Pragma
(Stmt
) then
6048 -- The group and the current pragma are not in the same
6049 -- declarative or statement list.
6051 if List_Containing
(Stmt
) /= List_Containing
(N
) then
6052 Grouping_Error
(Stmt
);
6054 -- Try to reach the current pragma from the first pragma
6055 -- of the grouping while skipping other members:
6057 -- pragma Loop_Invariant ...; -- first pragma
6058 -- pragma Loop_Variant ...; -- member
6060 -- pragma Loop_Variant ...; -- current pragma
6063 while Present
(Stmt
) loop
6064 -- The current pragma is either the first pragma
6065 -- of the group or is a member of the group.
6066 -- Stop the search as the placement is legal.
6071 -- Skip group members, but keep track of the
6072 -- last pragma in the group.
6074 elsif Is_Loop_Pragma
(Stmt
) then
6077 -- Skip declarations and statements generated by
6078 -- the compiler during expansion. Note that some
6079 -- source statements (e.g. pragma Assert) may have
6080 -- been transformed so that they do not appear as
6081 -- coming from source anymore, so we instead look
6082 -- at their Original_Node.
6084 elsif not Comes_From_Source
(Original_Node
(Stmt
))
6088 -- A non-pragma is separating the group from the
6089 -- current pragma, the placement is illegal.
6092 Grouping_Error
(Prag
);
6098 -- If the traversal did not reach the current pragma,
6099 -- then the list must be malformed.
6101 raise Program_Error
;
6104 -- Pragmas Loop_Invariant and Loop_Variant may only appear
6105 -- inside a loop or a block housed inside a loop. Inspect
6106 -- the declarations and statements of the block as they may
6107 -- contain the first grouping. This case follows the one for
6108 -- loop pragmas, as block statements which originate in a
6109 -- loop pragma (and so Is_Loop_Pragma will return True on
6110 -- that block statement) should be treated in the previous
6113 elsif Nkind
(Stmt
) = N_Block_Statement
then
6114 HSS
:= Handled_Statement_Sequence
(Stmt
);
6116 Check_Grouping
(Declarations
(Stmt
));
6118 if Present
(HSS
) then
6119 Check_Grouping
(Statements
(HSS
));
6127 --------------------
6128 -- Grouping_Error --
6129 --------------------
6131 procedure Grouping_Error
(Prag
: Node_Id
) is
6133 Error_Msg_Sloc
:= Sloc
(Prag
);
6134 Error_Pragma
("pragma% must appear next to pragma#");
6137 -- Start of processing for Check_Loop_Pragma_Grouping
6140 -- Inspect the statements of the loop or nested blocks housed
6141 -- within to determine whether the current pragma is part of the
6142 -- first topmost grouping of Loop_Invariant and Loop_Variant.
6144 Check_Grouping
(Statements
(Loop_Stmt
));
6147 when Stop_Search
=> null;
6148 end Check_Loop_Pragma_Grouping
;
6150 --------------------
6151 -- Is_Loop_Pragma --
6152 --------------------
6154 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
6156 -- Inspect the original node as Loop_Invariant and Loop_Variant
6157 -- pragmas are rewritten to null when assertions are disabled.
6159 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
6161 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
6162 Name_Loop_Invariant
,
6169 ---------------------
6170 -- Placement_Error --
6171 ---------------------
6173 procedure Placement_Error
(Constr
: Node_Id
) is
6174 LA
: constant String := " with Loop_Entry";
6177 if Prag_Id
= Pragma_Assert
then
6178 Error_Msg_String
(1 .. LA
'Length) := LA
;
6179 Error_Msg_Strlen
:= LA
'Length;
6181 Error_Msg_Strlen
:= 0;
6184 if Nkind
(Constr
) = N_Pragma
then
6186 ("pragma %~ must appear immediately within the statements "
6190 ("block containing pragma %~ must appear immediately within "
6191 & "the statements of a loop", Constr
);
6193 end Placement_Error
;
6195 -- Local declarations
6200 -- Start of processing for Check_Loop_Pragma_Placement
6203 -- Check that pragma appears immediately within a loop statement,
6204 -- ignoring intervening block statements.
6208 while Present
(Stmt
) loop
6210 -- The pragma or previous block must appear immediately within the
6211 -- current block's declarative or statement part.
6213 if Nkind
(Stmt
) = N_Block_Statement
then
6214 if (No
(Declarations
(Stmt
))
6215 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6217 List_Containing
(Prev
) /=
6218 Statements
(Handled_Statement_Sequence
(Stmt
))
6220 Placement_Error
(Prev
);
6223 -- Keep inspecting the parents because we are now within a
6224 -- chain of nested blocks.
6228 Stmt
:= Parent
(Stmt
);
6231 -- The pragma or previous block must appear immediately within the
6232 -- statements of the loop.
6234 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6235 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6236 Placement_Error
(Prev
);
6239 -- Stop the traversal because we reached the innermost loop
6240 -- regardless of whether we encountered an error or not.
6244 -- Ignore a handled statement sequence. Note that this node may
6245 -- be related to a subprogram body in which case we will emit an
6246 -- error on the next iteration of the search.
6248 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6249 Stmt
:= Parent
(Stmt
);
6251 -- Any other statement breaks the chain from the pragma to the
6255 Placement_Error
(Prev
);
6260 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6261 -- grouped together with other such pragmas.
6263 if Is_Loop_Pragma
(N
) then
6265 -- The previous check should have located the related loop
6267 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6268 Check_Loop_Pragma_Grouping
(Stmt
);
6270 end Check_Loop_Pragma_Placement
;
6272 -------------------------------------------
6273 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6274 -------------------------------------------
6276 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6285 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6288 elsif Nkind_In
(P
, N_Package_Specification
,
6293 -- Note: the following tests seem a little peculiar, because
6294 -- they test for bodies, but if we were in the statement part
6295 -- of the body, we would already have hit the handled statement
6296 -- sequence, so the only way we get here is by being in the
6297 -- declarative part of the body.
6299 elsif Nkind_In
(P
, N_Subprogram_Body
,
6310 Error_Pragma
("pragma% is not in declarative part or package spec");
6311 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6313 -------------------------
6314 -- Check_No_Identifier --
6315 -------------------------
6317 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6319 if Nkind
(Arg
) = N_Pragma_Argument_Association
6320 and then Chars
(Arg
) /= No_Name
6322 Error_Pragma_Arg_Ident
6323 ("pragma% does not permit identifier& here", Arg
);
6325 end Check_No_Identifier
;
6327 --------------------------
6328 -- Check_No_Identifiers --
6329 --------------------------
6331 procedure Check_No_Identifiers
is
6335 for J
in 1 .. Arg_Count
loop
6336 Check_No_Identifier
(Arg_Node
);
6339 end Check_No_Identifiers
;
6341 ------------------------
6342 -- Check_No_Link_Name --
6343 ------------------------
6345 procedure Check_No_Link_Name
is
6347 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6351 if Present
(Arg4
) then
6353 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6355 end Check_No_Link_Name
;
6357 -------------------------------
6358 -- Check_Optional_Identifier --
6359 -------------------------------
6361 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6364 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6365 and then Chars
(Arg
) /= No_Name
6367 if Chars
(Arg
) /= Id
then
6368 Error_Msg_Name_1
:= Pname
;
6369 Error_Msg_Name_2
:= Id
;
6370 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6374 end Check_Optional_Identifier
;
6376 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6378 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6379 end Check_Optional_Identifier
;
6381 -------------------------------------
6382 -- Check_Static_Boolean_Expression --
6383 -------------------------------------
6385 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6387 if Present
(Expr
) then
6388 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6390 if not Is_OK_Static_Expression
(Expr
) then
6392 ("expression of pragma % must be static", Expr
);
6395 end Check_Static_Boolean_Expression
;
6397 -----------------------------
6398 -- Check_Static_Constraint --
6399 -----------------------------
6401 -- Note: for convenience in writing this procedure, in addition to
6402 -- the officially (i.e. by spec) allowed argument which is always a
6403 -- constraint, it also allows ranges and discriminant associations.
6404 -- Above is not clear ???
6406 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6408 procedure Require_Static
(E
: Node_Id
);
6409 -- Require given expression to be static expression
6411 --------------------
6412 -- Require_Static --
6413 --------------------
6415 procedure Require_Static
(E
: Node_Id
) is
6417 if not Is_OK_Static_Expression
(E
) then
6418 Flag_Non_Static_Expr
6419 ("non-static constraint not allowed in Unchecked_Union!", E
);
6424 -- Start of processing for Check_Static_Constraint
6427 case Nkind
(Constr
) is
6428 when N_Discriminant_Association
=>
6429 Require_Static
(Expression
(Constr
));
6432 Require_Static
(Low_Bound
(Constr
));
6433 Require_Static
(High_Bound
(Constr
));
6435 when N_Attribute_Reference
=>
6436 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6437 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6439 when N_Range_Constraint
=>
6440 Check_Static_Constraint
(Range_Expression
(Constr
));
6442 when N_Index_Or_Discriminant_Constraint
=>
6446 IDC
:= First
(Constraints
(Constr
));
6447 while Present
(IDC
) loop
6448 Check_Static_Constraint
(IDC
);
6456 end Check_Static_Constraint
;
6458 --------------------------------------
6459 -- Check_Valid_Configuration_Pragma --
6460 --------------------------------------
6462 -- A configuration pragma must appear in the context clause of a
6463 -- compilation unit, and only other pragmas may precede it. Note that
6464 -- the test also allows use in a configuration pragma file.
6466 procedure Check_Valid_Configuration_Pragma
is
6468 if not Is_Configuration_Pragma
then
6469 Error_Pragma
("incorrect placement for configuration pragma%");
6471 end Check_Valid_Configuration_Pragma
;
6473 -------------------------------------
6474 -- Check_Valid_Library_Unit_Pragma --
6475 -------------------------------------
6477 procedure Check_Valid_Library_Unit_Pragma
is
6479 Parent_Node
: Node_Id
;
6480 Unit_Name
: Entity_Id
;
6481 Unit_Kind
: Node_Kind
;
6482 Unit_Node
: Node_Id
;
6483 Sindex
: Source_File_Index
;
6486 if not Is_List_Member
(N
) then
6490 Plist
:= List_Containing
(N
);
6491 Parent_Node
:= Parent
(Plist
);
6493 if Parent_Node
= Empty
then
6496 -- Case of pragma appearing after a compilation unit. In this case
6497 -- it must have an argument with the corresponding name and must
6498 -- be part of the following pragmas of its parent.
6500 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6501 if Plist
/= Pragmas_After
(Parent_Node
) then
6504 elsif Arg_Count
= 0 then
6506 ("argument required if outside compilation unit");
6509 Check_No_Identifiers
;
6510 Check_Arg_Count
(1);
6511 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6512 Unit_Kind
:= Nkind
(Unit_Node
);
6514 Analyze
(Get_Pragma_Arg
(Arg1
));
6516 if Unit_Kind
= N_Generic_Subprogram_Declaration
6517 or else Unit_Kind
= N_Subprogram_Declaration
6519 Unit_Name
:= Defining_Entity
(Unit_Node
);
6521 elsif Unit_Kind
in N_Generic_Instantiation
then
6522 Unit_Name
:= Defining_Entity
(Unit_Node
);
6525 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6528 if Chars
(Unit_Name
) /=
6529 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6532 ("pragma% argument is not current unit name", Arg1
);
6535 if Ekind
(Unit_Name
) = E_Package
6536 and then Present
(Renamed_Entity
(Unit_Name
))
6538 Error_Pragma
("pragma% not allowed for renamed package");
6542 -- Pragma appears other than after a compilation unit
6545 -- Here we check for the generic instantiation case and also
6546 -- for the case of processing a generic formal package. We
6547 -- detect these cases by noting that the Sloc on the node
6548 -- does not belong to the current compilation unit.
6550 Sindex
:= Source_Index
(Current_Sem_Unit
);
6552 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6553 Rewrite
(N
, Make_Null_Statement
(Loc
));
6556 -- If before first declaration, the pragma applies to the
6557 -- enclosing unit, and the name if present must be this name.
6559 elsif Is_Before_First_Decl
(N
, Plist
) then
6560 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6561 Unit_Kind
:= Nkind
(Unit_Node
);
6563 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6566 elsif Unit_Kind
= N_Subprogram_Body
6567 and then not Acts_As_Spec
(Unit_Node
)
6571 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6574 elsif Nkind
(Parent_Node
) = N_Package_Specification
6575 and then Plist
= Private_Declarations
(Parent_Node
)
6579 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6580 or else Nkind
(Parent_Node
) =
6581 N_Generic_Subprogram_Declaration
)
6582 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6586 elsif Arg_Count
> 0 then
6587 Analyze
(Get_Pragma_Arg
(Arg1
));
6589 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6591 ("name in pragma% must be enclosing unit", Arg1
);
6594 -- It is legal to have no argument in this context
6600 -- Error if not before first declaration. This is because a
6601 -- library unit pragma argument must be the name of a library
6602 -- unit (RM 10.1.5(7)), but the only names permitted in this
6603 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6604 -- generic subprogram declarations or generic instantiations.
6608 ("pragma% misplaced, must be before first declaration");
6612 end Check_Valid_Library_Unit_Pragma
;
6618 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6619 Clist
: constant Node_Id
:= Component_List
(Variant
);
6623 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6624 while Present
(Comp
) loop
6625 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6626 Next_Non_Pragma
(Comp
);
6630 ---------------------------
6631 -- Ensure_Aggregate_Form --
6632 ---------------------------
6634 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6635 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6636 Expr
: constant Node_Id
:= Expression
(Arg
);
6637 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6638 Comps
: List_Id
:= No_List
;
6639 Exprs
: List_Id
:= No_List
;
6640 Nam
: Name_Id
:= No_Name
;
6641 Nam_Loc
: Source_Ptr
;
6644 -- The pragma argument is in positional form:
6646 -- pragma Depends (Nam => ...)
6650 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6651 -- argument association.
6653 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6655 Nam_Loc
:= Sloc
(Arg
);
6657 -- Remove the pragma argument name as this will be captured in the
6660 Set_Chars
(Arg
, No_Name
);
6663 -- The argument is already in aggregate form, but the presence of a
6664 -- name causes this to be interpreted as named association which in
6665 -- turn must be converted into an aggregate.
6667 -- pragma Global (In_Out => (A, B, C))
6671 -- pragma Global ((In_Out => (A, B, C)))
6673 -- aggregate aggregate
6675 if Nkind
(Expr
) = N_Aggregate
then
6676 if Nam
= No_Name
then
6680 -- Do not transform a null argument into an aggregate as N_Null has
6681 -- special meaning in formal verification pragmas.
6683 elsif Nkind
(Expr
) = N_Null
then
6687 -- Everything comes from source if the original comes from source
6689 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6691 -- Positional argument is transformed into an aggregate with an
6692 -- Expressions list.
6694 if Nam
= No_Name
then
6695 Exprs
:= New_List
(Relocate_Node
(Expr
));
6697 -- An associative argument is transformed into an aggregate with
6698 -- Component_Associations.
6702 Make_Component_Association
(Loc
,
6703 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6704 Expression
=> Relocate_Node
(Expr
)));
6707 Set_Expression
(Arg
,
6708 Make_Aggregate
(Loc
,
6709 Component_Associations
=> Comps
,
6710 Expressions
=> Exprs
));
6712 -- Restore Comes_From_Source default
6714 Set_Comes_From_Source_Default
(CFSD
);
6715 end Ensure_Aggregate_Form
;
6721 procedure Error_Pragma
(Msg
: String) is
6723 Error_Msg_Name_1
:= Pname
;
6724 Error_Msg_N
(Fix_Error
(Msg
), N
);
6728 ----------------------
6729 -- Error_Pragma_Arg --
6730 ----------------------
6732 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6734 Error_Msg_Name_1
:= Pname
;
6735 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6737 end Error_Pragma_Arg
;
6739 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6741 Error_Msg_Name_1
:= Pname
;
6742 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6743 Error_Pragma_Arg
(Msg2
, Arg
);
6744 end Error_Pragma_Arg
;
6746 ----------------------------
6747 -- Error_Pragma_Arg_Ident --
6748 ----------------------------
6750 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6752 Error_Msg_Name_1
:= Pname
;
6753 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6755 end Error_Pragma_Arg_Ident
;
6757 ----------------------
6758 -- Error_Pragma_Ref --
6759 ----------------------
6761 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6763 Error_Msg_Name_1
:= Pname
;
6764 Error_Msg_Sloc
:= Sloc
(Ref
);
6765 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6767 end Error_Pragma_Ref
;
6769 ------------------------
6770 -- Find_Lib_Unit_Name --
6771 ------------------------
6773 function Find_Lib_Unit_Name
return Entity_Id
is
6775 -- Return inner compilation unit entity, for case of nested
6776 -- categorization pragmas. This happens in generic unit.
6778 if Nkind
(Parent
(N
)) = N_Package_Specification
6779 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6781 return Defining_Entity
(Parent
(N
));
6783 return Current_Scope
;
6785 end Find_Lib_Unit_Name
;
6787 ----------------------------
6788 -- Find_Program_Unit_Name --
6789 ----------------------------
6791 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6792 Unit_Name
: Entity_Id
;
6793 Unit_Kind
: Node_Kind
;
6794 P
: constant Node_Id
:= Parent
(N
);
6797 if Nkind
(P
) = N_Compilation_Unit
then
6798 Unit_Kind
:= Nkind
(Unit
(P
));
6800 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6801 N_Package_Declaration
)
6802 or else Unit_Kind
in N_Generic_Declaration
6804 Unit_Name
:= Defining_Entity
(Unit
(P
));
6806 if Chars
(Id
) = Chars
(Unit_Name
) then
6807 Set_Entity
(Id
, Unit_Name
);
6808 Set_Etype
(Id
, Etype
(Unit_Name
));
6810 Set_Etype
(Id
, Any_Type
);
6812 ("cannot find program unit referenced by pragma%");
6816 Set_Etype
(Id
, Any_Type
);
6817 Error_Pragma
("pragma% inapplicable to this unit");
6823 end Find_Program_Unit_Name
;
6825 -----------------------------------------
6826 -- Find_Unique_Parameterless_Procedure --
6827 -----------------------------------------
6829 function Find_Unique_Parameterless_Procedure
6831 Arg
: Node_Id
) return Entity_Id
6833 Proc
: Entity_Id
:= Empty
;
6836 -- The body of this procedure needs some comments ???
6838 if not Is_Entity_Name
(Name
) then
6840 ("argument of pragma% must be entity name", Arg
);
6842 elsif not Is_Overloaded
(Name
) then
6843 Proc
:= Entity
(Name
);
6845 if Ekind
(Proc
) /= E_Procedure
6846 or else Present
(First_Formal
(Proc
))
6849 ("argument of pragma% must be parameterless procedure", Arg
);
6854 Found
: Boolean := False;
6856 Index
: Interp_Index
;
6859 Get_First_Interp
(Name
, Index
, It
);
6860 while Present
(It
.Nam
) loop
6863 if Ekind
(Proc
) = E_Procedure
6864 and then No
(First_Formal
(Proc
))
6868 Set_Entity
(Name
, Proc
);
6869 Set_Is_Overloaded
(Name
, False);
6872 ("ambiguous handler name for pragma% ", Arg
);
6876 Get_Next_Interp
(Index
, It
);
6881 ("argument of pragma% must be parameterless procedure",
6884 Proc
:= Entity
(Name
);
6890 end Find_Unique_Parameterless_Procedure
;
6896 function Fix_Error
(Msg
: String) return String is
6897 Res
: String (Msg
'Range) := Msg
;
6898 Res_Last
: Natural := Msg
'Last;
6902 -- If we have a rewriting of another pragma, go to that pragma
6904 if Is_Rewrite_Substitution
(N
)
6905 and then Nkind
(Original_Node
(N
)) = N_Pragma
6907 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6910 -- Case where pragma comes from an aspect specification
6912 if From_Aspect_Specification
(N
) then
6914 -- Change appearence of "pragma" in message to "aspect"
6917 while J
<= Res_Last
- 5 loop
6918 if Res
(J
.. J
+ 5) = "pragma" then
6919 Res
(J
.. J
+ 5) := "aspect";
6927 -- Change "argument of" at start of message to "entity for"
6930 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6932 Res
(Res
'First .. Res
'First + 9) := "entity for";
6933 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6934 Res
(Res
'First + 11 .. Res_Last
);
6935 Res_Last
:= Res_Last
- 1;
6938 -- Change "argument" at start of message to "entity"
6941 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6943 Res
(Res
'First .. Res
'First + 5) := "entity";
6944 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6945 Res
(Res
'First + 8 .. Res_Last
);
6946 Res_Last
:= Res_Last
- 2;
6949 -- Get name from corresponding aspect
6951 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6954 -- Return possibly modified message
6956 return Res
(Res
'First .. Res_Last
);
6959 -------------------------
6960 -- Gather_Associations --
6961 -------------------------
6963 procedure Gather_Associations
6965 Args
: out Args_List
)
6970 -- Initialize all parameters to Empty
6972 for J
in Args
'Range loop
6976 -- That's all we have to do if there are no argument associations
6978 if No
(Pragma_Argument_Associations
(N
)) then
6982 -- Otherwise first deal with any positional parameters present
6984 Arg
:= First
(Pragma_Argument_Associations
(N
));
6985 for Index
in Args
'Range loop
6986 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6987 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6991 -- Positional parameters all processed, if any left, then we
6992 -- have too many positional parameters.
6994 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6996 ("too many positional associations for pragma%", Arg
);
6999 -- Process named parameters if any are present
7001 while Present
(Arg
) loop
7002 if Chars
(Arg
) = No_Name
then
7004 ("positional association cannot follow named association",
7008 for Index
in Names
'Range loop
7009 if Names
(Index
) = Chars
(Arg
) then
7010 if Present
(Args
(Index
)) then
7012 ("duplicate argument association for pragma%", Arg
);
7014 Args
(Index
) := Get_Pragma_Arg
(Arg
);
7019 if Index
= Names
'Last then
7020 Error_Msg_Name_1
:= Pname
;
7021 Error_Msg_N
("pragma% does not allow & argument", Arg
);
7023 -- Check for possible misspelling
7025 for Index1
in Names
'Range loop
7026 if Is_Bad_Spelling_Of
7027 (Chars
(Arg
), Names
(Index1
))
7029 Error_Msg_Name_1
:= Names
(Index1
);
7030 Error_Msg_N
-- CODEFIX
7031 ("\possible misspelling of%", Arg
);
7043 end Gather_Associations
;
7049 procedure GNAT_Pragma
is
7051 -- We need to check the No_Implementation_Pragmas restriction for
7052 -- the case of a pragma from source. Note that the case of aspects
7053 -- generating corresponding pragmas marks these pragmas as not being
7054 -- from source, so this test also catches that case.
7056 if Comes_From_Source
(N
) then
7057 Check_Restriction
(No_Implementation_Pragmas
, N
);
7061 --------------------------
7062 -- Is_Before_First_Decl --
7063 --------------------------
7065 function Is_Before_First_Decl
7066 (Pragma_Node
: Node_Id
;
7067 Decls
: List_Id
) return Boolean
7069 Item
: Node_Id
:= First
(Decls
);
7072 -- Only other pragmas can come before this pragma
7075 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
7078 elsif Item
= Pragma_Node
then
7084 end Is_Before_First_Decl
;
7086 -----------------------------
7087 -- Is_Configuration_Pragma --
7088 -----------------------------
7090 -- A configuration pragma must appear in the context clause of a
7091 -- compilation unit, and only other pragmas may precede it. Note that
7092 -- the test below also permits use in a configuration pragma file.
7094 function Is_Configuration_Pragma
return Boolean is
7095 Lis
: constant List_Id
:= List_Containing
(N
);
7096 Par
: constant Node_Id
:= Parent
(N
);
7100 -- If no parent, then we are in the configuration pragma file,
7101 -- so the placement is definitely appropriate.
7106 -- Otherwise we must be in the context clause of a compilation unit
7107 -- and the only thing allowed before us in the context list is more
7108 -- configuration pragmas.
7110 elsif Nkind
(Par
) = N_Compilation_Unit
7111 and then Context_Items
(Par
) = Lis
7118 elsif Nkind
(Prg
) /= N_Pragma
then
7128 end Is_Configuration_Pragma
;
7130 --------------------------
7131 -- Is_In_Context_Clause --
7132 --------------------------
7134 function Is_In_Context_Clause
return Boolean is
7136 Parent_Node
: Node_Id
;
7139 if not Is_List_Member
(N
) then
7143 Plist
:= List_Containing
(N
);
7144 Parent_Node
:= Parent
(Plist
);
7146 if Parent_Node
= Empty
7147 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
7148 or else Context_Items
(Parent_Node
) /= Plist
7155 end Is_In_Context_Clause
;
7157 ---------------------------------
7158 -- Is_Static_String_Expression --
7159 ---------------------------------
7161 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
7162 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
7163 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
7166 Analyze_And_Resolve
(Argx
);
7168 -- Special case Ada 83, where the expression will never be static,
7169 -- but we will return true if we had a string literal to start with.
7171 if Ada_Version
= Ada_83
then
7174 -- Normal case, true only if we end up with a string literal that
7175 -- is marked as being the result of evaluating a static expression.
7178 return Is_OK_Static_Expression
(Argx
)
7179 and then Nkind
(Argx
) = N_String_Literal
;
7182 end Is_Static_String_Expression
;
7184 ----------------------
7185 -- Pragma_Misplaced --
7186 ----------------------
7188 procedure Pragma_Misplaced
is
7190 Error_Pragma
("incorrect placement of pragma%");
7191 end Pragma_Misplaced
;
7193 ------------------------------------------------
7194 -- Process_Atomic_Independent_Shared_Volatile --
7195 ------------------------------------------------
7197 procedure Process_Atomic_Independent_Shared_Volatile
is
7198 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
7199 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
7201 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
7202 -- Appropriately set flags on the given entity (either an array or
7203 -- record component, or an object declaration) according to the
7206 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
7207 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
7208 -- no explicit alignment was given, set alignment to unknown, since
7209 -- back end knows what the alignment requirements are for atomic and
7210 -- full access arrays. Note: this is necessary for derived types.
7212 -------------------------
7213 -- Check_VFA_Conflicts --
7214 -------------------------
7216 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7220 VFA_And_Atomic
: Boolean := False;
7221 -- Set True if atomic component present
7223 VFA_And_Aliased
: Boolean := False;
7224 -- Set True if aliased component present
7227 -- Fetch the type in case we are dealing with an object or
7230 if Is_Type
(Ent
) then
7233 pragma Assert
(Is_Object
(Ent
)
7235 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7240 -- Check Atomic and VFA used together
7242 if Prag_Id
= Pragma_Volatile_Full_Access
7243 or else Is_Volatile_Full_Access
(Ent
)
7245 if Prag_Id
= Pragma_Atomic
7246 or else Prag_Id
= Pragma_Shared
7247 or else Is_Atomic
(Ent
)
7249 VFA_And_Atomic
:= True;
7251 elsif Is_Array_Type
(Typ
) then
7252 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7254 -- Note: Has_Atomic_Components is not used below, as this flag
7255 -- represents the pragma of the same name, Atomic_Components,
7256 -- which only applies to arrays.
7258 elsif Is_Record_Type
(Typ
) then
7259 -- Attributes cannot be applied to discriminants, only
7260 -- regular record components.
7262 Comp
:= First_Component
(Typ
);
7263 while Present
(Comp
) loop
7265 or else Is_Atomic
(Typ
)
7267 VFA_And_Atomic
:= True;
7272 Next_Component
(Comp
);
7276 if VFA_And_Atomic
then
7278 ("cannot have Volatile_Full_Access and Atomic for same "
7283 -- Check for the application of VFA to an entity that has aliased
7286 if Prag_Id
= Pragma_Volatile_Full_Access
then
7287 if Is_Array_Type
(Typ
)
7288 and then Has_Aliased_Components
(Typ
)
7290 VFA_And_Aliased
:= True;
7292 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7293 -- and Has_Independent_Components, applies only to arrays.
7294 -- However, this flag does not have a corresponding pragma, so
7295 -- perhaps it should be possible to apply it to record types as
7296 -- well. Should this be done ???
7298 elsif Is_Record_Type
(Typ
) then
7299 -- It is possible to have an aliased discriminant, so they
7300 -- must be checked along with normal components.
7302 Comp
:= First_Component_Or_Discriminant
(Typ
);
7303 while Present
(Comp
) loop
7304 if Is_Aliased
(Comp
)
7305 or else Is_Aliased
(Etype
(Comp
))
7307 VFA_And_Aliased
:= True;
7308 Check_SPARK_05_Restriction
7309 ("aliased is not allowed", Comp
);
7314 Next_Component_Or_Discriminant
(Comp
);
7318 if VFA_And_Aliased
then
7320 ("cannot apply Volatile_Full_Access (aliased component "
7324 end Check_VFA_Conflicts
;
7326 ------------------------------
7327 -- Mark_Component_Or_Object --
7328 ------------------------------
7330 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7332 if Prag_Id
= Pragma_Atomic
7333 or else Prag_Id
= Pragma_Shared
7334 or else Prag_Id
= Pragma_Volatile_Full_Access
7336 if Prag_Id
= Pragma_Volatile_Full_Access
then
7337 Set_Is_Volatile_Full_Access
(Ent
);
7339 Set_Is_Atomic
(Ent
);
7342 -- If the object declaration has an explicit initialization, a
7343 -- temporary may have to be created to hold the expression, to
7344 -- ensure that access to the object remains atomic.
7346 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7347 and then Present
(Expression
(Parent
(Ent
)))
7349 Set_Has_Delayed_Freeze
(Ent
);
7353 -- Atomic/Shared/Volatile_Full_Access imply Independent
7355 if Prag_Id
/= Pragma_Volatile
then
7356 Set_Is_Independent
(Ent
);
7358 if Prag_Id
= Pragma_Independent
then
7359 Record_Independence_Check
(N
, Ent
);
7363 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7365 if Prag_Id
/= Pragma_Independent
then
7366 Set_Is_Volatile
(Ent
);
7367 Set_Treat_As_Volatile
(Ent
);
7369 end Mark_Component_Or_Object
;
7371 --------------------
7372 -- Set_Atomic_VFA --
7373 --------------------
7375 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7377 if Prag_Id
= Pragma_Volatile_Full_Access
then
7378 Set_Is_Volatile_Full_Access
(Ent
);
7380 Set_Is_Atomic
(Ent
);
7383 if not Has_Alignment_Clause
(Ent
) then
7384 Set_Alignment
(Ent
, Uint_0
);
7394 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7397 Check_Ada_83_Warning
;
7398 Check_No_Identifiers
;
7399 Check_Arg_Count
(1);
7400 Check_Arg_Is_Local_Name
(Arg1
);
7401 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7403 if Etype
(E_Arg
) = Any_Type
then
7407 E
:= Entity
(E_Arg
);
7409 -- A pragma that applies to a Ghost entity becomes Ghost for the
7410 -- purposes of legality checks and removal of ignored Ghost code.
7412 Mark_Ghost_Pragma
(N
, E
);
7414 -- Check duplicate before we chain ourselves
7416 Check_Duplicate_Pragma
(E
);
7418 -- Check appropriateness of the entity
7420 Decl
:= Declaration_Node
(E
);
7422 -- Deal with the case where the pragma/attribute is applied to a type
7425 if Rep_Item_Too_Early
(E
, N
)
7426 or else Rep_Item_Too_Late
(E
, N
)
7430 Check_First_Subtype
(Arg1
);
7433 -- Attribute belongs on the base type. If the view of the type is
7434 -- currently private, it also belongs on the underlying type.
7436 if Prag_Id
= Pragma_Atomic
7437 or else Prag_Id
= Pragma_Shared
7438 or else Prag_Id
= Pragma_Volatile_Full_Access
7441 Set_Atomic_VFA
(Base_Type
(E
));
7442 Set_Atomic_VFA
(Underlying_Type
(E
));
7445 -- Atomic/Shared/Volatile_Full_Access imply Independent
7447 if Prag_Id
/= Pragma_Volatile
then
7448 Set_Is_Independent
(E
);
7449 Set_Is_Independent
(Base_Type
(E
));
7450 Set_Is_Independent
(Underlying_Type
(E
));
7452 if Prag_Id
= Pragma_Independent
then
7453 Record_Independence_Check
(N
, Base_Type
(E
));
7457 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7459 if Prag_Id
/= Pragma_Independent
then
7460 Set_Is_Volatile
(E
);
7461 Set_Is_Volatile
(Base_Type
(E
));
7462 Set_Is_Volatile
(Underlying_Type
(E
));
7464 Set_Treat_As_Volatile
(E
);
7465 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7468 -- Apply Volatile to the composite type's individual components,
7471 if Prag_Id
= Pragma_Volatile
7472 and then Is_Record_Type
(Etype
(E
))
7477 Comp
:= First_Component
(E
);
7478 while Present
(Comp
) loop
7479 Mark_Component_Or_Object
(Comp
);
7481 Next_Component
(Comp
);
7486 -- Deal with the case where the pragma/attribute applies to a
7487 -- component or object declaration.
7489 elsif Nkind
(Decl
) = N_Object_Declaration
7490 or else (Nkind
(Decl
) = N_Component_Declaration
7491 and then Original_Record_Component
(E
) = E
)
7493 if Rep_Item_Too_Late
(E
, N
) then
7497 Mark_Component_Or_Object
(E
);
7499 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7502 -- Perform the checks needed to assure the proper use of the GNAT
7503 -- pragma Volatile_Full_Access.
7505 Check_VFA_Conflicts
(E
);
7507 -- The following check is only relevant when SPARK_Mode is on as
7508 -- this is not a standard Ada legality rule. Pragma Volatile can
7509 -- only apply to a full type declaration or an object declaration
7510 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7511 -- untagged derived types that are rewritten as subtypes of their
7512 -- respective root types.
7515 and then Prag_Id
= Pragma_Volatile
7516 and then not Nkind_In
(Original_Node
(Decl
),
7517 N_Full_Type_Declaration
,
7518 N_Object_Declaration
,
7519 N_Single_Protected_Declaration
,
7520 N_Single_Task_Declaration
)
7523 ("argument of pragma % must denote a full type or object "
7524 & "declaration", Arg1
);
7526 end Process_Atomic_Independent_Shared_Volatile
;
7528 -------------------------------------------
7529 -- Process_Compile_Time_Warning_Or_Error --
7530 -------------------------------------------
7532 procedure Process_Compile_Time_Warning_Or_Error
is
7533 Validation_Needed
: Boolean := False;
7535 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7536 -- Tree visitor that checks if N is an attribute reference that can
7537 -- be statically computed by the back end. Validation_Needed is set
7538 -- to True if found.
7544 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7546 if Nkind
(N
) = N_Attribute_Reference
7547 and then Is_Entity_Name
(Prefix
(N
))
7548 and then not Is_Generic_Unit
(Scope
(Entity
(Prefix
(N
))))
7551 Attr_Id
: constant Attribute_Id
:=
7552 Get_Attribute_Id
(Attribute_Name
(N
));
7554 if Attr_Id
= Attribute_Alignment
7555 or else Attr_Id
= Attribute_Size
7557 Validation_Needed
:= True;
7565 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7569 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7571 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7574 -- In GNATprove mode, pragmas Compile_Time_Error and
7575 -- Compile_Time_Warning are ignored, as the analyzer may not have the
7576 -- same information as the compiler (in particular regarding size of
7577 -- objects decided in gigi) so it makes no sense to issue an error or
7578 -- warning in GNATprove.
7580 if GNATprove_Mode
then
7581 Rewrite
(N
, Make_Null_Statement
(Loc
));
7585 Check_Arg_Count
(2);
7586 Check_No_Identifiers
;
7587 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7588 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7590 if Compile_Time_Known_Value
(Arg1x
) then
7591 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7593 -- Register the expression for its validation after the back end has
7594 -- been called if it has occurrences of attributes Size or Alignment
7595 -- (because they may be statically computed by the back end and hence
7596 -- the whole expression needs to be reevaluated).
7599 Check_Expression
(Arg1x
);
7601 if Validation_Needed
then
7602 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7605 end Process_Compile_Time_Warning_Or_Error
;
7607 ------------------------
7608 -- Process_Convention --
7609 ------------------------
7611 procedure Process_Convention
7612 (C
: out Convention_Id
;
7613 Ent
: out Entity_Id
)
7617 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7618 -- Called if we have more than one Export/Import/Convention pragma.
7619 -- This is generally illegal, but we have a special case of allowing
7620 -- Import and Interface to coexist if they specify the convention in
7621 -- a consistent manner. We are allowed to do this, since Interface is
7622 -- an implementation defined pragma, and we choose to do it since we
7623 -- know Rational allows this combination. S is the entity id of the
7624 -- subprogram in question. This procedure also sets the special flag
7625 -- Import_Interface_Present in both pragmas in the case where we do
7626 -- have matching Import and Interface pragmas.
7628 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7629 -- Set convention in entity E, and also flag that the entity has a
7630 -- convention pragma. If entity is for a private or incomplete type,
7631 -- also set convention and flag on underlying type. This procedure
7632 -- also deals with the special case of C_Pass_By_Copy convention,
7633 -- and error checks for inappropriate convention specification.
7635 -------------------------------
7636 -- Diagnose_Multiple_Pragmas --
7637 -------------------------------
7639 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7640 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7644 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7645 -- Decl is a pragma node. This function returns True if this
7646 -- pragma has a first argument that is an identifier with a
7647 -- Chars field corresponding to the Convention_Id C.
7649 function Same_Name
(Decl
: Node_Id
) return Boolean;
7650 -- Decl is a pragma node. This function returns True if this
7651 -- pragma has a second argument that is an identifier with a
7652 -- Chars field that matches the Chars of the current subprogram.
7654 ---------------------
7655 -- Same_Convention --
7656 ---------------------
7658 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7659 Arg1
: constant Node_Id
:=
7660 First
(Pragma_Argument_Associations
(Decl
));
7663 if Present
(Arg1
) then
7665 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7667 if Nkind
(Arg
) = N_Identifier
7668 and then Is_Convention_Name
(Chars
(Arg
))
7669 and then Get_Convention_Id
(Chars
(Arg
)) = C
7677 end Same_Convention
;
7683 function Same_Name
(Decl
: Node_Id
) return Boolean is
7684 Arg1
: constant Node_Id
:=
7685 First
(Pragma_Argument_Associations
(Decl
));
7693 Arg2
:= Next
(Arg1
);
7700 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7702 if Nkind
(Arg
) = N_Identifier
7703 and then Chars
(Arg
) = Chars
(S
)
7712 -- Start of processing for Diagnose_Multiple_Pragmas
7717 -- Definitely give message if we have Convention/Export here
7719 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7722 -- If we have an Import or Export, scan back from pragma to
7723 -- find any previous pragma applying to the same procedure.
7724 -- The scan will be terminated by the start of the list, or
7725 -- hitting the subprogram declaration. This won't allow one
7726 -- pragma to appear in the public part and one in the private
7727 -- part, but that seems very unlikely in practice.
7731 while Present
(Decl
) and then Decl
/= Pdec
loop
7733 -- Look for pragma with same name as us
7735 if Nkind
(Decl
) = N_Pragma
7736 and then Same_Name
(Decl
)
7738 -- Give error if same as our pragma or Export/Convention
7740 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7743 Pragma_Name_Unmapped
(N
))
7747 -- Case of Import/Interface or the other way round
7749 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7750 Name_Interface
, Name_Import
)
7752 -- Here we know that we have Import and Interface. It
7753 -- doesn't matter which way round they are. See if
7754 -- they specify the same convention. If so, all OK,
7755 -- and set special flags to stop other messages
7757 if Same_Convention
(Decl
) then
7758 Set_Import_Interface_Present
(N
);
7759 Set_Import_Interface_Present
(Decl
);
7762 -- If different conventions, special message
7765 Error_Msg_Sloc
:= Sloc
(Decl
);
7767 ("convention differs from that given#", Arg1
);
7777 -- Give message if needed if we fall through those tests
7778 -- except on Relaxed_RM_Semantics where we let go: either this
7779 -- is a case accepted/ignored by other Ada compilers (e.g.
7780 -- a mix of Convention and Import), or another error will be
7781 -- generated later (e.g. using both Import and Export).
7783 if Err
and not Relaxed_RM_Semantics
then
7785 ("at most one Convention/Export/Import pragma is allowed",
7788 end Diagnose_Multiple_Pragmas
;
7790 --------------------------------
7791 -- Set_Convention_From_Pragma --
7792 --------------------------------
7794 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7796 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7797 -- for an overridden dispatching operation. Technically this is
7798 -- an amendment and should only be done in Ada 2005 mode. However,
7799 -- this is clearly a mistake, since the problem that is addressed
7800 -- by this AI is that there is a clear gap in the RM.
7802 if Is_Dispatching_Operation
(E
)
7803 and then Present
(Overridden_Operation
(E
))
7804 and then C
/= Convention
(Overridden_Operation
(E
))
7807 ("cannot change convention for overridden dispatching "
7808 & "operation", Arg1
);
7811 -- Special checks for Convention_Stdcall
7813 if C
= Convention_Stdcall
then
7815 -- A dispatching call is not allowed. A dispatching subprogram
7816 -- cannot be used to interface to the Win32 API, so in fact
7817 -- this check does not impose any effective restriction.
7819 if Is_Dispatching_Operation
(E
) then
7820 Error_Msg_Sloc
:= Sloc
(E
);
7822 -- Note: make this unconditional so that if there is more
7823 -- than one call to which the pragma applies, we get a
7824 -- message for each call. Also don't use Error_Pragma,
7825 -- so that we get multiple messages.
7828 ("dispatching subprogram# cannot use Stdcall convention!",
7831 -- Several allowed cases
7833 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7837 or else Ekind
(E
) = E_Variable
7839 -- A component as well. The entity does not have its Ekind
7840 -- set until the enclosing record declaration is fully
7843 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7845 -- An access to subprogram is also allowed
7849 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7851 -- Allow internal call to set convention of subprogram type
7853 or else Ekind
(E
) = E_Subprogram_Type
7859 ("second argument of pragma% must be subprogram (type)",
7864 -- Set the convention
7866 Set_Convention
(E
, C
);
7867 Set_Has_Convention_Pragma
(E
);
7869 -- For the case of a record base type, also set the convention of
7870 -- any anonymous access types declared in the record which do not
7871 -- currently have a specified convention.
7873 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7878 Comp
:= First_Component
(E
);
7879 while Present
(Comp
) loop
7880 if Present
(Etype
(Comp
))
7881 and then Ekind_In
(Etype
(Comp
),
7882 E_Anonymous_Access_Type
,
7883 E_Anonymous_Access_Subprogram_Type
)
7884 and then not Has_Convention_Pragma
(Comp
)
7886 Set_Convention
(Comp
, C
);
7889 Next_Component
(Comp
);
7894 -- Deal with incomplete/private type case, where underlying type
7895 -- is available, so set convention of that underlying type.
7897 if Is_Incomplete_Or_Private_Type
(E
)
7898 and then Present
(Underlying_Type
(E
))
7900 Set_Convention
(Underlying_Type
(E
), C
);
7901 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7904 -- A class-wide type should inherit the convention of the specific
7905 -- root type (although this isn't specified clearly by the RM).
7907 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7908 Set_Convention
(Class_Wide_Type
(E
), C
);
7911 -- If the entity is a record type, then check for special case of
7912 -- C_Pass_By_Copy, which is treated the same as C except that the
7913 -- special record flag is set. This convention is only permitted
7914 -- on record types (see AI95-00131).
7916 if Cname
= Name_C_Pass_By_Copy
then
7917 if Is_Record_Type
(E
) then
7918 Set_C_Pass_By_Copy
(Base_Type
(E
));
7919 elsif Is_Incomplete_Or_Private_Type
(E
)
7920 and then Is_Record_Type
(Underlying_Type
(E
))
7922 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7925 ("C_Pass_By_Copy convention allowed only for record type",
7930 -- If the entity is a derived boolean type, check for the special
7931 -- case of convention C, C++, or Fortran, where we consider any
7932 -- nonzero value to represent true.
7934 if Is_Discrete_Type
(E
)
7935 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7941 C
= Convention_Fortran
)
7943 Set_Nonzero_Is_True
(Base_Type
(E
));
7945 end Set_Convention_From_Pragma
;
7949 Comp_Unit
: Unit_Number_Type
;
7954 -- Start of processing for Process_Convention
7957 Check_At_Least_N_Arguments
(2);
7958 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7959 Check_Arg_Is_Identifier
(Arg1
);
7960 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7962 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7963 -- tested again below to set the critical flag).
7965 if Cname
= Name_C_Pass_By_Copy
then
7968 -- Otherwise we must have something in the standard convention list
7970 elsif Is_Convention_Name
(Cname
) then
7971 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7973 -- Otherwise warn on unrecognized convention
7976 if Warn_On_Export_Import
then
7978 ("??unrecognized convention name, C assumed",
7979 Get_Pragma_Arg
(Arg1
));
7985 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7986 Check_Arg_Is_Local_Name
(Arg2
);
7988 Id
:= Get_Pragma_Arg
(Arg2
);
7991 if not Is_Entity_Name
(Id
) then
7992 Error_Pragma_Arg
("entity name required", Arg2
);
7997 -- Set entity to return
8001 -- Ada_Pass_By_Copy special checking
8003 if C
= Convention_Ada_Pass_By_Copy
then
8004 if not Is_First_Subtype
(E
) then
8006 ("convention `Ada_Pass_By_Copy` only allowed for types",
8010 if Is_By_Reference_Type
(E
) then
8012 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
8016 -- Ada_Pass_By_Reference special checking
8018 elsif C
= Convention_Ada_Pass_By_Reference
then
8019 if not Is_First_Subtype
(E
) then
8021 ("convention `Ada_Pass_By_Reference` only allowed for types",
8025 if Is_By_Copy_Type
(E
) then
8027 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
8032 -- Go to renamed subprogram if present, since convention applies to
8033 -- the actual renamed entity, not to the renaming entity. If the
8034 -- subprogram is inherited, go to parent subprogram.
8036 if Is_Subprogram
(E
)
8037 and then Present
(Alias
(E
))
8039 if Nkind
(Parent
(Declaration_Node
(E
))) =
8040 N_Subprogram_Renaming_Declaration
8042 if Scope
(E
) /= Scope
(Alias
(E
)) then
8044 ("cannot apply pragma% to non-local entity&#", E
);
8049 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
8050 N_Private_Extension_Declaration
)
8051 and then Scope
(E
) = Scope
(Alias
(E
))
8055 -- Return the parent subprogram the entity was inherited from
8061 -- Check that we are not applying this to a specless body. Relax this
8062 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
8064 if Is_Subprogram
(E
)
8065 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
8066 and then not Relaxed_RM_Semantics
8069 ("pragma% requires separate spec and must come before body");
8072 -- Check that we are not applying this to a named constant
8074 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
8075 Error_Msg_Name_1
:= Pname
;
8077 ("cannot apply pragma% to named constant!",
8078 Get_Pragma_Arg
(Arg2
));
8080 ("\supply appropriate type for&!", Arg2
);
8083 if Ekind
(E
) = E_Enumeration_Literal
then
8084 Error_Pragma
("enumeration literal not allowed for pragma%");
8087 -- Check for rep item appearing too early or too late
8089 if Etype
(E
) = Any_Type
8090 or else Rep_Item_Too_Early
(E
, N
)
8094 elsif Present
(Underlying_Type
(E
)) then
8095 E
:= Underlying_Type
(E
);
8098 if Rep_Item_Too_Late
(E
, N
) then
8102 if Has_Convention_Pragma
(E
) then
8103 Diagnose_Multiple_Pragmas
(E
);
8105 elsif Convention
(E
) = Convention_Protected
8106 or else Ekind
(Scope
(E
)) = E_Protected_Type
8109 ("a protected operation cannot be given a different convention",
8113 -- For Intrinsic, a subprogram is required
8115 if C
= Convention_Intrinsic
8116 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
8118 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
8120 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
8122 ("second argument of pragma% must be a subprogram", Arg2
);
8126 -- Deal with non-subprogram cases
8128 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
8129 Set_Convention_From_Pragma
(E
);
8133 -- The pragma must apply to a first subtype, but it can also
8134 -- apply to a generic type in a generic formal part, in which
8135 -- case it will also appear in the corresponding instance.
8137 if Is_Generic_Type
(E
) or else In_Instance
then
8140 Check_First_Subtype
(Arg2
);
8143 Set_Convention_From_Pragma
(Base_Type
(E
));
8145 -- For access subprograms, we must set the convention on the
8146 -- internally generated directly designated type as well.
8148 if Ekind
(E
) = E_Access_Subprogram_Type
then
8149 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
8153 -- For the subprogram case, set proper convention for all homonyms
8154 -- in same scope and the same declarative part, i.e. the same
8155 -- compilation unit.
8158 Comp_Unit
:= Get_Source_Unit
(E
);
8159 Set_Convention_From_Pragma
(E
);
8161 -- Treat a pragma Import as an implicit body, and pragma import
8162 -- as implicit reference (for navigation in GPS).
8164 if Prag_Id
= Pragma_Import
then
8165 Generate_Reference
(E
, Id
, 'b');
8167 -- For exported entities we restrict the generation of references
8168 -- to entities exported to foreign languages since entities
8169 -- exported to Ada do not provide further information to GPS and
8170 -- add undesired references to the output of the gnatxref tool.
8172 elsif Prag_Id
= Pragma_Export
8173 and then Convention
(E
) /= Convention_Ada
8175 Generate_Reference
(E
, Id
, 'i');
8178 -- If the pragma comes from an aspect, it only applies to the
8179 -- given entity, not its homonyms.
8181 if From_Aspect_Specification
(N
) then
8182 if C
= Convention_Intrinsic
8183 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
8185 if Is_Fixed_Point_Type
(Etype
(Ent
))
8186 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
8187 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
8190 ("no intrinsic operator available for this fixed-point "
8193 ("\use expression functions with the desired "
8194 & "conversions made explicit", N
);
8201 -- Otherwise Loop through the homonyms of the pragma argument's
8202 -- entity, an apply convention to those in the current scope.
8208 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
8210 -- Ignore entry for which convention is already set
8212 if Has_Convention_Pragma
(E1
) then
8216 if Is_Subprogram
(E1
)
8217 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
8219 and then not Relaxed_RM_Semantics
8221 Set_Has_Completion
(E
); -- to prevent cascaded error
8223 ("pragma% requires separate spec and must come before "
8227 -- Do not set the pragma on inherited operations or on formal
8230 if Comes_From_Source
(E1
)
8231 and then Comp_Unit
= Get_Source_Unit
(E1
)
8232 and then not Is_Formal_Subprogram
(E1
)
8233 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8234 N_Full_Type_Declaration
8236 if Present
(Alias
(E1
))
8237 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8240 ("cannot apply pragma% to non-local entity& declared#",
8244 Set_Convention_From_Pragma
(E1
);
8246 if Prag_Id
= Pragma_Import
then
8247 Generate_Reference
(E1
, Id
, 'b');
8255 end Process_Convention
;
8257 ----------------------------------------
8258 -- Process_Disable_Enable_Atomic_Sync --
8259 ----------------------------------------
8261 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8263 Check_No_Identifiers
;
8264 Check_At_Most_N_Arguments
(1);
8266 -- Modeled internally as
8267 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8272 Pragma_Argument_Associations
=> New_List
(
8273 Make_Pragma_Argument_Association
(Loc
,
8275 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8277 if Present
(Arg1
) then
8278 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8282 end Process_Disable_Enable_Atomic_Sync
;
8284 -------------------------------------------------
8285 -- Process_Extended_Import_Export_Internal_Arg --
8286 -------------------------------------------------
8288 procedure Process_Extended_Import_Export_Internal_Arg
8289 (Arg_Internal
: Node_Id
:= Empty
)
8292 if No
(Arg_Internal
) then
8293 Error_Pragma
("Internal parameter required for pragma%");
8296 if Nkind
(Arg_Internal
) = N_Identifier
then
8299 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8300 and then (Prag_Id
= Pragma_Import_Function
8302 Prag_Id
= Pragma_Export_Function
)
8308 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8311 Check_Arg_Is_Local_Name
(Arg_Internal
);
8312 end Process_Extended_Import_Export_Internal_Arg
;
8314 --------------------------------------------------
8315 -- Process_Extended_Import_Export_Object_Pragma --
8316 --------------------------------------------------
8318 procedure Process_Extended_Import_Export_Object_Pragma
8319 (Arg_Internal
: Node_Id
;
8320 Arg_External
: Node_Id
;
8326 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8327 Def_Id
:= Entity
(Arg_Internal
);
8329 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8331 ("pragma% must designate an object", Arg_Internal
);
8334 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8336 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8339 ("previous Common/Psect_Object applies, pragma % not permitted",
8343 if Rep_Item_Too_Late
(Def_Id
, N
) then
8347 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8349 if Present
(Arg_Size
) then
8350 Check_Arg_Is_External_Name
(Arg_Size
);
8353 -- Export_Object case
8355 if Prag_Id
= Pragma_Export_Object
then
8356 if not Is_Library_Level_Entity
(Def_Id
) then
8358 ("argument for pragma% must be library level entity",
8362 if Ekind
(Current_Scope
) = E_Generic_Package
then
8363 Error_Pragma
("pragma& cannot appear in a generic unit");
8366 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8368 ("exported object must have compile time known size",
8372 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8373 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8375 Set_Exported
(Def_Id
, Arg_Internal
);
8378 -- Import_Object case
8381 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8383 ("cannot use pragma% for task/protected object",
8387 if Ekind
(Def_Id
) = E_Constant
then
8389 ("cannot import a constant", Arg_Internal
);
8392 if Warn_On_Export_Import
8393 and then Has_Discriminants
(Etype
(Def_Id
))
8396 ("imported value must be initialized??", Arg_Internal
);
8399 if Warn_On_Export_Import
8400 and then Is_Access_Type
(Etype
(Def_Id
))
8403 ("cannot import object of an access type??", Arg_Internal
);
8406 if Warn_On_Export_Import
8407 and then Is_Imported
(Def_Id
)
8409 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8411 -- Check for explicit initialization present. Note that an
8412 -- initialization generated by the code generator, e.g. for an
8413 -- access type, does not count here.
8415 elsif Present
(Expression
(Parent
(Def_Id
)))
8418 (Original_Node
(Expression
(Parent
(Def_Id
))))
8420 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8422 ("imported entities cannot be initialized (RM B.1(24))",
8423 "\no initialization allowed for & declared#", Arg1
);
8425 Set_Imported
(Def_Id
);
8426 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8429 end Process_Extended_Import_Export_Object_Pragma
;
8431 ------------------------------------------------------
8432 -- Process_Extended_Import_Export_Subprogram_Pragma --
8433 ------------------------------------------------------
8435 procedure Process_Extended_Import_Export_Subprogram_Pragma
8436 (Arg_Internal
: Node_Id
;
8437 Arg_External
: Node_Id
;
8438 Arg_Parameter_Types
: Node_Id
;
8439 Arg_Result_Type
: Node_Id
:= Empty
;
8440 Arg_Mechanism
: Node_Id
;
8441 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8447 Ambiguous
: Boolean;
8450 function Same_Base_Type
8452 Formal
: Entity_Id
) return Boolean;
8453 -- Determines if Ptype references the type of Formal. Note that only
8454 -- the base types need to match according to the spec. Ptype here is
8455 -- the argument from the pragma, which is either a type name, or an
8456 -- access attribute.
8458 --------------------
8459 -- Same_Base_Type --
8460 --------------------
8462 function Same_Base_Type
8464 Formal
: Entity_Id
) return Boolean
8466 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8470 -- Case where pragma argument is typ'Access
8472 if Nkind
(Ptype
) = N_Attribute_Reference
8473 and then Attribute_Name
(Ptype
) = Name_Access
8475 Pref
:= Prefix
(Ptype
);
8478 if not Is_Entity_Name
(Pref
)
8479 or else Entity
(Pref
) = Any_Type
8484 -- We have a match if the corresponding argument is of an
8485 -- anonymous access type, and its designated type matches the
8486 -- type of the prefix of the access attribute
8488 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8489 and then Base_Type
(Entity
(Pref
)) =
8490 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8492 -- Case where pragma argument is a type name
8497 if not Is_Entity_Name
(Ptype
)
8498 or else Entity
(Ptype
) = Any_Type
8503 -- We have a match if the corresponding argument is of the type
8504 -- given in the pragma (comparing base types)
8506 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8510 -- Start of processing for
8511 -- Process_Extended_Import_Export_Subprogram_Pragma
8514 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8518 -- Loop through homonyms (overloadings) of the entity
8520 Hom_Id
:= Entity
(Arg_Internal
);
8521 while Present
(Hom_Id
) loop
8522 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8524 -- We need a subprogram in the current scope
8526 if not Is_Subprogram
(Def_Id
)
8527 or else Scope
(Def_Id
) /= Current_Scope
8534 -- Pragma cannot apply to subprogram body
8536 if Is_Subprogram
(Def_Id
)
8537 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8541 ("pragma% requires separate spec and must come before "
8545 -- Test result type if given, note that the result type
8546 -- parameter can only be present for the function cases.
8548 if Present
(Arg_Result_Type
)
8549 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8553 elsif Etype
(Def_Id
) /= Standard_Void_Type
8554 and then Nam_In
(Pname
, Name_Export_Procedure
,
8555 Name_Import_Procedure
)
8559 -- Test parameter types if given. Note that this parameter has
8560 -- not been analyzed (and must not be, since it is semantic
8561 -- nonsense), so we get it as the parser left it.
8563 elsif Present
(Arg_Parameter_Types
) then
8564 Check_Matching_Types
: declare
8569 Formal
:= First_Formal
(Def_Id
);
8571 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8572 if Present
(Formal
) then
8576 -- A list of one type, e.g. (List) is parsed as a
8577 -- parenthesized expression.
8579 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8580 and then Paren_Count
(Arg_Parameter_Types
) = 1
8583 or else Present
(Next_Formal
(Formal
))
8588 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8591 -- A list of more than one type is parsed as a aggregate
8593 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8594 and then Paren_Count
(Arg_Parameter_Types
) = 0
8596 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8597 while Present
(Ptype
) or else Present
(Formal
) loop
8600 or else not Same_Base_Type
(Ptype
, Formal
)
8605 Next_Formal
(Formal
);
8610 -- Anything else is of the wrong form
8614 ("wrong form for Parameter_Types parameter",
8615 Arg_Parameter_Types
);
8617 end Check_Matching_Types
;
8620 -- Match is now False if the entry we found did not match
8621 -- either a supplied Parameter_Types or Result_Types argument
8627 -- Ambiguous case, the flag Ambiguous shows if we already
8628 -- detected this and output the initial messages.
8631 if not Ambiguous
then
8633 Error_Msg_Name_1
:= Pname
;
8635 ("pragma% does not uniquely identify subprogram!",
8637 Error_Msg_Sloc
:= Sloc
(Ent
);
8638 Error_Msg_N
("matching subprogram #!", N
);
8642 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8643 Error_Msg_N
("matching subprogram #!", N
);
8648 Hom_Id
:= Homonym
(Hom_Id
);
8651 -- See if we found an entry
8654 if not Ambiguous
then
8655 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8657 ("pragma% cannot be given for generic subprogram");
8660 ("pragma% does not identify local subprogram");
8667 -- Import pragmas must be for imported entities
8669 if Prag_Id
= Pragma_Import_Function
8671 Prag_Id
= Pragma_Import_Procedure
8673 Prag_Id
= Pragma_Import_Valued_Procedure
8675 if not Is_Imported
(Ent
) then
8677 ("pragma Import or Interface must precede pragma%");
8680 -- Here we have the Export case which can set the entity as exported
8682 -- But does not do so if the specified external name is null, since
8683 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8684 -- compatible) to request no external name.
8686 elsif Nkind
(Arg_External
) = N_String_Literal
8687 and then String_Length
(Strval
(Arg_External
)) = 0
8691 -- In all other cases, set entity as exported
8694 Set_Exported
(Ent
, Arg_Internal
);
8697 -- Special processing for Valued_Procedure cases
8699 if Prag_Id
= Pragma_Import_Valued_Procedure
8701 Prag_Id
= Pragma_Export_Valued_Procedure
8703 Formal
:= First_Formal
(Ent
);
8706 Error_Pragma
("at least one parameter required for pragma%");
8708 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8709 Error_Pragma
("first parameter must have mode out for pragma%");
8712 Set_Is_Valued_Procedure
(Ent
);
8716 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8718 -- Process Result_Mechanism argument if present. We have already
8719 -- checked that this is only allowed for the function case.
8721 if Present
(Arg_Result_Mechanism
) then
8722 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8725 -- Process Mechanism parameter if present. Note that this parameter
8726 -- is not analyzed, and must not be analyzed since it is semantic
8727 -- nonsense, so we get it in exactly as the parser left it.
8729 if Present
(Arg_Mechanism
) then
8737 -- A single mechanism association without a formal parameter
8738 -- name is parsed as a parenthesized expression. All other
8739 -- cases are parsed as aggregates, so we rewrite the single
8740 -- parameter case as an aggregate for consistency.
8742 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8743 and then Paren_Count
(Arg_Mechanism
) = 1
8745 Rewrite
(Arg_Mechanism
,
8746 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8747 Expressions
=> New_List
(
8748 Relocate_Node
(Arg_Mechanism
))));
8751 -- Case of only mechanism name given, applies to all formals
8753 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8754 Formal
:= First_Formal
(Ent
);
8755 while Present
(Formal
) loop
8756 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8757 Next_Formal
(Formal
);
8760 -- Case of list of mechanism associations given
8763 if Null_Record_Present
(Arg_Mechanism
) then
8765 ("inappropriate form for Mechanism parameter",
8769 -- Deal with positional ones first
8771 Formal
:= First_Formal
(Ent
);
8773 if Present
(Expressions
(Arg_Mechanism
)) then
8774 Mname
:= First
(Expressions
(Arg_Mechanism
));
8775 while Present
(Mname
) loop
8778 ("too many mechanism associations", Mname
);
8781 Set_Mechanism_Value
(Formal
, Mname
);
8782 Next_Formal
(Formal
);
8787 -- Deal with named entries
8789 if Present
(Component_Associations
(Arg_Mechanism
)) then
8790 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8791 while Present
(Massoc
) loop
8792 Choice
:= First
(Choices
(Massoc
));
8794 if Nkind
(Choice
) /= N_Identifier
8795 or else Present
(Next
(Choice
))
8798 ("incorrect form for mechanism association",
8802 Formal
:= First_Formal
(Ent
);
8806 ("parameter name & not present", Choice
);
8809 if Chars
(Choice
) = Chars
(Formal
) then
8811 (Formal
, Expression
(Massoc
));
8813 -- Set entity on identifier (needed by ASIS)
8815 Set_Entity
(Choice
, Formal
);
8820 Next_Formal
(Formal
);
8829 end Process_Extended_Import_Export_Subprogram_Pragma
;
8831 --------------------------
8832 -- Process_Generic_List --
8833 --------------------------
8835 procedure Process_Generic_List
is
8840 Check_No_Identifiers
;
8841 Check_At_Least_N_Arguments
(1);
8843 -- Check all arguments are names of generic units or instances
8846 while Present
(Arg
) loop
8847 Exp
:= Get_Pragma_Arg
(Arg
);
8850 if not Is_Entity_Name
(Exp
)
8852 (not Is_Generic_Instance
(Entity
(Exp
))
8854 not Is_Generic_Unit
(Entity
(Exp
)))
8857 ("pragma% argument must be name of generic unit/instance",
8863 end Process_Generic_List
;
8865 ------------------------------------
8866 -- Process_Import_Predefined_Type --
8867 ------------------------------------
8869 procedure Process_Import_Predefined_Type
is
8870 Loc
: constant Source_Ptr
:= Sloc
(N
);
8872 Ftyp
: Node_Id
:= Empty
;
8878 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8880 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8881 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8885 Ftyp
:= Node
(Elmt
);
8887 if Present
(Ftyp
) then
8889 -- Don't build a derived type declaration, because predefined C
8890 -- types have no declaration anywhere, so cannot really be named.
8891 -- Instead build a full type declaration, starting with an
8892 -- appropriate type definition is built
8894 if Is_Floating_Point_Type
(Ftyp
) then
8895 Def
:= Make_Floating_Point_Definition
(Loc
,
8896 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8897 Make_Real_Range_Specification
(Loc
,
8898 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8899 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8901 -- Should never have a predefined type we cannot handle
8904 raise Program_Error
;
8907 -- Build and insert a Full_Type_Declaration, which will be
8908 -- analyzed as soon as this list entry has been analyzed.
8910 Decl
:= Make_Full_Type_Declaration
(Loc
,
8911 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8912 Type_Definition
=> Def
);
8914 Insert_After
(N
, Decl
);
8915 Mark_Rewrite_Insertion
(Decl
);
8918 Error_Pragma_Arg
("no matching type found for pragma%",
8921 end Process_Import_Predefined_Type
;
8923 ---------------------------------
8924 -- Process_Import_Or_Interface --
8925 ---------------------------------
8927 procedure Process_Import_Or_Interface
is
8933 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8934 -- pragma Import (Entity, "external name");
8936 if Relaxed_RM_Semantics
8937 and then Arg_Count
= 2
8938 and then Prag_Id
= Pragma_Import
8939 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8942 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8945 if not Is_Entity_Name
(Def_Id
) then
8946 Error_Pragma_Arg
("entity name required", Arg1
);
8949 Def_Id
:= Entity
(Def_Id
);
8950 Kill_Size_Check_Code
(Def_Id
);
8951 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8954 Process_Convention
(C
, Def_Id
);
8956 -- A pragma that applies to a Ghost entity becomes Ghost for the
8957 -- purposes of legality checks and removal of ignored Ghost code.
8959 Mark_Ghost_Pragma
(N
, Def_Id
);
8960 Kill_Size_Check_Code
(Def_Id
);
8961 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8964 -- Various error checks
8966 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8968 -- We do not permit Import to apply to a renaming declaration
8970 if Present
(Renamed_Object
(Def_Id
)) then
8972 ("pragma% not allowed for object renaming", Arg2
);
8974 -- User initialization is not allowed for imported object, but
8975 -- the object declaration may contain a default initialization,
8976 -- that will be discarded. Note that an explicit initialization
8977 -- only counts if it comes from source, otherwise it is simply
8978 -- the code generator making an implicit initialization explicit.
8980 elsif Present
(Expression
(Parent
(Def_Id
)))
8981 and then Comes_From_Source
8982 (Original_Node
(Expression
(Parent
(Def_Id
))))
8984 -- Set imported flag to prevent cascaded errors
8986 Set_Is_Imported
(Def_Id
);
8988 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8990 ("no initialization allowed for declaration of& #",
8991 "\imported entities cannot be initialized (RM B.1(24))",
8995 -- If the pragma comes from an aspect specification the
8996 -- Is_Imported flag has already been set.
8998 if not From_Aspect_Specification
(N
) then
8999 Set_Imported
(Def_Id
);
9002 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9004 -- Note that we do not set Is_Public here. That's because we
9005 -- only want to set it if there is no address clause, and we
9006 -- don't know that yet, so we delay that processing till
9009 -- pragma Import completes deferred constants
9011 if Ekind
(Def_Id
) = E_Constant
then
9012 Set_Has_Completion
(Def_Id
);
9015 -- It is not possible to import a constant of an unconstrained
9016 -- array type (e.g. string) because there is no simple way to
9017 -- write a meaningful subtype for it.
9019 if Is_Array_Type
(Etype
(Def_Id
))
9020 and then not Is_Constrained
(Etype
(Def_Id
))
9023 ("imported constant& must have a constrained subtype",
9028 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9030 -- If the name is overloaded, pragma applies to all of the denoted
9031 -- entities in the same declarative part, unless the pragma comes
9032 -- from an aspect specification or was generated by the compiler
9033 -- (such as for pragma Provide_Shift_Operators).
9036 while Present
(Hom_Id
) loop
9038 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
9040 -- Ignore inherited subprograms because the pragma will apply
9041 -- to the parent operation, which is the one called.
9043 if Is_Overloadable
(Def_Id
)
9044 and then Present
(Alias
(Def_Id
))
9048 -- If it is not a subprogram, it must be in an outer scope and
9049 -- pragma does not apply.
9051 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
9054 -- The pragma does not apply to primitives of interfaces
9056 elsif Is_Dispatching_Operation
(Def_Id
)
9057 and then Present
(Find_Dispatching_Type
(Def_Id
))
9058 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
9062 -- Verify that the homonym is in the same declarative part (not
9063 -- just the same scope). If the pragma comes from an aspect
9064 -- specification we know that it is part of the declaration.
9066 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
9067 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
9068 and then not From_Aspect_Specification
(N
)
9073 -- If the pragma comes from an aspect specification the
9074 -- Is_Imported flag has already been set.
9076 if not From_Aspect_Specification
(N
) then
9077 Set_Imported
(Def_Id
);
9080 -- Reject an Import applied to an abstract subprogram
9082 if Is_Subprogram
(Def_Id
)
9083 and then Is_Abstract_Subprogram
(Def_Id
)
9085 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9087 ("cannot import abstract subprogram& declared#",
9091 -- Special processing for Convention_Intrinsic
9093 if C
= Convention_Intrinsic
then
9095 -- Link_Name argument not allowed for intrinsic
9099 Set_Is_Intrinsic_Subprogram
(Def_Id
);
9101 -- If no external name is present, then check that this
9102 -- is a valid intrinsic subprogram. If an external name
9103 -- is present, then this is handled by the back end.
9106 Check_Intrinsic_Subprogram
9107 (Def_Id
, Get_Pragma_Arg
(Arg2
));
9111 -- Verify that the subprogram does not have a completion
9112 -- through a renaming declaration. For other completions the
9113 -- pragma appears as a too late representation.
9116 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
9120 and then Nkind
(Decl
) = N_Subprogram_Declaration
9121 and then Present
(Corresponding_Body
(Decl
))
9122 and then Nkind
(Unit_Declaration_Node
9123 (Corresponding_Body
(Decl
))) =
9124 N_Subprogram_Renaming_Declaration
9126 Error_Msg_Sloc
:= Sloc
(Def_Id
);
9128 ("cannot import&, renaming already provided for "
9129 & "declaration #", N
, Def_Id
);
9133 -- If the pragma comes from an aspect specification, there
9134 -- must be an Import aspect specified as well. In the rare
9135 -- case where Import is set to False, the suprogram needs to
9136 -- have a local completion.
9139 Imp_Aspect
: constant Node_Id
:=
9140 Find_Aspect
(Def_Id
, Aspect_Import
);
9144 if Present
(Imp_Aspect
)
9145 and then Present
(Expression
(Imp_Aspect
))
9147 Expr
:= Expression
(Imp_Aspect
);
9148 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
9150 if Is_Entity_Name
(Expr
)
9151 and then Entity
(Expr
) = Standard_True
9153 Set_Has_Completion
(Def_Id
);
9156 -- If there is no expression, the default is True, as for
9157 -- all boolean aspects. Same for the older pragma.
9160 Set_Has_Completion
(Def_Id
);
9164 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
9167 if Is_Compilation_Unit
(Hom_Id
) then
9169 -- Its possible homonyms are not affected by the pragma.
9170 -- Such homonyms might be present in the context of other
9171 -- units being compiled.
9175 elsif From_Aspect_Specification
(N
) then
9178 -- If the pragma was created by the compiler, then we don't
9179 -- want it to apply to other homonyms. This kind of case can
9180 -- occur when using pragma Provide_Shift_Operators, which
9181 -- generates implicit shift and rotate operators with Import
9182 -- pragmas that might apply to earlier explicit or implicit
9183 -- declarations marked with Import (for example, coming from
9184 -- an earlier pragma Provide_Shift_Operators for another type),
9185 -- and we don't generally want other homonyms being treated
9186 -- as imported or the pragma flagged as an illegal duplicate.
9188 elsif not Comes_From_Source
(N
) then
9192 Hom_Id
:= Homonym
(Hom_Id
);
9196 -- Import a CPP class
9198 elsif C
= Convention_CPP
9199 and then (Is_Record_Type
(Def_Id
)
9200 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
9202 if Ekind
(Def_Id
) = E_Incomplete_Type
then
9203 if Present
(Full_View
(Def_Id
)) then
9204 Def_Id
:= Full_View
(Def_Id
);
9208 ("cannot import 'C'P'P type before full declaration seen",
9209 Get_Pragma_Arg
(Arg2
));
9211 -- Although we have reported the error we decorate it as
9212 -- CPP_Class to avoid reporting spurious errors
9214 Set_Is_CPP_Class
(Def_Id
);
9219 -- Types treated as CPP classes must be declared limited (note:
9220 -- this used to be a warning but there is no real benefit to it
9221 -- since we did effectively intend to treat the type as limited
9224 if not Is_Limited_Type
(Def_Id
) then
9226 ("imported 'C'P'P type must be limited",
9227 Get_Pragma_Arg
(Arg2
));
9230 if Etype
(Def_Id
) /= Def_Id
9231 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9233 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9236 Set_Is_CPP_Class
(Def_Id
);
9238 -- Imported CPP types must not have discriminants (because C++
9239 -- classes do not have discriminants).
9241 if Has_Discriminants
(Def_Id
) then
9243 ("imported 'C'P'P type cannot have discriminants",
9244 First
(Discriminant_Specifications
9245 (Declaration_Node
(Def_Id
))));
9248 -- Check that components of imported CPP types do not have default
9249 -- expressions. For private types this check is performed when the
9250 -- full view is analyzed (see Process_Full_View).
9252 if not Is_Private_Type
(Def_Id
) then
9253 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9256 -- Import a CPP exception
9258 elsif C
= Convention_CPP
9259 and then Ekind
(Def_Id
) = E_Exception
9263 ("'External_'Name arguments is required for 'Cpp exception",
9266 -- As only a string is allowed, Check_Arg_Is_External_Name
9269 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9272 if Present
(Arg4
) then
9274 ("Link_Name argument not allowed for imported Cpp exception",
9278 -- Do not call Set_Interface_Name as the name of the exception
9279 -- shouldn't be modified (and in particular it shouldn't be
9280 -- the External_Name). For exceptions, the External_Name is the
9281 -- name of the RTTI structure.
9283 -- ??? Emit an error if pragma Import/Export_Exception is present
9285 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9287 Check_Arg_Count
(3);
9288 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9290 Process_Import_Predefined_Type
;
9294 ("second argument of pragma% must be object, subprogram "
9295 & "or incomplete type",
9299 -- If this pragma applies to a compilation unit, then the unit, which
9300 -- is a subprogram, does not require (or allow) a body. We also do
9301 -- not need to elaborate imported procedures.
9303 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9305 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9307 Set_Body_Required
(Cunit
, False);
9310 end Process_Import_Or_Interface
;
9312 --------------------
9313 -- Process_Inline --
9314 --------------------
9316 procedure Process_Inline
(Status
: Inline_Status
) is
9323 Ghost_Error_Posted
: Boolean := False;
9324 -- Flag set when an error concerning the illegal mix of Ghost and
9325 -- non-Ghost subprograms is emitted.
9327 Ghost_Id
: Entity_Id
:= Empty
;
9328 -- The entity of the first Ghost subprogram encountered while
9329 -- processing the arguments of the pragma.
9331 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9332 -- Verify the placement of pragma Inline_Always with respect to the
9333 -- initial declaration of subprogram Spec_Id.
9335 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9336 -- Returns True if it can be determined at this stage that inlining
9337 -- is not possible, for example if the body is available and contains
9338 -- exception handlers, we prevent inlining, since otherwise we can
9339 -- get undefined symbols at link time. This function also emits a
9340 -- warning if the pragma appears too late.
9342 -- ??? is business with link symbols still valid, or does it relate
9343 -- to front end ZCX which is being phased out ???
9345 procedure Make_Inline
(Subp
: Entity_Id
);
9346 -- Subp is the defining unit name of the subprogram declaration. If
9347 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9348 -- the corresponding body, if there is one present.
9350 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9351 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9352 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9354 -----------------------------------
9355 -- Check_Inline_Always_Placement --
9356 -----------------------------------
9358 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9359 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9361 function Compilation_Unit_OK
return Boolean;
9362 pragma Inline
(Compilation_Unit_OK
);
9363 -- Determine whether pragma Inline_Always applies to a compatible
9364 -- compilation unit denoted by Spec_Id.
9366 function Declarative_List_OK
return Boolean;
9367 pragma Inline
(Declarative_List_OK
);
9368 -- Determine whether the initial declaration of subprogram Spec_Id
9369 -- and the pragma appear in compatible declarative lists.
9371 function Subprogram_Body_OK
return Boolean;
9372 pragma Inline
(Subprogram_Body_OK
);
9373 -- Determine whether pragma Inline_Always applies to a compatible
9374 -- subprogram body denoted by Spec_Id.
9376 -------------------------
9377 -- Compilation_Unit_OK --
9378 -------------------------
9380 function Compilation_Unit_OK
return Boolean is
9381 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9384 -- The pragma appears after the initial declaration of a
9385 -- compilation unit.
9387 -- procedure Comp_Unit;
9388 -- pragma Inline_Always (Comp_Unit);
9390 -- Note that for compatibility reasons, the following case is
9393 -- procedure Stand_Alone_Body_Comp_Unit is
9395 -- end Stand_Alone_Body_Comp_Unit;
9396 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9399 Nkind
(Comp_Unit
) = N_Compilation_Unit
9400 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9401 and then Is_List_Member
(N
)
9402 and then List_Containing
(N
) =
9403 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9404 end Compilation_Unit_OK
;
9406 -------------------------
9407 -- Declarative_List_OK --
9408 -------------------------
9410 function Declarative_List_OK
return Boolean is
9411 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9413 Init_Decl
: Node_Id
;
9414 Init_List
: List_Id
;
9415 Prag_List
: List_Id
;
9418 -- Determine the proper initial declaration. In general this is
9419 -- the declaration node of the subprogram except when the input
9420 -- denotes a generic instantiation.
9422 -- procedure Inst is new Gen;
9423 -- pragma Inline_Always (Inst);
9425 -- In this case the original subprogram is moved inside an
9426 -- anonymous package while pragma Inline_Always remains at the
9427 -- level of the anonymous package. Use the declaration of the
9428 -- package because it reflects the placement of the original
9431 -- package Anon_Pack is
9432 -- procedure Inst is ... end Inst; -- original
9435 -- procedure Inst renames Anon_Pack.Inst;
9436 -- pragma Inline_Always (Inst);
9438 if Is_Generic_Instance
(Spec_Id
) then
9439 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9440 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9442 Init_Decl
:= Spec_Decl
;
9445 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9446 Init_List
:= List_Containing
(Init_Decl
);
9447 Prag_List
:= List_Containing
(N
);
9449 -- The pragma and then initial declaration appear within the
9450 -- same declarative list.
9452 if Init_List
= Prag_List
then
9455 -- A special case of the above is when both the pragma and
9456 -- the initial declaration appear in different lists of a
9457 -- package spec, protected definition, or a task definition.
9462 -- pragma Inline_Always (Proc);
9465 elsif Nkind_In
(Context
, N_Package_Specification
,
9466 N_Protected_Definition
,
9468 and then Init_List
= Visible_Declarations
(Context
)
9469 and then Prag_List
= Private_Declarations
(Context
)
9476 end Declarative_List_OK
;
9478 ------------------------
9479 -- Subprogram_Body_OK --
9480 ------------------------
9482 function Subprogram_Body_OK
return Boolean is
9483 Body_Decl
: Node_Id
;
9486 -- The pragma appears within the declarative list of a stand-
9487 -- alone subprogram body.
9489 -- procedure Stand_Alone_Body is
9490 -- pragma Inline_Always (Stand_Alone_Body);
9493 -- end Stand_Alone_Body;
9495 -- The compiler creates a dummy spec in this case, however the
9496 -- pragma remains within the declarative list of the body.
9498 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9499 and then not Comes_From_Source
(Spec_Decl
)
9500 and then Present
(Corresponding_Body
(Spec_Decl
))
9503 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9505 if Present
(Declarations
(Body_Decl
))
9506 and then Is_List_Member
(N
)
9507 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9514 end Subprogram_Body_OK
;
9516 -- Start of processing for Check_Inline_Always_Placement
9519 -- This check is relevant only for pragma Inline_Always
9521 if Pname
/= Name_Inline_Always
then
9524 -- Nothing to do when the pragma is internally generated on the
9525 -- assumption that it is properly placed.
9527 elsif not Comes_From_Source
(N
) then
9530 -- Nothing to do for internally generated subprograms that act
9531 -- as accidental homonyms of a source subprogram being inlined.
9533 elsif not Comes_From_Source
(Spec_Id
) then
9536 -- Nothing to do for generic formal subprograms that act as
9537 -- homonyms of another source subprogram being inlined.
9539 elsif Is_Formal_Subprogram
(Spec_Id
) then
9542 elsif Compilation_Unit_OK
9543 or else Declarative_List_OK
9544 or else Subprogram_Body_OK
9549 -- At this point it is known that the pragma applies to or appears
9550 -- within a completing body, a completing stub, or a subunit.
9552 Error_Msg_Name_1
:= Pname
;
9553 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9554 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9557 ("pragma % must appear on initial declaration of subprogram "
9558 & "% defined #", N
);
9559 end Check_Inline_Always_Placement
;
9561 ---------------------------
9562 -- Inlining_Not_Possible --
9563 ---------------------------
9565 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9566 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9570 if Nkind
(Decl
) = N_Subprogram_Body
then
9571 Stats
:= Handled_Statement_Sequence
(Decl
);
9572 return Present
(Exception_Handlers
(Stats
))
9573 or else Present
(At_End_Proc
(Stats
));
9575 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9576 and then Present
(Corresponding_Body
(Decl
))
9578 if Analyzed
(Corresponding_Body
(Decl
)) then
9579 Error_Msg_N
("pragma appears too late, ignored??", N
);
9582 -- If the subprogram is a renaming as body, the body is just a
9583 -- call to the renamed subprogram, and inlining is trivially
9587 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9588 N_Subprogram_Renaming_Declaration
9594 Handled_Statement_Sequence
9595 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9598 Present
(Exception_Handlers
(Stats
))
9599 or else Present
(At_End_Proc
(Stats
));
9603 -- If body is not available, assume the best, the check is
9604 -- performed again when compiling enclosing package bodies.
9608 end Inlining_Not_Possible
;
9614 procedure Make_Inline
(Subp
: Entity_Id
) is
9615 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9616 Inner_Subp
: Entity_Id
:= Subp
;
9619 -- Ignore if bad type, avoid cascaded error
9621 if Etype
(Subp
) = Any_Type
then
9625 -- If inlining is not possible, for now do not treat as an error
9627 elsif Status
/= Suppressed
9628 and then Front_End_Inlining
9629 and then Inlining_Not_Possible
(Subp
)
9634 -- Here we have a candidate for inlining, but we must exclude
9635 -- derived operations. Otherwise we would end up trying to inline
9636 -- a phantom declaration, and the result would be to drag in a
9637 -- body which has no direct inlining associated with it. That
9638 -- would not only be inefficient but would also result in the
9639 -- backend doing cross-unit inlining in cases where it was
9640 -- definitely inappropriate to do so.
9642 -- However, a simple Comes_From_Source test is insufficient, since
9643 -- we do want to allow inlining of generic instances which also do
9644 -- not come from source. We also need to recognize specs generated
9645 -- by the front-end for bodies that carry the pragma. Finally,
9646 -- predefined operators do not come from source but are not
9647 -- inlineable either.
9649 elsif Is_Generic_Instance
(Subp
)
9650 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9654 elsif not Comes_From_Source
(Subp
)
9655 and then Scope
(Subp
) /= Standard_Standard
9661 -- The referenced entity must either be the enclosing entity, or
9662 -- an entity declared within the current open scope.
9664 if Present
(Scope
(Subp
))
9665 and then Scope
(Subp
) /= Current_Scope
9666 and then Subp
/= Current_Scope
9669 ("argument of% must be entity in current scope", Assoc
);
9673 -- Processing for procedure, operator or function. If subprogram
9674 -- is aliased (as for an instance) indicate that the renamed
9675 -- entity (if declared in the same unit) is inlined.
9676 -- If this is the anonymous subprogram created for a subprogram
9677 -- instance, the inlining applies to it directly. Otherwise we
9678 -- retrieve it as the alias of the visible subprogram instance.
9680 if Is_Subprogram
(Subp
) then
9682 -- Ensure that pragma Inline_Always is associated with the
9683 -- initial declaration of the subprogram.
9685 Check_Inline_Always_Placement
(Subp
);
9687 if Is_Wrapper_Package
(Scope
(Subp
)) then
9690 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9693 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9694 Set_Inline_Flags
(Inner_Subp
);
9696 Decl
:= Parent
(Parent
(Inner_Subp
));
9698 if Nkind
(Decl
) = N_Subprogram_Declaration
9699 and then Present
(Corresponding_Body
(Decl
))
9701 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9703 elsif Is_Generic_Instance
(Subp
)
9704 and then Comes_From_Source
(Subp
)
9706 -- Indicate that the body needs to be created for
9707 -- inlining subsequent calls. The instantiation node
9708 -- follows the declaration of the wrapper package
9709 -- created for it. The subprogram that requires the
9710 -- body is the anonymous one in the wrapper package.
9712 if Scope
(Subp
) /= Standard_Standard
9714 Need_Subprogram_Instance_Body
9715 (Next
(Unit_Declaration_Node
9716 (Scope
(Alias
(Subp
)))), Subp
)
9721 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9722 -- appear in a formal part to apply to a formal subprogram.
9723 -- Do not apply check within an instance or a formal package
9724 -- the test will have been applied to the original generic.
9726 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9727 and then List_Containing
(Decl
) = List_Containing
(N
)
9728 and then not In_Instance
9731 ("Inline cannot apply to a formal subprogram", N
);
9733 -- If Subp is a renaming, it is the renamed entity that
9734 -- will appear in any call, and be inlined. However, for
9735 -- ASIS uses it is convenient to indicate that the renaming
9736 -- itself is an inlined subprogram, so that some gnatcheck
9737 -- rules can be applied in the absence of expansion.
9739 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9740 Set_Inline_Flags
(Subp
);
9746 -- For a generic subprogram set flag as well, for use at the point
9747 -- of instantiation, to determine whether the body should be
9750 elsif Is_Generic_Subprogram
(Subp
) then
9751 Set_Inline_Flags
(Subp
);
9754 -- Literals are by definition inlined
9756 elsif Kind
= E_Enumeration_Literal
then
9759 -- Anything else is an error
9763 ("expect subprogram name for pragma%", Assoc
);
9767 ----------------------
9768 -- Set_Inline_Flags --
9769 ----------------------
9771 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9773 -- First set the Has_Pragma_XXX flags and issue the appropriate
9774 -- errors and warnings for suspicious combinations.
9776 if Prag_Id
= Pragma_No_Inline
then
9777 if Has_Pragma_Inline_Always
(Subp
) then
9779 ("Inline_Always and No_Inline are mutually exclusive", N
);
9780 elsif Has_Pragma_Inline
(Subp
) then
9782 ("Inline and No_Inline both specified for& ??",
9783 N
, Entity
(Subp_Id
));
9786 Set_Has_Pragma_No_Inline
(Subp
);
9788 if Prag_Id
= Pragma_Inline_Always
then
9789 if Has_Pragma_No_Inline
(Subp
) then
9791 ("Inline_Always and No_Inline are mutually exclusive",
9795 Set_Has_Pragma_Inline_Always
(Subp
);
9797 if Has_Pragma_No_Inline
(Subp
) then
9799 ("Inline and No_Inline both specified for& ??",
9800 N
, Entity
(Subp_Id
));
9804 Set_Has_Pragma_Inline
(Subp
);
9807 -- Then adjust the Is_Inlined flag. It can never be set if the
9808 -- subprogram is subject to pragma No_Inline.
9812 Set_Is_Inlined
(Subp
, False);
9818 if not Has_Pragma_No_Inline
(Subp
) then
9819 Set_Is_Inlined
(Subp
, True);
9823 -- A pragma that applies to a Ghost entity becomes Ghost for the
9824 -- purposes of legality checks and removal of ignored Ghost code.
9826 Mark_Ghost_Pragma
(N
, Subp
);
9828 -- Capture the entity of the first Ghost subprogram being
9829 -- processed for error detection purposes.
9831 if Is_Ghost_Entity
(Subp
) then
9832 if No
(Ghost_Id
) then
9836 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9837 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9839 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9840 Ghost_Error_Posted
:= True;
9842 Error_Msg_Name_1
:= Pname
;
9844 ("pragma % cannot mention ghost and non-ghost subprograms",
9847 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9848 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9850 Error_Msg_Sloc
:= Sloc
(Subp
);
9851 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9853 end Set_Inline_Flags
;
9855 -- Start of processing for Process_Inline
9858 Check_No_Identifiers
;
9859 Check_At_Least_N_Arguments
(1);
9861 if Status
= Enabled
then
9862 Inline_Processing_Required
:= True;
9866 while Present
(Assoc
) loop
9867 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9871 if Is_Entity_Name
(Subp_Id
) then
9872 Subp
:= Entity
(Subp_Id
);
9874 if Subp
= Any_Id
then
9876 -- If previous error, avoid cascaded errors
9878 Check_Error_Detected
;
9884 -- For the pragma case, climb homonym chain. This is
9885 -- what implements allowing the pragma in the renaming
9886 -- case, with the result applying to the ancestors, and
9887 -- also allows Inline to apply to all previous homonyms.
9889 if not From_Aspect_Specification
(N
) then
9890 while Present
(Homonym
(Subp
))
9891 and then Scope
(Homonym
(Subp
)) = Current_Scope
9893 Make_Inline
(Homonym
(Subp
));
9894 Subp
:= Homonym
(Subp
);
9901 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9907 -- If the context is a package declaration, the pragma indicates
9908 -- that inlining will require the presence of the corresponding
9909 -- body. (this may be further refined).
9912 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9913 N_Package_Declaration
9915 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9919 ----------------------------
9920 -- Process_Interface_Name --
9921 ----------------------------
9923 procedure Process_Interface_Name
9924 (Subprogram_Def
: Entity_Id
;
9931 String_Val
: String_Id
;
9933 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9934 -- SN is a string literal node for an interface name. This routine
9935 -- performs some minimal checks that the name is reasonable. In
9936 -- particular that no spaces or other obviously incorrect characters
9937 -- appear. This is only a warning, since any characters are allowed.
9939 ----------------------------------
9940 -- Check_Form_Of_Interface_Name --
9941 ----------------------------------
9943 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9944 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9945 SL
: constant Nat
:= String_Length
(S
);
9950 Error_Msg_N
("interface name cannot be null string", SN
);
9953 for J
in 1 .. SL
loop
9954 C
:= Get_String_Char
(S
, J
);
9956 -- Look for dubious character and issue unconditional warning.
9957 -- Definitely dubious if not in character range.
9959 if not In_Character_Range
(C
)
9961 -- Commas, spaces and (back)slashes are dubious
9963 or else Get_Character
(C
) = ','
9964 or else Get_Character
(C
) = '\'
9965 or else Get_Character
(C
) = ' '
9966 or else Get_Character
(C
) = '/'
9969 ("??interface name contains illegal character",
9970 Sloc
(SN
) + Source_Ptr
(J
));
9973 end Check_Form_Of_Interface_Name
;
9975 -- Start of processing for Process_Interface_Name
9978 -- If we are looking at a pragma that comes from an aspect then it
9979 -- needs to have its corresponding aspect argument expressions
9980 -- analyzed in addition to the generated pragma so that aspects
9981 -- within generic units get properly resolved.
9983 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9985 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9993 -- Obtain all interfacing aspects used to construct the pragma
9995 Get_Interfacing_Aspects
9996 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9998 -- Analyze the expression of aspect External_Name
10000 if Present
(EN
) then
10001 Analyze
(Expression
(EN
));
10004 -- Analyze the expressio of aspect Link_Name
10006 if Present
(LN
) then
10007 Analyze
(Expression
(LN
));
10012 if No
(Link_Arg
) then
10013 if No
(Ext_Arg
) then
10016 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
10018 Link_Nam
:= Expression
(Ext_Arg
);
10021 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10022 Ext_Nam
:= Expression
(Ext_Arg
);
10027 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
10028 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
10029 Ext_Nam
:= Expression
(Ext_Arg
);
10030 Link_Nam
:= Expression
(Link_Arg
);
10033 -- Check expressions for external name and link name are static
10035 if Present
(Ext_Nam
) then
10036 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
10037 Check_Form_Of_Interface_Name
(Ext_Nam
);
10039 -- Verify that external name is not the name of a local entity,
10040 -- which would hide the imported one and could lead to run-time
10041 -- surprises. The problem can only arise for entities declared in
10042 -- a package body (otherwise the external name is fully qualified
10043 -- and will not conflict).
10051 if Prag_Id
= Pragma_Import
then
10052 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
10053 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
10055 if Nam
/= Chars
(Subprogram_Def
)
10056 and then Present
(E
)
10057 and then not Is_Overloadable
(E
)
10058 and then Is_Immediately_Visible
(E
)
10059 and then not Is_Imported
(E
)
10060 and then Ekind
(Scope
(E
)) = E_Package
10063 while Present
(Par
) loop
10064 if Nkind
(Par
) = N_Package_Body
then
10065 Error_Msg_Sloc
:= Sloc
(E
);
10067 ("imported entity is hidden by & declared#",
10072 Par
:= Parent
(Par
);
10079 if Present
(Link_Nam
) then
10080 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
10081 Check_Form_Of_Interface_Name
(Link_Nam
);
10084 -- If there is no link name, just set the external name
10086 if No
(Link_Nam
) then
10087 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
10089 -- For the Link_Name case, the given literal is preceded by an
10090 -- asterisk, which indicates to GCC that the given name should be
10091 -- taken literally, and in particular that no prepending of
10092 -- underlines should occur, even in systems where this is the
10097 Store_String_Char
(Get_Char_Code
('*'));
10098 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
10099 Store_String_Chars
(String_Val
);
10101 Make_String_Literal
(Sloc
(Link_Nam
),
10102 Strval
=> End_String
);
10105 -- Set the interface name. If the entity is a generic instance, use
10106 -- its alias, which is the callable entity.
10108 if Is_Generic_Instance
(Subprogram_Def
) then
10109 Set_Encoded_Interface_Name
10110 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
10112 Set_Encoded_Interface_Name
10113 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
10116 Check_Duplicated_Export_Name
(Link_Nam
);
10117 end Process_Interface_Name
;
10119 -----------------------------------------
10120 -- Process_Interrupt_Or_Attach_Handler --
10121 -----------------------------------------
10123 procedure Process_Interrupt_Or_Attach_Handler
is
10124 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
10125 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
10128 -- A pragma that applies to a Ghost entity becomes Ghost for the
10129 -- purposes of legality checks and removal of ignored Ghost code.
10131 Mark_Ghost_Pragma
(N
, Handler
);
10132 Set_Is_Interrupt_Handler
(Handler
);
10134 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
10136 Record_Rep_Item
(Prot_Typ
, N
);
10138 -- Chain the pragma on the contract for completeness
10140 Add_Contract_Item
(N
, Handler
);
10141 end Process_Interrupt_Or_Attach_Handler
;
10143 --------------------------------------------------
10144 -- Process_Restrictions_Or_Restriction_Warnings --
10145 --------------------------------------------------
10147 -- Note: some of the simple identifier cases were handled in par-prag,
10148 -- but it is harmless (and more straightforward) to simply handle all
10149 -- cases here, even if it means we repeat a bit of work in some cases.
10151 procedure Process_Restrictions_Or_Restriction_Warnings
10155 R_Id
: Restriction_Id
;
10161 -- Ignore all Restrictions pragmas in CodePeer mode
10163 if CodePeer_Mode
then
10167 Check_Ada_83_Warning
;
10168 Check_At_Least_N_Arguments
(1);
10169 Check_Valid_Configuration_Pragma
;
10172 while Present
(Arg
) loop
10174 Expr
:= Get_Pragma_Arg
(Arg
);
10176 -- Case of no restriction identifier present
10178 if Id
= No_Name
then
10179 if Nkind
(Expr
) /= N_Identifier
then
10181 ("invalid form for restriction", Arg
);
10186 (Process_Restriction_Synonyms
(Expr
));
10188 if R_Id
not in All_Boolean_Restrictions
then
10189 Error_Msg_Name_1
:= Pname
;
10191 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
10193 -- Check for possible misspelling
10195 for J
in Restriction_Id
loop
10197 Rnm
: constant String := Restriction_Id
'Image (J
);
10200 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
10201 Name_Len
:= Rnm
'Length;
10202 Set_Casing
(All_Lower_Case
);
10204 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
10207 (Source_Index
(Current_Sem_Unit
)));
10208 Error_Msg_String
(1 .. Rnm
'Length) :=
10209 Name_Buffer
(1 .. Name_Len
);
10210 Error_Msg_Strlen
:= Rnm
'Length;
10211 Error_Msg_N
-- CODEFIX
10212 ("\possible misspelling of ""~""",
10213 Get_Pragma_Arg
(Arg
));
10222 if Implementation_Restriction
(R_Id
) then
10223 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10226 -- Special processing for No_Elaboration_Code restriction
10228 if R_Id
= No_Elaboration_Code
then
10230 -- Restriction is only recognized within a configuration
10231 -- pragma file, or within a unit of the main extended
10232 -- program. Note: the test for Main_Unit is needed to
10233 -- properly include the case of configuration pragma files.
10235 if not (Current_Sem_Unit
= Main_Unit
10236 or else In_Extended_Main_Source_Unit
(N
))
10240 -- Don't allow in a subunit unless already specified in
10243 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10244 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10245 and then not Restriction_Active
(No_Elaboration_Code
)
10248 ("invalid specification of ""No_Elaboration_Code""",
10251 ("\restriction cannot be specified in a subunit", N
);
10253 ("\unless also specified in body or spec", N
);
10256 -- If we accept a No_Elaboration_Code restriction, then it
10257 -- needs to be added to the configuration restriction set so
10258 -- that we get proper application to other units in the main
10259 -- extended source as required.
10262 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10266 -- If this is a warning, then set the warning unless we already
10267 -- have a real restriction active (we never want a warning to
10268 -- override a real restriction).
10271 if not Restriction_Active
(R_Id
) then
10272 Set_Restriction
(R_Id
, N
);
10273 Restriction_Warnings
(R_Id
) := True;
10276 -- If real restriction case, then set it and make sure that the
10277 -- restriction warning flag is off, since a real restriction
10278 -- always overrides a warning.
10281 Set_Restriction
(R_Id
, N
);
10282 Restriction_Warnings
(R_Id
) := False;
10285 -- Check for obsolescent restrictions in Ada 2005 mode
10288 and then Ada_Version
>= Ada_2005
10289 and then (R_Id
= No_Asynchronous_Control
10291 R_Id
= No_Unchecked_Deallocation
10293 R_Id
= No_Unchecked_Conversion
)
10295 Check_Restriction
(No_Obsolescent_Features
, N
);
10298 -- A very special case that must be processed here: pragma
10299 -- Restrictions (No_Exceptions) turns off all run-time
10300 -- checking. This is a bit dubious in terms of the formal
10301 -- language definition, but it is what is intended by RM
10302 -- H.4(12). Restriction_Warnings never affects generated code
10303 -- so this is done only in the real restriction case.
10305 -- Atomic_Synchronization is not a real check, so it is not
10306 -- affected by this processing).
10308 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10309 -- run-time checks in CodePeer and GNATprove modes: we want to
10310 -- generate checks for analysis purposes, as set respectively
10311 -- by -gnatC and -gnatd.F
10314 and then not (CodePeer_Mode
or GNATprove_Mode
)
10315 and then R_Id
= No_Exceptions
10317 for J
in Scope_Suppress
.Suppress
'Range loop
10318 if J
/= Atomic_Synchronization
then
10319 Scope_Suppress
.Suppress
(J
) := True;
10324 -- Case of No_Dependence => unit-name. Note that the parser
10325 -- already made the necessary entry in the No_Dependence table.
10327 elsif Id
= Name_No_Dependence
then
10328 if not OK_No_Dependence_Unit_Name
(Expr
) then
10332 -- Case of No_Specification_Of_Aspect => aspect-identifier
10334 elsif Id
= Name_No_Specification_Of_Aspect
then
10339 if Nkind
(Expr
) /= N_Identifier
then
10342 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10345 if A_Id
= No_Aspect
then
10346 Error_Pragma_Arg
("invalid restriction name", Arg
);
10348 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10352 -- Case of No_Use_Of_Attribute => attribute-identifier
10354 elsif Id
= Name_No_Use_Of_Attribute
then
10355 if Nkind
(Expr
) /= N_Identifier
10356 or else not Is_Attribute_Name
(Chars
(Expr
))
10358 Error_Msg_N
("unknown attribute name??", Expr
);
10361 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10364 -- Case of No_Use_Of_Entity => fully-qualified-name
10366 elsif Id
= Name_No_Use_Of_Entity
then
10368 -- Restriction is only recognized within a configuration
10369 -- pragma file, or within a unit of the main extended
10370 -- program. Note: the test for Main_Unit is needed to
10371 -- properly include the case of configuration pragma files.
10373 if Current_Sem_Unit
= Main_Unit
10374 or else In_Extended_Main_Source_Unit
(N
)
10376 if not OK_No_Dependence_Unit_Name
(Expr
) then
10377 Error_Msg_N
("wrong form for entity name", Expr
);
10379 Set_Restriction_No_Use_Of_Entity
10380 (Expr
, Warn
, No_Profile
);
10384 -- Case of No_Use_Of_Pragma => pragma-identifier
10386 elsif Id
= Name_No_Use_Of_Pragma
then
10387 if Nkind
(Expr
) /= N_Identifier
10388 or else not Is_Pragma_Name
(Chars
(Expr
))
10390 Error_Msg_N
("unknown pragma name??", Expr
);
10392 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10395 -- All other cases of restriction identifier present
10398 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10399 Analyze_And_Resolve
(Expr
, Any_Integer
);
10401 if R_Id
not in All_Parameter_Restrictions
then
10403 ("invalid restriction parameter identifier", Arg
);
10405 elsif not Is_OK_Static_Expression
(Expr
) then
10406 Flag_Non_Static_Expr
10407 ("value must be static expression!", Expr
);
10410 elsif not Is_Integer_Type
(Etype
(Expr
))
10411 or else Expr_Value
(Expr
) < 0
10414 ("value must be non-negative integer", Arg
);
10417 -- Restriction pragma is active
10419 Val
:= Expr_Value
(Expr
);
10421 if not UI_Is_In_Int_Range
(Val
) then
10423 ("pragma ignored, value too large??", Arg
);
10426 -- Warning case. If the real restriction is active, then we
10427 -- ignore the request, since warning never overrides a real
10428 -- restriction. Otherwise we set the proper warning. Note that
10429 -- this circuit sets the warning again if it is already set,
10430 -- which is what we want, since the constant may have changed.
10433 if not Restriction_Active
(R_Id
) then
10435 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10436 Restriction_Warnings
(R_Id
) := True;
10439 -- Real restriction case, set restriction and make sure warning
10440 -- flag is off since real restriction always overrides warning.
10443 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10444 Restriction_Warnings
(R_Id
) := False;
10450 end Process_Restrictions_Or_Restriction_Warnings
;
10452 ---------------------------------
10453 -- Process_Suppress_Unsuppress --
10454 ---------------------------------
10456 -- Note: this procedure makes entries in the check suppress data
10457 -- structures managed by Sem. See spec of package Sem for full
10458 -- details on how we handle recording of check suppression.
10460 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10465 In_Package_Spec
: constant Boolean :=
10466 Is_Package_Or_Generic_Package
(Current_Scope
)
10467 and then not In_Package_Body
(Current_Scope
);
10469 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10470 -- Used to suppress a single check on the given entity
10472 --------------------------------
10473 -- Suppress_Unsuppress_Echeck --
10474 --------------------------------
10476 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10478 -- Check for error of trying to set atomic synchronization for
10479 -- a non-atomic variable.
10481 if C
= Atomic_Synchronization
10482 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10485 ("pragma & requires atomic type or variable",
10486 Pragma_Identifier
(Original_Node
(N
)));
10489 Set_Checks_May_Be_Suppressed
(E
);
10491 if In_Package_Spec
then
10492 Push_Global_Suppress_Stack_Entry
10495 Suppress
=> Suppress_Case
);
10497 Push_Local_Suppress_Stack_Entry
10500 Suppress
=> Suppress_Case
);
10503 -- If this is a first subtype, and the base type is distinct,
10504 -- then also set the suppress flags on the base type.
10506 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10507 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10509 end Suppress_Unsuppress_Echeck
;
10511 -- Start of processing for Process_Suppress_Unsuppress
10514 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10515 -- on user code: we want to generate checks for analysis purposes, as
10516 -- set respectively by -gnatC and -gnatd.F
10518 if Comes_From_Source
(N
)
10519 and then (CodePeer_Mode
or GNATprove_Mode
)
10524 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10525 -- declarative part or a package spec (RM 11.5(5)).
10527 if not Is_Configuration_Pragma
then
10528 Check_Is_In_Decl_Part_Or_Package_Spec
;
10531 Check_At_Least_N_Arguments
(1);
10532 Check_At_Most_N_Arguments
(2);
10533 Check_No_Identifier
(Arg1
);
10534 Check_Arg_Is_Identifier
(Arg1
);
10536 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10538 if C
= No_Check_Id
then
10540 ("argument of pragma% is not valid check name", Arg1
);
10543 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10545 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10547 ("Suppress of Elaboration_Check ignored in SPARK??",
10548 "\elaboration checking rules are statically enforced "
10549 & "(SPARK RM 7.7)", Arg1
);
10552 -- One-argument case
10554 if Arg_Count
= 1 then
10556 -- Make an entry in the local scope suppress table. This is the
10557 -- table that directly shows the current value of the scope
10558 -- suppress check for any check id value.
10560 if C
= All_Checks
then
10562 -- For All_Checks, we set all specific predefined checks with
10563 -- the exception of Elaboration_Check, which is handled
10564 -- specially because of not wanting All_Checks to have the
10565 -- effect of deactivating static elaboration order processing.
10566 -- Atomic_Synchronization is also not affected, since this is
10567 -- not a real check.
10569 for J
in Scope_Suppress
.Suppress
'Range loop
10570 if J
/= Elaboration_Check
10572 J
/= Atomic_Synchronization
10574 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10578 -- If not All_Checks, and predefined check, then set appropriate
10579 -- scope entry. Note that we will set Elaboration_Check if this
10580 -- is explicitly specified. Atomic_Synchronization is allowed
10581 -- only if internally generated and entity is atomic.
10583 elsif C
in Predefined_Check_Id
10584 and then (not Comes_From_Source
(N
)
10585 or else C
/= Atomic_Synchronization
)
10587 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10590 -- Also make an entry in the Local_Entity_Suppress table
10592 Push_Local_Suppress_Stack_Entry
10595 Suppress
=> Suppress_Case
);
10597 -- Case of two arguments present, where the check is suppressed for
10598 -- a specified entity (given as the second argument of the pragma)
10601 -- This is obsolescent in Ada 2005 mode
10603 if Ada_Version
>= Ada_2005
then
10604 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10607 Check_Optional_Identifier
(Arg2
, Name_On
);
10608 E_Id
:= Get_Pragma_Arg
(Arg2
);
10611 if not Is_Entity_Name
(E_Id
) then
10613 ("second argument of pragma% must be entity name", Arg2
);
10616 E
:= Entity
(E_Id
);
10622 -- A pragma that applies to a Ghost entity becomes Ghost for the
10623 -- purposes of legality checks and removal of ignored Ghost code.
10625 Mark_Ghost_Pragma
(N
, E
);
10627 -- Enforce RM 11.5(7) which requires that for a pragma that
10628 -- appears within a package spec, the named entity must be
10629 -- within the package spec. We allow the package name itself
10630 -- to be mentioned since that makes sense, although it is not
10631 -- strictly allowed by 11.5(7).
10634 and then E
/= Current_Scope
10635 and then Scope
(E
) /= Current_Scope
10638 ("entity in pragma% is not in package spec (RM 11.5(7))",
10642 -- Loop through homonyms. As noted below, in the case of a package
10643 -- spec, only homonyms within the package spec are considered.
10646 Suppress_Unsuppress_Echeck
(E
, C
);
10648 if Is_Generic_Instance
(E
)
10649 and then Is_Subprogram
(E
)
10650 and then Present
(Alias
(E
))
10652 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10655 -- Move to next homonym if not aspect spec case
10657 exit when From_Aspect_Specification
(N
);
10661 -- If we are within a package specification, the pragma only
10662 -- applies to homonyms in the same scope.
10664 exit when In_Package_Spec
10665 and then Scope
(E
) /= Current_Scope
;
10668 end Process_Suppress_Unsuppress
;
10670 -------------------------------
10671 -- Record_Independence_Check --
10672 -------------------------------
10674 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10675 pragma Unreferenced
(N
, E
);
10677 -- For GCC back ends the validation is done a priori
10678 -- ??? This code is dead, might be useful in the future
10680 -- if not AAMP_On_Target then
10684 -- Independence_Checks.Append ((N, E));
10687 end Record_Independence_Check
;
10693 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10695 if Is_Imported
(E
) then
10697 ("cannot export entity& that was previously imported", Arg
);
10699 elsif Present
(Address_Clause
(E
))
10700 and then not Relaxed_RM_Semantics
10703 ("cannot export entity& that has an address clause", Arg
);
10706 Set_Is_Exported
(E
);
10708 -- Generate a reference for entity explicitly, because the
10709 -- identifier may be overloaded and name resolution will not
10712 Generate_Reference
(E
, Arg
);
10714 -- Deal with exporting non-library level entity
10716 if not Is_Library_Level_Entity
(E
) then
10718 -- Not allowed at all for subprograms
10720 if Is_Subprogram
(E
) then
10721 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10723 -- Otherwise set public and statically allocated
10727 Set_Is_Statically_Allocated
(E
);
10729 -- Warn if the corresponding W flag is set
10731 if Warn_On_Export_Import
10733 -- Only do this for something that was in the source. Not
10734 -- clear if this can be False now (there used for sure to be
10735 -- cases on some systems where it was False), but anyway the
10736 -- test is harmless if not needed, so it is retained.
10738 and then Comes_From_Source
(Arg
)
10741 ("?x?& has been made static as a result of Export",
10744 ("\?x?this usage is non-standard and non-portable",
10750 if Warn_On_Export_Import
and then Is_Type
(E
) then
10751 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10754 if Warn_On_Export_Import
and Inside_A_Generic
then
10756 ("all instances of& will have the same external name?x?",
10761 ----------------------------------------------
10762 -- Set_Extended_Import_Export_External_Name --
10763 ----------------------------------------------
10765 procedure Set_Extended_Import_Export_External_Name
10766 (Internal_Ent
: Entity_Id
;
10767 Arg_External
: Node_Id
)
10769 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10770 New_Name
: Node_Id
;
10773 if No
(Arg_External
) then
10777 Check_Arg_Is_External_Name
(Arg_External
);
10779 if Nkind
(Arg_External
) = N_String_Literal
then
10780 if String_Length
(Strval
(Arg_External
)) = 0 then
10783 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10786 elsif Nkind
(Arg_External
) = N_Identifier
then
10787 New_Name
:= Get_Default_External_Name
(Arg_External
);
10789 -- Check_Arg_Is_External_Name should let through only identifiers and
10790 -- string literals or static string expressions (which are folded to
10791 -- string literals).
10794 raise Program_Error
;
10797 -- If we already have an external name set (by a prior normal Import
10798 -- or Export pragma), then the external names must match
10800 if Present
(Interface_Name
(Internal_Ent
)) then
10802 -- Ignore mismatching names in CodePeer mode, to support some
10803 -- old compilers which would export the same procedure under
10804 -- different names, e.g:
10806 -- pragma Export_Procedure (P, "a");
10807 -- pragma Export_Procedure (P, "b");
10809 if CodePeer_Mode
then
10813 Check_Matching_Internal_Names
: declare
10814 S1
: constant String_Id
:= Strval
(Old_Name
);
10815 S2
: constant String_Id
:= Strval
(New_Name
);
10817 procedure Mismatch
;
10818 pragma No_Return
(Mismatch
);
10819 -- Called if names do not match
10825 procedure Mismatch
is
10827 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10829 ("external name does not match that given #",
10833 -- Start of processing for Check_Matching_Internal_Names
10836 if String_Length
(S1
) /= String_Length
(S2
) then
10840 for J
in 1 .. String_Length
(S1
) loop
10841 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10846 end Check_Matching_Internal_Names
;
10848 -- Otherwise set the given name
10851 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10852 Check_Duplicated_Export_Name
(New_Name
);
10854 end Set_Extended_Import_Export_External_Name
;
10860 procedure Set_Imported
(E
: Entity_Id
) is
10862 -- Error message if already imported or exported
10864 if Is_Exported
(E
) or else Is_Imported
(E
) then
10866 -- Error if being set Exported twice
10868 if Is_Exported
(E
) then
10869 Error_Msg_NE
("entity& was previously exported", N
, E
);
10871 -- Ignore error in CodePeer mode where we treat all imported
10872 -- subprograms as unknown.
10874 elsif CodePeer_Mode
then
10877 -- OK if Import/Interface case
10879 elsif Import_Interface_Present
(N
) then
10882 -- Error if being set Imported twice
10885 Error_Msg_NE
("entity& was previously imported", N
, E
);
10888 Error_Msg_Name_1
:= Pname
;
10890 ("\(pragma% applies to all previous entities)", N
);
10892 Error_Msg_Sloc
:= Sloc
(E
);
10893 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10895 -- Here if not previously imported or exported, OK to import
10898 Set_Is_Imported
(E
);
10900 -- For subprogram, set Import_Pragma field
10902 if Is_Subprogram
(E
) then
10903 Set_Import_Pragma
(E
, N
);
10906 -- If the entity is an object that is not at the library level,
10907 -- then it is statically allocated. We do not worry about objects
10908 -- with address clauses in this context since they are not really
10909 -- imported in the linker sense.
10912 and then not Is_Library_Level_Entity
(E
)
10913 and then No
(Address_Clause
(E
))
10915 Set_Is_Statically_Allocated
(E
);
10922 -------------------------
10923 -- Set_Mechanism_Value --
10924 -------------------------
10926 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10927 -- analyzed, since it is semantic nonsense), so we get it in the exact
10928 -- form created by the parser.
10930 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10931 procedure Bad_Mechanism
;
10932 pragma No_Return
(Bad_Mechanism
);
10933 -- Signal bad mechanism name
10935 -------------------
10936 -- Bad_Mechanism --
10937 -------------------
10939 procedure Bad_Mechanism
is
10941 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10944 -- Start of processing for Set_Mechanism_Value
10947 if Mechanism
(Ent
) /= Default_Mechanism
then
10949 ("mechanism for & has already been set", Mech_Name
, Ent
);
10952 -- MECHANISM_NAME ::= value | reference
10954 if Nkind
(Mech_Name
) = N_Identifier
then
10955 if Chars
(Mech_Name
) = Name_Value
then
10956 Set_Mechanism
(Ent
, By_Copy
);
10959 elsif Chars
(Mech_Name
) = Name_Reference
then
10960 Set_Mechanism
(Ent
, By_Reference
);
10963 elsif Chars
(Mech_Name
) = Name_Copy
then
10965 ("bad mechanism name, Value assumed", Mech_Name
);
10974 end Set_Mechanism_Value
;
10976 --------------------------
10977 -- Set_Rational_Profile --
10978 --------------------------
10980 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10981 -- extension to the semantics of renaming declarations.
10983 procedure Set_Rational_Profile
is
10985 Implicit_Packing
:= True;
10986 Overriding_Renamings
:= True;
10987 Use_VADS_Size
:= True;
10988 end Set_Rational_Profile
;
10990 ---------------------------
10991 -- Set_Ravenscar_Profile --
10992 ---------------------------
10994 -- The tasks to be done here are
10996 -- Set required policies
10998 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10999 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
11000 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11001 -- (For GNAT_Ravenscar_EDF profile)
11002 -- pragma Locking_Policy (Ceiling_Locking)
11004 -- Set Detect_Blocking mode
11006 -- Set required restrictions (see System.Rident for detailed list)
11008 -- Set the No_Dependence rules
11009 -- No_Dependence => Ada.Asynchronous_Task_Control
11010 -- No_Dependence => Ada.Calendar
11011 -- No_Dependence => Ada.Execution_Time.Group_Budget
11012 -- No_Dependence => Ada.Execution_Time.Timers
11013 -- No_Dependence => Ada.Task_Attributes
11014 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11016 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
11017 procedure Set_Error_Msg_To_Profile_Name
;
11018 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
11021 -----------------------------------
11022 -- Set_Error_Msg_To_Profile_Name --
11023 -----------------------------------
11025 procedure Set_Error_Msg_To_Profile_Name
is
11026 Prof_Nam
: constant Node_Id
:=
11028 (First
(Pragma_Argument_Associations
(N
)));
11031 Get_Name_String
(Chars
(Prof_Nam
));
11032 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
11033 Error_Msg_Strlen
:= Name_Len
;
11034 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
11035 end Set_Error_Msg_To_Profile_Name
;
11044 Profile_Dispatching_Policy
: Character;
11046 -- Start of processing for Set_Ravenscar_Profile
11049 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
11051 if Profile
= GNAT_Ravenscar_EDF
then
11052 Profile_Dispatching_Policy
:= 'E';
11054 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
11057 Profile_Dispatching_Policy
:= 'F';
11060 if Task_Dispatching_Policy
/= ' '
11061 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
11063 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
11064 Set_Error_Msg_To_Profile_Name
;
11065 Error_Pragma
("Profile (~) incompatible with policy#");
11067 -- Set the FIFO_Within_Priorities policy, but always preserve
11068 -- System_Location since we like the error message with the run time
11072 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
11074 if Task_Dispatching_Policy_Sloc
/= System_Location
then
11075 Task_Dispatching_Policy_Sloc
:= Loc
;
11079 -- pragma Locking_Policy (Ceiling_Locking)
11081 if Locking_Policy
/= ' '
11082 and then Locking_Policy
/= 'C'
11084 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
11085 Set_Error_Msg_To_Profile_Name
;
11086 Error_Pragma
("Profile (~) incompatible with policy#");
11088 -- Set the Ceiling_Locking policy, but preserve System_Location since
11089 -- we like the error message with the run time name.
11092 Locking_Policy
:= 'C';
11094 if Locking_Policy_Sloc
/= System_Location
then
11095 Locking_Policy_Sloc
:= Loc
;
11099 -- pragma Detect_Blocking
11101 Detect_Blocking
:= True;
11103 -- Set the corresponding restrictions
11105 Set_Profile_Restrictions
11106 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
11108 -- Set the No_Dependence restrictions
11110 -- The following No_Dependence restrictions:
11111 -- No_Dependence => Ada.Asynchronous_Task_Control
11112 -- No_Dependence => Ada.Calendar
11113 -- No_Dependence => Ada.Task_Attributes
11114 -- are already set by previous call to Set_Profile_Restrictions.
11116 -- Set the following restrictions which were added to Ada 2005:
11117 -- No_Dependence => Ada.Execution_Time.Group_Budget
11118 -- No_Dependence => Ada.Execution_Time.Timers
11120 if Ada_Version
>= Ada_2005
then
11121 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
11122 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
11125 Make_Selected_Component
11128 Selector_Name
=> Sel_Id
);
11130 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
11133 Make_Selected_Component
11136 Selector_Name
=> Sel_Id
);
11138 Set_Restriction_No_Dependence
11140 Warn
=> Treat_Restrictions_As_Warnings
,
11141 Profile
=> Ravenscar
);
11143 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
11146 Make_Selected_Component
11149 Selector_Name
=> Sel_Id
);
11151 Set_Restriction_No_Dependence
11153 Warn
=> Treat_Restrictions_As_Warnings
,
11154 Profile
=> Ravenscar
);
11157 -- Set the following restriction which was added to Ada 2012 (see
11159 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
11161 if Ada_Version
>= Ada_2012
then
11162 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
11163 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
11166 Make_Selected_Component
11169 Selector_Name
=> Sel_Id
);
11171 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
11174 Make_Selected_Component
11177 Selector_Name
=> Sel_Id
);
11179 Set_Restriction_No_Dependence
11181 Warn
=> Treat_Restrictions_As_Warnings
,
11182 Profile
=> Ravenscar
);
11184 end Set_Ravenscar_Profile
;
11186 -----------------------------------
11187 -- Validate_Acc_Condition_Clause --
11188 -----------------------------------
11190 procedure Validate_Acc_Condition_Clause
(Clause
: Node_Id
) is
11192 Analyze_And_Resolve
(Clause
);
11194 if not Is_Boolean_Type
(Etype
(Clause
)) then
11195 Error_Pragma
("expected a boolean");
11197 end Validate_Acc_Condition_Clause
;
11199 ------------------------------
11200 -- Validate_Acc_Data_Clause --
11201 ------------------------------
11203 procedure Validate_Acc_Data_Clause
(Clause
: Node_Id
) is
11207 Expr
:= Acc_First
(Clause
);
11208 while Present
(Expr
) loop
11209 if Nkind
(Expr
) /= N_Identifier
then
11210 Error_Pragma
("expected an identifer");
11213 Analyze_And_Resolve
(Expr
);
11215 Expr
:= Acc_Next
(Expr
);
11217 end Validate_Acc_Data_Clause
;
11219 ----------------------------------
11220 -- Validate_Acc_Int_Expr_Clause --
11221 ----------------------------------
11223 procedure Validate_Acc_Int_Expr_Clause
(Clause
: Node_Id
) is
11225 Analyze_And_Resolve
(Clause
);
11227 if not Is_Integer_Type
(Etype
(Clause
)) then
11228 Error_Pragma_Arg
("expected an integer", Clause
);
11230 end Validate_Acc_Int_Expr_Clause
;
11232 ---------------------------------------
11233 -- Validate_Acc_Int_Expr_List_Clause --
11234 ---------------------------------------
11236 procedure Validate_Acc_Int_Expr_List_Clause
(Clause
: Node_Id
) is
11240 Expr
:= Acc_First
(Clause
);
11241 while Present
(Expr
) loop
11242 Analyze_And_Resolve
(Expr
);
11244 if not Is_Integer_Type
(Etype
(Expr
)) then
11245 Error_Pragma
("expected an integer");
11248 Expr
:= Acc_Next
(Expr
);
11250 end Validate_Acc_Int_Expr_List_Clause
;
11252 --------------------------------
11253 -- Validate_Acc_Loop_Collapse --
11254 --------------------------------
11256 procedure Validate_Acc_Loop_Collapse
(Clause
: Node_Id
) is
11258 Par_Loop
: Node_Id
;
11262 -- Make sure the argument is a positive integer
11264 Analyze_And_Resolve
(Clause
);
11266 Count
:= Static_Integer
(Clause
);
11267 if Count
= No_Uint
or else Count
< 1 then
11268 Error_Pragma_Arg
("expected a positive integer", Clause
);
11271 -- Then, make sure we have at least Count-1 tightly-nested loops
11272 -- (i.e. loops with no statements in between).
11274 Par_Loop
:= Parent
(Parent
(Parent
(Clause
)));
11275 Stmt
:= First
(Statements
(Par_Loop
));
11277 -- Skip first pragmas in the parent loop
11279 while Present
(Stmt
) and then Nkind
(Stmt
) = N_Pragma
loop
11283 if not Present
(Next
(Stmt
)) then
11284 while Nkind
(Stmt
) = N_Loop_Statement
and Count
> 1 loop
11285 Stmt
:= First
(Statements
(Stmt
));
11286 exit when Present
(Next
(Stmt
));
11288 Count
:= Count
- 1;
11294 ("Collapse argument too high or loops not tightly nested",
11297 end Validate_Acc_Loop_Collapse
;
11299 ----------------------------
11300 -- Validate_Acc_Loop_Gang --
11301 ----------------------------
11303 procedure Validate_Acc_Loop_Gang
(Clause
: Node_Id
) is
11305 Error_Pragma_Arg
("Loop_Gang not implemented", Clause
);
11306 end Validate_Acc_Loop_Gang
;
11308 ------------------------------
11309 -- Validate_Acc_Loop_Vector --
11310 ------------------------------
11312 procedure Validate_Acc_Loop_Vector
(Clause
: Node_Id
) is
11314 Error_Pragma_Arg
("Loop_Vector not implemented", Clause
);
11315 end Validate_Acc_Loop_Vector
;
11317 -------------------------------
11318 -- Validate_Acc_Loop_Worker --
11319 -------------------------------
11321 procedure Validate_Acc_Loop_Worker
(Clause
: Node_Id
) is
11323 Error_Pragma_Arg
("Loop_Worker not implemented", Clause
);
11324 end Validate_Acc_Loop_Worker
;
11326 ---------------------------------
11327 -- Validate_Acc_Name_Reduction --
11328 ---------------------------------
11330 procedure Validate_Acc_Name_Reduction
(Clause
: Node_Id
) is
11332 -- ??? On top of the following operations, the OpenAcc spec adds the
11333 -- "bitwise and", "bitwise or" and modulo for C and ".eqv" and
11334 -- ".neqv" for Fortran. Can we, should we and how do we support them
11337 type Reduction_Op
is (Add_Op
, Mul_Op
, Max_Op
, Min_Op
, And_Op
, Or_Op
);
11339 function To_Reduction_Op
(Op
: String) return Reduction_Op
;
11340 -- Convert operator Op described by a String into its corresponding
11341 -- enumeration value.
11343 ---------------------
11344 -- To_Reduction_Op --
11345 ---------------------
11347 function To_Reduction_Op
(Op
: String) return Reduction_Op
is
11352 elsif Op
= "*" then
11355 elsif Op
= "max" then
11358 elsif Op
= "min" then
11361 elsif Op
= "and" then
11364 elsif Op
= "or" then
11368 Error_Pragma
("unsuported reduction operation");
11370 end To_Reduction_Op
;
11374 Seen
: constant Elist_Id
:= New_Elmt_List
;
11377 Reduc_Op
: Node_Id
;
11378 Reduc_Var
: Node_Id
;
11380 -- Start of processing for Validate_Acc_Name_Reduction
11383 -- Reduction operations appear in the following form:
11384 -- ("+" => (a, b), "*" => c)
11386 Expr
:= First
(Component_Associations
(Clause
));
11387 while Present
(Expr
) loop
11388 Reduc_Op
:= First
(Choices
(Expr
));
11389 String_To_Name_Buffer
(Strval
(Reduc_Op
));
11391 case To_Reduction_Op
(Name_Buffer
(1 .. Name_Len
)) is
11397 Reduc_Var
:= Acc_First
(Expression
(Expr
));
11398 while Present
(Reduc_Var
) loop
11399 Analyze_And_Resolve
(Reduc_Var
);
11401 if Contains
(Seen
, Entity
(Reduc_Var
)) then
11402 Error_Pragma
("variable used in multiple reductions");
11405 if Nkind
(Reduc_Var
) /= N_Identifier
11406 or not Is_Numeric_Type
(Etype
(Reduc_Var
))
11409 ("expected an identifier for a Numeric");
11412 Append_Elmt
(Entity
(Reduc_Var
), Seen
);
11415 Reduc_Var
:= Acc_Next
(Reduc_Var
);
11421 Reduc_Var
:= Acc_First
(Expression
(Expr
));
11422 while Present
(Reduc_Var
) loop
11423 Analyze_And_Resolve
(Reduc_Var
);
11425 if Contains
(Seen
, Entity
(Reduc_Var
)) then
11426 Error_Pragma
("variable used in multiple reductions");
11429 if Nkind
(Reduc_Var
) /= N_Identifier
11430 or not Is_Boolean_Type
(Etype
(Reduc_Var
))
11433 ("expected a variable of type boolean");
11436 Append_Elmt
(Entity
(Reduc_Var
), Seen
);
11439 Reduc_Var
:= Acc_Next
(Reduc_Var
);
11445 end Validate_Acc_Name_Reduction
;
11447 -----------------------------------
11448 -- Validate_Acc_Size_Expressions --
11449 -----------------------------------
11451 procedure Validate_Acc_Size_Expressions
(Clause
: Node_Id
) is
11452 function Validate_Size_Expr
(Expr
: Node_Id
) return Boolean;
11453 -- A size expr is either an integer expression or "*"
11455 ------------------------
11456 -- Validate_Size_Expr --
11457 ------------------------
11459 function Validate_Size_Expr
(Expr
: Node_Id
) return Boolean is
11461 if Nkind
(Expr
) = N_Operator_Symbol
then
11462 return Get_String_Char
(Strval
(Expr
), 1) = Get_Char_Code
('*');
11465 Analyze_And_Resolve
(Expr
);
11467 return Is_Integer_Type
(Etype
(Expr
));
11468 end Validate_Size_Expr
;
11474 -- Start of processing for Validate_Acc_Size_Expressions
11477 Expr
:= Acc_First
(Clause
);
11478 while Present
(Expr
) loop
11479 if not Validate_Size_Expr
(Expr
) then
11481 ("Size expressions should be either integers or '*'");
11484 Expr
:= Acc_Next
(Expr
);
11486 end Validate_Acc_Size_Expressions
;
11488 -- Start of processing for Analyze_Pragma
11491 -- The following code is a defense against recursion. Not clear that
11492 -- this can happen legitimately, but perhaps some error situations can
11493 -- cause it, and we did see this recursion during testing.
11495 if Analyzed
(N
) then
11501 Check_Restriction_No_Use_Of_Pragma
(N
);
11503 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
11504 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
11506 if Should_Ignore_Pragma_Sem
(N
)
11507 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
11508 and then Ignore_Rep_Clauses
)
11513 -- Deal with unrecognized pragma
11515 if not Is_Pragma_Name
(Pname
) then
11516 if Warn_On_Unrecognized_Pragma
then
11517 Error_Msg_Name_1
:= Pname
;
11518 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
11520 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
11521 if Is_Bad_Spelling_Of
(Pname
, PN
) then
11522 Error_Msg_Name_1
:= PN
;
11523 Error_Msg_N
-- CODEFIX
11524 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11533 -- Here to start processing for recognized pragma
11535 Pname
:= Original_Aspect_Pragma_Name
(N
);
11537 -- Capture setting of Opt.Uneval_Old
11539 case Opt
.Uneval_Old
is
11541 Set_Uneval_Old_Accept
(N
);
11547 Set_Uneval_Old_Warn
(N
);
11550 raise Program_Error
;
11553 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11554 -- is already set, indicating that we have already checked the policy
11555 -- at the right point. This happens for example in the case of a pragma
11556 -- that is derived from an Aspect.
11558 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11561 -- For a pragma that is a rewriting of another pragma, copy the
11562 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11564 elsif Is_Rewrite_Substitution
(N
)
11565 and then Nkind
(Original_Node
(N
)) = N_Pragma
11567 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11568 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11570 -- Otherwise query the applicable policy at this point
11573 Check_Applicable_Policy
(N
);
11575 -- If pragma is disabled, rewrite as NULL and skip analysis
11577 if Is_Disabled
(N
) then
11578 Rewrite
(N
, Make_Null_Statement
(Loc
));
11584 -- Preset arguments
11592 if Present
(Pragma_Argument_Associations
(N
)) then
11593 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11594 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11596 if Present
(Arg1
) then
11597 Arg2
:= Next
(Arg1
);
11599 if Present
(Arg2
) then
11600 Arg3
:= Next
(Arg2
);
11602 if Present
(Arg3
) then
11603 Arg4
:= Next
(Arg3
);
11609 -- An enumeration type defines the pragmas that are supported by the
11610 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11611 -- into the corresponding enumeration value for the following case.
11619 -- pragma Abort_Defer;
11621 when Pragma_Abort_Defer
=>
11623 Check_Arg_Count
(0);
11625 -- The only required semantic processing is to check the
11626 -- placement. This pragma must appear at the start of the
11627 -- statement sequence of a handled sequence of statements.
11629 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11630 or else N
/= First
(Statements
(Parent
(N
)))
11635 --------------------
11636 -- Abstract_State --
11637 --------------------
11639 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11641 -- ABSTRACT_STATE_LIST ::=
11643 -- | STATE_NAME_WITH_OPTIONS
11644 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11646 -- STATE_NAME_WITH_OPTIONS ::=
11648 -- | (STATE_NAME with OPTION_LIST)
11650 -- OPTION_LIST ::= OPTION {, OPTION}
11654 -- | NAME_VALUE_OPTION
11656 -- SIMPLE_OPTION ::= Ghost | Synchronous
11658 -- NAME_VALUE_OPTION ::=
11659 -- Part_Of => ABSTRACT_STATE
11660 -- | External [=> EXTERNAL_PROPERTY_LIST]
11662 -- EXTERNAL_PROPERTY_LIST ::=
11663 -- EXTERNAL_PROPERTY
11664 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11666 -- EXTERNAL_PROPERTY ::=
11667 -- Async_Readers [=> boolean_EXPRESSION]
11668 -- | Async_Writers [=> boolean_EXPRESSION]
11669 -- | Effective_Reads [=> boolean_EXPRESSION]
11670 -- | Effective_Writes [=> boolean_EXPRESSION]
11671 -- others => boolean_EXPRESSION
11673 -- STATE_NAME ::= defining_identifier
11675 -- ABSTRACT_STATE ::= name
11677 -- Characteristics:
11679 -- * Analysis - The annotation is fully analyzed immediately upon
11680 -- elaboration as it cannot forward reference entities.
11682 -- * Expansion - None.
11684 -- * Template - The annotation utilizes the generic template of the
11685 -- related package declaration.
11687 -- * Globals - The annotation cannot reference global entities.
11689 -- * Instance - The annotation is instantiated automatically when
11690 -- the related generic package is instantiated.
11692 when Pragma_Abstract_State
=> Abstract_State
: declare
11693 Missing_Parentheses
: Boolean := False;
11694 -- Flag set when a state declaration with options is not properly
11697 -- Flags used to verify the consistency of states
11699 Non_Null_Seen
: Boolean := False;
11700 Null_Seen
: Boolean := False;
11702 procedure Analyze_Abstract_State
11704 Pack_Id
: Entity_Id
);
11705 -- Verify the legality of a single state declaration. Create and
11706 -- decorate a state abstraction entity and introduce it into the
11707 -- visibility chain. Pack_Id denotes the entity or the related
11708 -- package where pragma Abstract_State appears.
11710 procedure Malformed_State_Error
(State
: Node_Id
);
11711 -- Emit an error concerning the illegal declaration of abstract
11712 -- state State. This routine diagnoses syntax errors that lead to
11713 -- a different parse tree. The error is issued regardless of the
11714 -- SPARK mode in effect.
11716 ----------------------------
11717 -- Analyze_Abstract_State --
11718 ----------------------------
11720 procedure Analyze_Abstract_State
11722 Pack_Id
: Entity_Id
)
11724 -- Flags used to verify the consistency of options
11726 AR_Seen
: Boolean := False;
11727 AW_Seen
: Boolean := False;
11728 ER_Seen
: Boolean := False;
11729 EW_Seen
: Boolean := False;
11730 External_Seen
: Boolean := False;
11731 Ghost_Seen
: Boolean := False;
11732 Others_Seen
: Boolean := False;
11733 Part_Of_Seen
: Boolean := False;
11734 Synchronous_Seen
: Boolean := False;
11736 -- Flags used to store the static value of all external states'
11739 AR_Val
: Boolean := False;
11740 AW_Val
: Boolean := False;
11741 ER_Val
: Boolean := False;
11742 EW_Val
: Boolean := False;
11744 State_Id
: Entity_Id
:= Empty
;
11745 -- The entity to be generated for the current state declaration
11747 procedure Analyze_External_Option
(Opt
: Node_Id
);
11748 -- Verify the legality of option External
11750 procedure Analyze_External_Property
11752 Expr
: Node_Id
:= Empty
);
11753 -- Verify the legailty of a single external property. Prop
11754 -- denotes the external property. Expr is the expression used
11755 -- to set the property.
11757 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11758 -- Verify the legality of option Part_Of
11760 procedure Check_Duplicate_Option
11762 Status
: in out Boolean);
11763 -- Flag Status denotes whether a particular option has been
11764 -- seen while processing a state. This routine verifies that
11765 -- Opt is not a duplicate option and sets the flag Status
11766 -- (SPARK RM 7.1.4(1)).
11768 procedure Check_Duplicate_Property
11770 Status
: in out Boolean);
11771 -- Flag Status denotes whether a particular property has been
11772 -- seen while processing option External. This routine verifies
11773 -- that Prop is not a duplicate property and sets flag Status.
11774 -- Opt is not a duplicate property and sets the flag Status.
11775 -- (SPARK RM 7.1.4(2))
11777 procedure Check_Ghost_Synchronous
;
11778 -- Ensure that the abstract state is not subject to both Ghost
11779 -- and Synchronous simple options. Emit an error if this is the
11782 procedure Create_Abstract_State
11786 Is_Null
: Boolean);
11787 -- Generate an abstract state entity with name Nam and enter it
11788 -- into visibility. Decl is the "declaration" of the state as
11789 -- it appears in pragma Abstract_State. Loc is the location of
11790 -- the related state "declaration". Flag Is_Null should be set
11791 -- when the associated Abstract_State pragma defines a null
11794 -----------------------------
11795 -- Analyze_External_Option --
11796 -----------------------------
11798 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11799 Errors
: constant Nat
:= Serious_Errors_Detected
;
11801 Props
: Node_Id
:= Empty
;
11804 if Nkind
(Opt
) = N_Component_Association
then
11805 Props
:= Expression
(Opt
);
11808 -- External state with properties
11810 if Present
(Props
) then
11812 -- Multiple properties appear as an aggregate
11814 if Nkind
(Props
) = N_Aggregate
then
11816 -- Simple property form
11818 Prop
:= First
(Expressions
(Props
));
11819 while Present
(Prop
) loop
11820 Analyze_External_Property
(Prop
);
11824 -- Property with expression form
11826 Prop
:= First
(Component_Associations
(Props
));
11827 while Present
(Prop
) loop
11828 Analyze_External_Property
11829 (Prop
=> First
(Choices
(Prop
)),
11830 Expr
=> Expression
(Prop
));
11838 Analyze_External_Property
(Props
);
11841 -- An external state defined without any properties defaults
11842 -- all properties to True.
11851 -- Once all external properties have been processed, verify
11852 -- their mutual interaction. Do not perform the check when
11853 -- at least one of the properties is illegal as this will
11854 -- produce a bogus error.
11856 if Errors
= Serious_Errors_Detected
then
11857 Check_External_Properties
11858 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11860 end Analyze_External_Option
;
11862 -------------------------------
11863 -- Analyze_External_Property --
11864 -------------------------------
11866 procedure Analyze_External_Property
11868 Expr
: Node_Id
:= Empty
)
11870 Expr_Val
: Boolean;
11873 -- Check the placement of "others" (if available)
11875 if Nkind
(Prop
) = N_Others_Choice
then
11876 if Others_Seen
then
11878 ("only one others choice allowed in option External",
11881 Others_Seen
:= True;
11884 elsif Others_Seen
then
11886 ("others must be the last property in option External",
11889 -- The only remaining legal options are the four predefined
11890 -- external properties.
11892 elsif Nkind
(Prop
) = N_Identifier
11893 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11894 Name_Async_Writers
,
11895 Name_Effective_Reads
,
11896 Name_Effective_Writes
)
11900 -- Otherwise the construct is not a valid property
11903 SPARK_Msg_N
("invalid external state property", Prop
);
11907 -- Ensure that the expression of the external state property
11908 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11910 if Present
(Expr
) then
11911 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11913 if Is_OK_Static_Expression
(Expr
) then
11914 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11917 ("expression of external state property must be "
11922 -- The lack of expression defaults the property to True
11928 -- Named properties
11930 if Nkind
(Prop
) = N_Identifier
then
11931 if Chars
(Prop
) = Name_Async_Readers
then
11932 Check_Duplicate_Property
(Prop
, AR_Seen
);
11933 AR_Val
:= Expr_Val
;
11935 elsif Chars
(Prop
) = Name_Async_Writers
then
11936 Check_Duplicate_Property
(Prop
, AW_Seen
);
11937 AW_Val
:= Expr_Val
;
11939 elsif Chars
(Prop
) = Name_Effective_Reads
then
11940 Check_Duplicate_Property
(Prop
, ER_Seen
);
11941 ER_Val
:= Expr_Val
;
11944 Check_Duplicate_Property
(Prop
, EW_Seen
);
11945 EW_Val
:= Expr_Val
;
11948 -- The handling of property "others" must take into account
11949 -- all other named properties that have been encountered so
11950 -- far. Only those that have not been seen are affected by
11954 if not AR_Seen
then
11955 AR_Val
:= Expr_Val
;
11958 if not AW_Seen
then
11959 AW_Val
:= Expr_Val
;
11962 if not ER_Seen
then
11963 ER_Val
:= Expr_Val
;
11966 if not EW_Seen
then
11967 EW_Val
:= Expr_Val
;
11970 end Analyze_External_Property
;
11972 ----------------------------
11973 -- Analyze_Part_Of_Option --
11974 ----------------------------
11976 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11977 Encap
: constant Node_Id
:= Expression
(Opt
);
11978 Constits
: Elist_Id
;
11979 Encap_Id
: Entity_Id
;
11983 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11986 (Indic
=> First
(Choices
(Opt
)),
11987 Item_Id
=> State_Id
,
11989 Encap_Id
=> Encap_Id
,
11992 -- The Part_Of indicator transforms the abstract state into
11993 -- a constituent of the encapsulating state or single
11994 -- concurrent type.
11997 pragma Assert
(Present
(Encap_Id
));
11998 Constits
:= Part_Of_Constituents
(Encap_Id
);
12000 if No
(Constits
) then
12001 Constits
:= New_Elmt_List
;
12002 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
12005 Append_Elmt
(State_Id
, Constits
);
12006 Set_Encapsulating_State
(State_Id
, Encap_Id
);
12008 end Analyze_Part_Of_Option
;
12010 ----------------------------
12011 -- Check_Duplicate_Option --
12012 ----------------------------
12014 procedure Check_Duplicate_Option
12016 Status
: in out Boolean)
12020 SPARK_Msg_N
("duplicate state option", Opt
);
12024 end Check_Duplicate_Option
;
12026 ------------------------------
12027 -- Check_Duplicate_Property --
12028 ------------------------------
12030 procedure Check_Duplicate_Property
12032 Status
: in out Boolean)
12036 SPARK_Msg_N
("duplicate external property", Prop
);
12040 end Check_Duplicate_Property
;
12042 -----------------------------
12043 -- Check_Ghost_Synchronous --
12044 -----------------------------
12046 procedure Check_Ghost_Synchronous
is
12048 -- A synchronized abstract state cannot be Ghost and vice
12049 -- versa (SPARK RM 6.9(19)).
12051 if Ghost_Seen
and Synchronous_Seen
then
12052 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
12054 end Check_Ghost_Synchronous
;
12056 ---------------------------
12057 -- Create_Abstract_State --
12058 ---------------------------
12060 procedure Create_Abstract_State
12067 -- The abstract state may be semi-declared when the related
12068 -- package was withed through a limited with clause. In that
12069 -- case reuse the entity to fully declare the state.
12071 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
12072 State_Id
:= Entity
(Decl
);
12074 -- Otherwise the elaboration of pragma Abstract_State
12075 -- declares the state.
12078 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
12080 if Present
(Decl
) then
12081 Set_Entity
(Decl
, State_Id
);
12085 -- Null states never come from source
12087 Set_Comes_From_Source
(State_Id
, not Is_Null
);
12088 Set_Parent
(State_Id
, State
);
12089 Set_Ekind
(State_Id
, E_Abstract_State
);
12090 Set_Etype
(State_Id
, Standard_Void_Type
);
12091 Set_Encapsulating_State
(State_Id
, Empty
);
12093 -- Set the SPARK mode from the current context
12095 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
12096 Set_SPARK_Pragma_Inherited
(State_Id
);
12098 -- An abstract state declared within a Ghost region becomes
12099 -- Ghost (SPARK RM 6.9(2)).
12101 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
12102 Set_Is_Ghost_Entity
(State_Id
);
12105 -- Establish a link between the state declaration and the
12106 -- abstract state entity. Note that a null state remains as
12107 -- N_Null and does not carry any linkages.
12109 if not Is_Null
then
12110 if Present
(Decl
) then
12111 Set_Entity
(Decl
, State_Id
);
12112 Set_Etype
(Decl
, Standard_Void_Type
);
12115 -- Every non-null state must be defined, nameable and
12118 Push_Scope
(Pack_Id
);
12119 Generate_Definition
(State_Id
);
12120 Enter_Name
(State_Id
);
12123 end Create_Abstract_State
;
12130 -- Start of processing for Analyze_Abstract_State
12133 -- A package with a null abstract state is not allowed to
12134 -- declare additional states.
12138 ("package & has null abstract state", State
, Pack_Id
);
12140 -- Null states appear as internally generated entities
12142 elsif Nkind
(State
) = N_Null
then
12143 Create_Abstract_State
12144 (Nam
=> New_Internal_Name
('S'),
12146 Loc
=> Sloc
(State
),
12150 -- Catch a case where a null state appears in a list of
12151 -- non-null states.
12153 if Non_Null_Seen
then
12155 ("package & has non-null abstract state",
12159 -- Simple state declaration
12161 elsif Nkind
(State
) = N_Identifier
then
12162 Create_Abstract_State
12163 (Nam
=> Chars
(State
),
12165 Loc
=> Sloc
(State
),
12167 Non_Null_Seen
:= True;
12169 -- State declaration with various options. This construct
12170 -- appears as an extension aggregate in the tree.
12172 elsif Nkind
(State
) = N_Extension_Aggregate
then
12173 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
12174 Create_Abstract_State
12175 (Nam
=> Chars
(Ancestor_Part
(State
)),
12176 Decl
=> Ancestor_Part
(State
),
12177 Loc
=> Sloc
(Ancestor_Part
(State
)),
12179 Non_Null_Seen
:= True;
12182 ("state name must be an identifier",
12183 Ancestor_Part
(State
));
12186 -- Options External, Ghost and Synchronous appear as
12189 Opt
:= First
(Expressions
(State
));
12190 while Present
(Opt
) loop
12191 if Nkind
(Opt
) = N_Identifier
then
12195 if Chars
(Opt
) = Name_External
then
12196 Check_Duplicate_Option
(Opt
, External_Seen
);
12197 Analyze_External_Option
(Opt
);
12201 elsif Chars
(Opt
) = Name_Ghost
then
12202 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
12203 Check_Ghost_Synchronous
;
12205 if Present
(State_Id
) then
12206 Set_Is_Ghost_Entity
(State_Id
);
12211 elsif Chars
(Opt
) = Name_Synchronous
then
12212 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
12213 Check_Ghost_Synchronous
;
12215 -- Option Part_Of without an encapsulating state is
12216 -- illegal (SPARK RM 7.1.4(9)).
12218 elsif Chars
(Opt
) = Name_Part_Of
then
12220 ("indicator Part_Of must denote abstract state, "
12221 & "single protected type or single task type",
12224 -- Do not emit an error message when a previous state
12225 -- declaration with options was not parenthesized as
12226 -- the option is actually another state declaration.
12228 -- with Abstract_State
12229 -- (State_1 with ..., -- missing parentheses
12230 -- (State_2 with ...),
12231 -- State_3) -- ok state declaration
12233 elsif Missing_Parentheses
then
12236 -- Otherwise the option is not allowed. Note that it
12237 -- is not possible to distinguish between an option
12238 -- and a state declaration when a previous state with
12239 -- options not properly parentheses.
12241 -- with Abstract_State
12242 -- (State_1 with ..., -- missing parentheses
12243 -- State_2); -- could be an option
12247 ("simple option not allowed in state declaration",
12251 -- Catch a case where missing parentheses around a state
12252 -- declaration with options cause a subsequent state
12253 -- declaration with options to be treated as an option.
12255 -- with Abstract_State
12256 -- (State_1 with ..., -- missing parentheses
12257 -- (State_2 with ...))
12259 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
12260 Missing_Parentheses
:= True;
12262 ("state declaration must be parenthesized",
12263 Ancestor_Part
(State
));
12265 -- Otherwise the option is malformed
12268 SPARK_Msg_N
("malformed option", Opt
);
12274 -- Options External and Part_Of appear as component
12277 Opt
:= First
(Component_Associations
(State
));
12278 while Present
(Opt
) loop
12279 Opt_Nam
:= First
(Choices
(Opt
));
12281 if Nkind
(Opt_Nam
) = N_Identifier
then
12282 if Chars
(Opt_Nam
) = Name_External
then
12283 Analyze_External_Option
(Opt
);
12285 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
12286 Analyze_Part_Of_Option
(Opt
);
12289 SPARK_Msg_N
("invalid state option", Opt
);
12292 SPARK_Msg_N
("invalid state option", Opt
);
12298 -- Any other attempt to declare a state is illegal
12301 Malformed_State_Error
(State
);
12305 -- Guard against a junk state. In such cases no entity is
12306 -- generated and the subsequent checks cannot be applied.
12308 if Present
(State_Id
) then
12310 -- Verify whether the state does not introduce an illegal
12311 -- hidden state within a package subject to a null abstract
12314 Check_No_Hidden_State
(State_Id
);
12316 -- Check whether the lack of option Part_Of agrees with the
12317 -- placement of the abstract state with respect to the state
12320 if not Part_Of_Seen
then
12321 Check_Missing_Part_Of
(State_Id
);
12324 -- Associate the state with its related package
12326 if No
(Abstract_States
(Pack_Id
)) then
12327 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
12330 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
12332 end Analyze_Abstract_State
;
12334 ---------------------------
12335 -- Malformed_State_Error --
12336 ---------------------------
12338 procedure Malformed_State_Error
(State
: Node_Id
) is
12340 Error_Msg_N
("malformed abstract state declaration", State
);
12342 -- An abstract state with a simple option is being declared
12343 -- with "=>" rather than the legal "with". The state appears
12344 -- as a component association.
12346 if Nkind
(State
) = N_Component_Association
then
12347 Error_Msg_N
("\use WITH to specify simple option", State
);
12349 end Malformed_State_Error
;
12353 Pack_Decl
: Node_Id
;
12354 Pack_Id
: Entity_Id
;
12358 -- Start of processing for Abstract_State
12362 Check_No_Identifiers
;
12363 Check_Arg_Count
(1);
12365 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
12367 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
12368 N_Package_Declaration
)
12374 Pack_Id
:= Defining_Entity
(Pack_Decl
);
12376 -- A pragma that applies to a Ghost entity becomes Ghost for the
12377 -- purposes of legality checks and removal of ignored Ghost code.
12379 Mark_Ghost_Pragma
(N
, Pack_Id
);
12380 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
12382 -- Chain the pragma on the contract for completeness
12384 Add_Contract_Item
(N
, Pack_Id
);
12386 -- The legality checks of pragmas Abstract_State, Initializes, and
12387 -- Initial_Condition are affected by the SPARK mode in effect. In
12388 -- addition, these three pragmas are subject to an inherent order:
12390 -- 1) Abstract_State
12392 -- 3) Initial_Condition
12394 -- Analyze all these pragmas in the order outlined above
12396 Analyze_If_Present
(Pragma_SPARK_Mode
);
12397 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
12399 -- Multiple non-null abstract states appear as an aggregate
12401 if Nkind
(States
) = N_Aggregate
then
12402 State
:= First
(Expressions
(States
));
12403 while Present
(State
) loop
12404 Analyze_Abstract_State
(State
, Pack_Id
);
12408 -- An abstract state with a simple option is being illegaly
12409 -- declared with "=>" rather than "with". In this case the
12410 -- state declaration appears as a component association.
12412 if Present
(Component_Associations
(States
)) then
12413 State
:= First
(Component_Associations
(States
));
12414 while Present
(State
) loop
12415 Malformed_State_Error
(State
);
12420 -- Various forms of a single abstract state. Note that these may
12421 -- include malformed state declarations.
12424 Analyze_Abstract_State
(States
, Pack_Id
);
12427 Analyze_If_Present
(Pragma_Initializes
);
12428 Analyze_If_Present
(Pragma_Initial_Condition
);
12429 end Abstract_State
;
12435 when Pragma_Acc_Data
=> Acc_Data
: declare
12436 Clause_Names
: constant Name_List
:=
12449 Clauses
: Args_List
(Clause_Names
'Range);
12452 if not OpenAcc_Enabled
then
12458 if Nkind
(Parent
(N
)) /= N_Loop_Statement
then
12460 ("Acc_Data pragma should be placed in loop or block "
12464 Gather_Associations
(Clause_Names
, Clauses
);
12466 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12467 Clause
:= Clauses
(Id
);
12469 if Present
(Clause
) then
12470 case Clause_Names
(Id
) is
12478 Validate_Acc_Data_Clause
(Clause
);
12485 Error_Pragma
("unsupported pragma clause");
12488 raise Program_Error
;
12493 Set_Is_OpenAcc_Environment
(Parent
(N
));
12500 when Pragma_Acc_Loop
=> Acc_Loop
: declare
12501 Clause_Names
: constant Name_List
:=
12514 Clauses
: Args_List
(Clause_Names
'Range);
12518 if not OpenAcc_Enabled
then
12524 -- Make sure the pragma is in an openacc construct
12526 Check_Loop_Pragma_Placement
;
12529 while Present
(Par
)
12530 and then (Nkind
(Par
) /= N_Loop_Statement
12531 or else not Is_OpenAcc_Environment
(Par
))
12533 Par
:= Parent
(Par
);
12536 if not Is_OpenAcc_Environment
(Par
) then
12538 ("Acc_Loop directive must be associated with an OpenAcc "
12539 & "construct region");
12542 Gather_Associations
(Clause_Names
, Clauses
);
12544 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12545 Clause
:= Clauses
(Id
);
12547 if Present
(Clause
) then
12548 case Clause_Names
(Id
) is
12555 when Name_Collapse
=>
12556 Validate_Acc_Loop_Collapse
(Clause
);
12559 Validate_Acc_Loop_Gang
(Clause
);
12561 when Name_Acc_Private
=>
12562 Validate_Acc_Data_Clause
(Clause
);
12564 when Name_Reduction
=>
12565 Validate_Acc_Name_Reduction
(Clause
);
12568 Validate_Acc_Size_Expressions
(Clause
);
12570 when Name_Vector
=>
12571 Validate_Acc_Loop_Vector
(Clause
);
12573 when Name_Worker
=>
12574 Validate_Acc_Loop_Worker
(Clause
);
12577 raise Program_Error
;
12582 Set_Is_OpenAcc_Loop
(Parent
(N
));
12585 ----------------------------------
12586 -- Acc_Parallel and Acc_Kernels --
12587 ----------------------------------
12589 when Pragma_Acc_Parallel
12590 | Pragma_Acc_Kernels
12592 Acc_Kernels_Or_Parallel
: declare
12593 Clause_Names
: constant Name_List
:=
12606 Name_Vector_Length
,
12612 Name_First_Private
,
12621 Clauses
: Args_List
(Clause_Names
'Range);
12624 if not OpenAcc_Enabled
then
12629 Check_Loop_Pragma_Placement
;
12631 if Nkind
(Parent
(N
)) /= N_Loop_Statement
then
12633 ("pragma should be placed in loop or block statements");
12636 Gather_Associations
(Clause_Names
, Clauses
);
12638 for Id
in Clause_Names
'First .. Clause_Names
'Last loop
12639 Clause
:= Clauses
(Id
);
12641 if Present
(Clause
) then
12642 if Chars
(Parent
(Clause
)) = No_Name
then
12643 Error_Pragma
("all arguments should be associations");
12645 case Clause_Names
(Id
) is
12647 -- Note: According to the OpenAcc Standard v2.6,
12648 -- Async's argument should be optional. Because this
12649 -- complicates parsing the clause, the argument is
12650 -- made mandatory. The standard defines two negative
12651 -- values, acc_async_noval and acc_async_sync. When
12652 -- given acc_async_noval as value, the clause should
12653 -- behave as if no argument was given. According to
12654 -- the standard, acc_async_noval is defined in header
12655 -- files for C and Fortran, thus this value should
12656 -- probably be defined in the OpenAcc Ada library once
12657 -- it is implemented.
12662 | Name_Vector_Length
12664 Validate_Acc_Int_Expr_Clause
(Clause
);
12666 when Name_Acc_If
=>
12667 Validate_Acc_Condition_Clause
(Clause
);
12669 -- Unsupported by GCC
12674 Error_Pragma
("unsupported clause");
12676 when Name_Acc_Private
12677 | Name_First_Private
12679 if Prag_Id
/= Pragma_Acc_Parallel
then
12681 ("argument is only available for 'Parallel' "
12684 Validate_Acc_Data_Clause
(Clause
);
12694 Validate_Acc_Data_Clause
(Clause
);
12696 when Name_Reduction
=>
12697 if Prag_Id
/= Pragma_Acc_Parallel
then
12699 ("argument is only available for 'Parallel' "
12702 Validate_Acc_Name_Reduction
(Clause
);
12705 when Name_Default
=>
12706 if Chars
(Clause
) /= Name_None
then
12707 Error_Pragma
("expected none");
12710 when Name_Device_Type
=>
12711 Error_Pragma
("unsupported pragma clause");
12713 -- Similar to Name_Async, Name_Wait's arguments should
12714 -- be optional. However, this can be simulated using
12715 -- acc_async_noval, hence, we do not bother making the
12716 -- argument optional for now.
12719 Validate_Acc_Int_Expr_List_Clause
(Clause
);
12722 raise Program_Error
;
12728 Set_Is_OpenAcc_Environment
(Parent
(N
));
12729 end Acc_Kernels_Or_Parallel
;
12737 -- Note: this pragma also has some specific processing in Par.Prag
12738 -- because we want to set the Ada version mode during parsing.
12740 when Pragma_Ada_83
=>
12742 Check_Arg_Count
(0);
12744 -- We really should check unconditionally for proper configuration
12745 -- pragma placement, since we really don't want mixed Ada modes
12746 -- within a single unit, and the GNAT reference manual has always
12747 -- said this was a configuration pragma, but we did not check and
12748 -- are hesitant to add the check now.
12750 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
12751 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
12752 -- or Ada 2012 mode.
12754 if Ada_Version
>= Ada_2005
then
12755 Check_Valid_Configuration_Pragma
;
12758 -- Now set Ada 83 mode
12760 if Latest_Ada_Only
then
12761 Error_Pragma
("??pragma% ignored");
12763 Ada_Version
:= Ada_83
;
12764 Ada_Version_Explicit
:= Ada_83
;
12765 Ada_Version_Pragma
:= N
;
12774 -- Note: this pragma also has some specific processing in Par.Prag
12775 -- because we want to set the Ada 83 version mode during parsing.
12777 when Pragma_Ada_95
=>
12779 Check_Arg_Count
(0);
12781 -- We really should check unconditionally for proper configuration
12782 -- pragma placement, since we really don't want mixed Ada modes
12783 -- within a single unit, and the GNAT reference manual has always
12784 -- said this was a configuration pragma, but we did not check and
12785 -- are hesitant to add the check now.
12787 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
12788 -- or Ada 95, so we must check if we are in Ada 2005 mode.
12790 if Ada_Version
>= Ada_2005
then
12791 Check_Valid_Configuration_Pragma
;
12794 -- Now set Ada 95 mode
12796 if Latest_Ada_Only
then
12797 Error_Pragma
("??pragma% ignored");
12799 Ada_Version
:= Ada_95
;
12800 Ada_Version_Explicit
:= Ada_95
;
12801 Ada_Version_Pragma
:= N
;
12804 ---------------------
12805 -- Ada_05/Ada_2005 --
12806 ---------------------
12809 -- pragma Ada_05 (LOCAL_NAME);
12811 -- pragma Ada_2005;
12812 -- pragma Ada_2005 (LOCAL_NAME):
12814 -- Note: these pragmas also have some specific processing in Par.Prag
12815 -- because we want to set the Ada 2005 version mode during parsing.
12817 -- The one argument form is used for managing the transition from
12818 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12819 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12820 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12821 -- mode, a preference rule is established which does not choose
12822 -- such an entity unless it is unambiguously specified. This avoids
12823 -- extra subprograms marked this way from generating ambiguities in
12824 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12825 -- intended for exclusive use in the GNAT run-time library.
12836 if Arg_Count
= 1 then
12837 Check_Arg_Is_Local_Name
(Arg1
);
12838 E_Id
:= Get_Pragma_Arg
(Arg1
);
12840 if Etype
(E_Id
) = Any_Type
then
12844 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12845 Record_Rep_Item
(Entity
(E_Id
), N
);
12848 Check_Arg_Count
(0);
12850 -- For Ada_2005 we unconditionally enforce the documented
12851 -- configuration pragma placement, since we do not want to
12852 -- tolerate mixed modes in a unit involving Ada 2005. That
12853 -- would cause real difficulties for those cases where there
12854 -- are incompatibilities between Ada 95 and Ada 2005.
12856 Check_Valid_Configuration_Pragma
;
12858 -- Now set appropriate Ada mode
12860 if Latest_Ada_Only
then
12861 Error_Pragma
("??pragma% ignored");
12863 Ada_Version
:= Ada_2005
;
12864 Ada_Version_Explicit
:= Ada_2005
;
12865 Ada_Version_Pragma
:= N
;
12870 ---------------------
12871 -- Ada_12/Ada_2012 --
12872 ---------------------
12875 -- pragma Ada_12 (LOCAL_NAME);
12877 -- pragma Ada_2012;
12878 -- pragma Ada_2012 (LOCAL_NAME):
12880 -- Note: these pragmas also have some specific processing in Par.Prag
12881 -- because we want to set the Ada 2012 version mode during parsing.
12883 -- The one argument form is used for managing the transition from Ada
12884 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12885 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12886 -- mode will generate a warning. In addition, in any pre-Ada_2012
12887 -- mode, a preference rule is established which does not choose
12888 -- such an entity unless it is unambiguously specified. This avoids
12889 -- extra subprograms marked this way from generating ambiguities in
12890 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12891 -- intended for exclusive use in the GNAT run-time library.
12902 if Arg_Count
= 1 then
12903 Check_Arg_Is_Local_Name
(Arg1
);
12904 E_Id
:= Get_Pragma_Arg
(Arg1
);
12906 if Etype
(E_Id
) = Any_Type
then
12910 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12911 Record_Rep_Item
(Entity
(E_Id
), N
);
12914 Check_Arg_Count
(0);
12916 -- For Ada_2012 we unconditionally enforce the documented
12917 -- configuration pragma placement, since we do not want to
12918 -- tolerate mixed modes in a unit involving Ada 2012. That
12919 -- would cause real difficulties for those cases where there
12920 -- are incompatibilities between Ada 95 and Ada 2012. We could
12921 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12923 Check_Valid_Configuration_Pragma
;
12925 -- Now set appropriate Ada mode
12927 Ada_Version
:= Ada_2012
;
12928 Ada_Version_Explicit
:= Ada_2012
;
12929 Ada_Version_Pragma
:= N
;
12937 -- pragma Ada_2020;
12939 -- Note: this pragma also has some specific processing in Par.Prag
12940 -- because we want to set the Ada 2020 version mode during parsing.
12942 when Pragma_Ada_2020
=>
12945 Check_Arg_Count
(0);
12947 Check_Valid_Configuration_Pragma
;
12949 -- Now set appropriate Ada mode
12951 Ada_Version
:= Ada_2020
;
12952 Ada_Version_Explicit
:= Ada_2020
;
12953 Ada_Version_Pragma
:= N
;
12955 ----------------------
12956 -- All_Calls_Remote --
12957 ----------------------
12959 -- pragma All_Calls_Remote [(library_package_NAME)];
12961 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12962 Lib_Entity
: Entity_Id
;
12965 Check_Ada_83_Warning
;
12966 Check_Valid_Library_Unit_Pragma
;
12968 if Nkind
(N
) = N_Null_Statement
then
12972 Lib_Entity
:= Find_Lib_Unit_Name
;
12974 -- A pragma that applies to a Ghost entity becomes Ghost for the
12975 -- purposes of legality checks and removal of ignored Ghost code.
12977 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12979 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12981 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12982 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12983 Error_Pragma
("pragma% only apply to rci unit");
12985 -- Set flag for entity of the library unit
12988 Set_Has_All_Calls_Remote
(Lib_Entity
);
12991 end All_Calls_Remote
;
12993 ---------------------------
12994 -- Allow_Integer_Address --
12995 ---------------------------
12997 -- pragma Allow_Integer_Address;
12999 when Pragma_Allow_Integer_Address
=>
13001 Check_Valid_Configuration_Pragma
;
13002 Check_Arg_Count
(0);
13004 -- If Address is a private type, then set the flag to allow
13005 -- integer address values. If Address is not private, then this
13006 -- pragma has no purpose, so it is simply ignored. Not clear if
13007 -- there are any such targets now.
13009 if Opt
.Address_Is_Private
then
13010 Opt
.Allow_Integer_Address
:= True;
13018 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
13019 -- ARG ::= NAME | EXPRESSION
13021 -- The first two arguments are by convention intended to refer to an
13022 -- external tool and a tool-specific function. These arguments are
13025 when Pragma_Annotate
=> Annotate
: declare
13032 Check_At_Least_N_Arguments
(1);
13034 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
13036 -- Determine whether the last argument is "Entity => local_NAME"
13037 -- and if it is, perform the required semantic checks. Remove the
13038 -- argument from further processing.
13040 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
13041 and then Chars
(Nam_Arg
) = Name_Entity
13043 Check_Arg_Is_Local_Name
(Nam_Arg
);
13044 Arg_Count
:= Arg_Count
- 1;
13046 -- A pragma that applies to a Ghost entity becomes Ghost for
13047 -- the purposes of legality checks and removal of ignored Ghost
13050 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
13051 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
13053 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
13056 -- Not allowed in compiler units (bootstrap issues)
13058 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
13061 -- Continue the processing with last argument removed for now
13063 Check_Arg_Is_Identifier
(Arg1
);
13064 Check_No_Identifiers
;
13067 -- The second parameter is optional, it is never analyzed
13072 -- Otherwise there is a second parameter
13075 -- The second parameter must be an identifier
13077 Check_Arg_Is_Identifier
(Arg2
);
13079 -- Process the remaining parameters (if any)
13081 Arg
:= Next
(Arg2
);
13082 while Present
(Arg
) loop
13083 Expr
:= Get_Pragma_Arg
(Arg
);
13086 if Is_Entity_Name
(Expr
) then
13089 -- For string literals, we assume Standard_String as the
13090 -- type, unless the string contains wide or wide_wide
13093 elsif Nkind
(Expr
) = N_String_Literal
then
13094 if Has_Wide_Wide_Character
(Expr
) then
13095 Resolve
(Expr
, Standard_Wide_Wide_String
);
13096 elsif Has_Wide_Character
(Expr
) then
13097 Resolve
(Expr
, Standard_Wide_String
);
13099 Resolve
(Expr
, Standard_String
);
13102 elsif Is_Overloaded
(Expr
) then
13103 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
13114 -------------------------------------------------
13115 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
13116 -------------------------------------------------
13119 -- ( [Check => ] Boolean_EXPRESSION
13120 -- [, [Message =>] Static_String_EXPRESSION]);
13122 -- pragma Assert_And_Cut
13123 -- ( [Check => ] Boolean_EXPRESSION
13124 -- [, [Message =>] Static_String_EXPRESSION]);
13127 -- ( [Check => ] Boolean_EXPRESSION
13128 -- [, [Message =>] Static_String_EXPRESSION]);
13130 -- pragma Loop_Invariant
13131 -- ( [Check => ] Boolean_EXPRESSION
13132 -- [, [Message =>] Static_String_EXPRESSION]);
13135 | Pragma_Assert_And_Cut
13137 | Pragma_Loop_Invariant
13140 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
13141 -- Determine whether expression Expr contains a Loop_Entry
13142 -- attribute reference.
13144 -------------------------
13145 -- Contains_Loop_Entry --
13146 -------------------------
13148 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
13149 Has_Loop_Entry
: Boolean := False;
13151 function Process
(N
: Node_Id
) return Traverse_Result
;
13152 -- Process function for traversal to look for Loop_Entry
13158 function Process
(N
: Node_Id
) return Traverse_Result
is
13160 if Nkind
(N
) = N_Attribute_Reference
13161 and then Attribute_Name
(N
) = Name_Loop_Entry
13163 Has_Loop_Entry
:= True;
13170 procedure Traverse
is new Traverse_Proc
(Process
);
13172 -- Start of processing for Contains_Loop_Entry
13176 return Has_Loop_Entry
;
13177 end Contains_Loop_Entry
;
13182 New_Args
: List_Id
;
13184 -- Start of processing for Assert
13187 -- Assert is an Ada 2005 RM-defined pragma
13189 if Prag_Id
= Pragma_Assert
then
13192 -- The remaining ones are GNAT pragmas
13198 Check_At_Least_N_Arguments
(1);
13199 Check_At_Most_N_Arguments
(2);
13200 Check_Arg_Order
((Name_Check
, Name_Message
));
13201 Check_Optional_Identifier
(Arg1
, Name_Check
);
13202 Expr
:= Get_Pragma_Arg
(Arg1
);
13204 -- Special processing for Loop_Invariant, Loop_Variant or for
13205 -- other cases where a Loop_Entry attribute is present. If the
13206 -- assertion pragma contains attribute Loop_Entry, ensure that
13207 -- the related pragma is within a loop.
13209 if Prag_Id
= Pragma_Loop_Invariant
13210 or else Prag_Id
= Pragma_Loop_Variant
13211 or else Contains_Loop_Entry
(Expr
)
13213 Check_Loop_Pragma_Placement
;
13215 -- Perform preanalysis to deal with embedded Loop_Entry
13218 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
13221 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
13222 -- a corresponding Check pragma:
13224 -- pragma Check (name, condition [, msg]);
13226 -- Where name is the identifier matching the pragma name. So
13227 -- rewrite pragma in this manner, transfer the message argument
13228 -- if present, and analyze the result
13230 -- Note: When dealing with a semantically analyzed tree, the
13231 -- information that a Check node N corresponds to a source Assert,
13232 -- Assume, or Assert_And_Cut pragma can be retrieved from the
13233 -- pragma kind of Original_Node(N).
13235 New_Args
:= New_List
(
13236 Make_Pragma_Argument_Association
(Loc
,
13237 Expression
=> Make_Identifier
(Loc
, Pname
)),
13238 Make_Pragma_Argument_Association
(Sloc
(Expr
),
13239 Expression
=> Expr
));
13241 if Arg_Count
> 1 then
13242 Check_Optional_Identifier
(Arg2
, Name_Message
);
13244 -- Provide semantic annnotations for optional argument, for
13245 -- ASIS use, before rewriting.
13247 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
13248 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
13251 -- Rewrite as Check pragma
13255 Chars
=> Name_Check
,
13256 Pragma_Argument_Associations
=> New_Args
));
13261 ----------------------
13262 -- Assertion_Policy --
13263 ----------------------
13265 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
13267 -- The following form is Ada 2012 only, but we allow it in all modes
13269 -- Pragma Assertion_Policy (
13270 -- ASSERTION_KIND => POLICY_IDENTIFIER
13271 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
13273 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
13275 -- RM_ASSERTION_KIND ::= Assert |
13276 -- Static_Predicate |
13277 -- Dynamic_Predicate |
13282 -- Type_Invariant |
13283 -- Type_Invariant'Class
13285 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
13287 -- Contract_Cases |
13289 -- Default_Initial_Condition |
13291 -- Initial_Condition |
13292 -- Loop_Invariant |
13298 -- Statement_Assertions
13300 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
13301 -- ID_ASSERTION_KIND list contains implementation-defined additions
13302 -- recognized by GNAT. The effect is to control the behavior of
13303 -- identically named aspects and pragmas, depending on the specified
13304 -- policy identifier:
13306 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
13308 -- Note: Check and Ignore are language-defined. Disable is a GNAT
13309 -- implementation-defined addition that results in totally ignoring
13310 -- the corresponding assertion. If Disable is specified, then the
13311 -- argument of the assertion is not even analyzed. This is useful
13312 -- when the aspect/pragma argument references entities in a with'ed
13313 -- package that is replaced by a dummy package in the final build.
13315 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
13316 -- and Type_Invariant'Class were recognized by the parser and
13317 -- transformed into references to the special internal identifiers
13318 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
13319 -- processing is required here.
13321 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
13322 procedure Resolve_Suppressible
(Policy
: Node_Id
);
13323 -- Converts the assertion policy 'Suppressible' to either Check or
13324 -- Ignore based on whether checks are suppressed via -gnatp.
13326 --------------------------
13327 -- Resolve_Suppressible --
13328 --------------------------
13330 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
13331 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
13335 -- Transform policy argument Suppressible into either Ignore or
13336 -- Check depending on whether checks are enabled or suppressed.
13338 if Chars
(Arg
) = Name_Suppressible
then
13339 if Suppress_Checks
then
13340 Nam
:= Name_Ignore
;
13345 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
13347 end Resolve_Suppressible
;
13359 -- This can always appear as a configuration pragma
13361 if Is_Configuration_Pragma
then
13364 -- It can also appear in a declarative part or package spec in Ada
13365 -- 2012 mode. We allow this in other modes, but in that case we
13366 -- consider that we have an Ada 2012 pragma on our hands.
13369 Check_Is_In_Decl_Part_Or_Package_Spec
;
13373 -- One argument case with no identifier (first form above)
13376 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
13377 or else Chars
(Arg1
) = No_Name
)
13379 Check_Arg_Is_One_Of
(Arg1
,
13380 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13382 Resolve_Suppressible
(Arg1
);
13384 -- Treat one argument Assertion_Policy as equivalent to:
13386 -- pragma Check_Policy (Assertion, policy)
13388 -- So rewrite pragma in that manner and link on to the chain
13389 -- of Check_Policy pragmas, marking the pragma as analyzed.
13391 Policy
:= Get_Pragma_Arg
(Arg1
);
13395 Chars
=> Name_Check_Policy
,
13396 Pragma_Argument_Associations
=> New_List
(
13397 Make_Pragma_Argument_Association
(Loc
,
13398 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
13400 Make_Pragma_Argument_Association
(Loc
,
13402 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
13405 -- Here if we have two or more arguments
13408 Check_At_Least_N_Arguments
(1);
13411 -- Loop through arguments
13414 while Present
(Arg
) loop
13415 LocP
:= Sloc
(Arg
);
13417 -- Kind must be specified
13419 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13420 or else Chars
(Arg
) = No_Name
13423 ("missing assertion kind for pragma%", Arg
);
13426 -- Check Kind and Policy have allowed forms
13428 Kind
:= Chars
(Arg
);
13429 Policy
:= Get_Pragma_Arg
(Arg
);
13431 if not Is_Valid_Assertion_Kind
(Kind
) then
13433 ("invalid assertion kind for pragma%", Arg
);
13436 Check_Arg_Is_One_Of
(Arg
,
13437 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
13439 Resolve_Suppressible
(Arg
);
13441 if Kind
= Name_Ghost
then
13443 -- The Ghost policy must be either Check or Ignore
13444 -- (SPARK RM 6.9(6)).
13446 if not Nam_In
(Chars
(Policy
), Name_Check
,
13450 ("argument of pragma % Ghost must be Check or "
13451 & "Ignore", Policy
);
13454 -- Pragma Assertion_Policy specifying a Ghost policy
13455 -- cannot occur within a Ghost subprogram or package
13456 -- (SPARK RM 6.9(14)).
13458 if Ghost_Mode
> None
then
13460 ("pragma % cannot appear within ghost subprogram or "
13465 -- Rewrite the Assertion_Policy pragma as a series of
13466 -- Check_Policy pragmas of the form:
13468 -- Check_Policy (Kind, Policy);
13470 -- Note: the insertion of the pragmas cannot be done with
13471 -- Insert_Action because in the configuration case, there
13472 -- are no scopes on the scope stack and the mechanism will
13475 Insert_Before_And_Analyze
(N
,
13477 Chars
=> Name_Check_Policy
,
13478 Pragma_Argument_Associations
=> New_List
(
13479 Make_Pragma_Argument_Association
(LocP
,
13480 Expression
=> Make_Identifier
(LocP
, Kind
)),
13481 Make_Pragma_Argument_Association
(LocP
,
13482 Expression
=> Policy
))));
13487 -- Rewrite the Assertion_Policy pragma as null since we have
13488 -- now inserted all the equivalent Check pragmas.
13490 Rewrite
(N
, Make_Null_Statement
(Loc
));
13493 end Assertion_Policy
;
13495 ------------------------------
13496 -- Assume_No_Invalid_Values --
13497 ------------------------------
13499 -- pragma Assume_No_Invalid_Values (On | Off);
13501 when Pragma_Assume_No_Invalid_Values
=>
13503 Check_Valid_Configuration_Pragma
;
13504 Check_Arg_Count
(1);
13505 Check_No_Identifiers
;
13506 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
13508 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
13509 Assume_No_Invalid_Values
:= True;
13511 Assume_No_Invalid_Values
:= False;
13514 --------------------------
13515 -- Attribute_Definition --
13516 --------------------------
13518 -- pragma Attribute_Definition
13519 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
13520 -- [Entity =>] LOCAL_NAME,
13521 -- [Expression =>] EXPRESSION | NAME);
13523 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
13524 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
13529 Check_Arg_Count
(3);
13530 Check_Optional_Identifier
(Arg1
, "attribute");
13531 Check_Optional_Identifier
(Arg2
, "entity");
13532 Check_Optional_Identifier
(Arg3
, "expression");
13534 if Nkind
(Attribute_Designator
) /= N_Identifier
then
13535 Error_Msg_N
("attribute name expected", Attribute_Designator
);
13539 Check_Arg_Is_Local_Name
(Arg2
);
13541 -- If the attribute is not recognized, then issue a warning (not
13542 -- an error), and ignore the pragma.
13544 Aname
:= Chars
(Attribute_Designator
);
13546 if not Is_Attribute_Name
(Aname
) then
13547 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
13551 -- Otherwise, rewrite the pragma as an attribute definition clause
13554 Make_Attribute_Definition_Clause
(Loc
,
13555 Name
=> Get_Pragma_Arg
(Arg2
),
13557 Expression
=> Get_Pragma_Arg
(Arg3
)));
13559 end Attribute_Definition
;
13561 ------------------------------------------------------------------
13562 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
13563 ------------------------------------------------------------------
13565 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
13566 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
13567 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
13568 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
13570 when Pragma_Async_Readers
13571 | Pragma_Async_Writers
13572 | Pragma_Effective_Reads
13573 | Pragma_Effective_Writes
13575 Async_Effective
: declare
13576 Obj_Decl
: Node_Id
;
13577 Obj_Id
: Entity_Id
;
13581 Check_No_Identifiers
;
13582 Check_At_Most_N_Arguments
(1);
13584 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13586 -- Object declaration
13588 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
13593 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13595 -- Perform minimal verification to ensure that the argument is at
13596 -- least a variable. Subsequent finer grained checks will be done
13597 -- at the end of the declarative region the contains the pragma.
13599 if Ekind
(Obj_Id
) = E_Variable
then
13601 -- A pragma that applies to a Ghost entity becomes Ghost for
13602 -- the purposes of legality checks and removal of ignored Ghost
13605 Mark_Ghost_Pragma
(N
, Obj_Id
);
13607 -- Chain the pragma on the contract for further processing by
13608 -- Analyze_External_Property_In_Decl_Part.
13610 Add_Contract_Item
(N
, Obj_Id
);
13612 -- Analyze the Boolean expression (if any)
13614 if Present
(Arg1
) then
13615 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13618 -- Otherwise the external property applies to a constant
13621 Error_Pragma
("pragma % must apply to a volatile object");
13623 end Async_Effective
;
13629 -- pragma Asynchronous (LOCAL_NAME);
13631 when Pragma_Asynchronous
=> Asynchronous
: declare
13634 Formal
: Entity_Id
;
13639 procedure Process_Async_Pragma
;
13640 -- Common processing for procedure and access-to-procedure case
13642 --------------------------
13643 -- Process_Async_Pragma --
13644 --------------------------
13646 procedure Process_Async_Pragma
is
13649 Set_Is_Asynchronous
(Nm
);
13653 -- The formals should be of mode IN (RM E.4.1(6))
13656 while Present
(S
) loop
13657 Formal
:= Defining_Identifier
(S
);
13659 if Nkind
(Formal
) = N_Defining_Identifier
13660 and then Ekind
(Formal
) /= E_In_Parameter
13663 ("pragma% procedure can only have IN parameter",
13670 Set_Is_Asynchronous
(Nm
);
13671 end Process_Async_Pragma
;
13673 -- Start of processing for pragma Asynchronous
13676 Check_Ada_83_Warning
;
13677 Check_No_Identifiers
;
13678 Check_Arg_Count
(1);
13679 Check_Arg_Is_Local_Name
(Arg1
);
13681 if Debug_Flag_U
then
13685 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
13686 Analyze
(Get_Pragma_Arg
(Arg1
));
13687 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
13689 -- A pragma that applies to a Ghost entity becomes Ghost for the
13690 -- purposes of legality checks and removal of ignored Ghost code.
13692 Mark_Ghost_Pragma
(N
, Nm
);
13694 if not Is_Remote_Call_Interface
(C_Ent
)
13695 and then not Is_Remote_Types
(C_Ent
)
13697 -- This pragma should only appear in an RCI or Remote Types
13698 -- unit (RM E.4.1(4)).
13701 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
13704 if Ekind
(Nm
) = E_Procedure
13705 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
13707 if not Is_Remote_Call_Interface
(Nm
) then
13709 ("pragma% cannot be applied on non-remote procedure",
13713 L
:= Parameter_Specifications
(Parent
(Nm
));
13714 Process_Async_Pragma
;
13717 elsif Ekind
(Nm
) = E_Function
then
13719 ("pragma% cannot be applied to function", Arg1
);
13721 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
13722 if Is_Record_Type
(Nm
) then
13724 -- A record type that is the Equivalent_Type for a remote
13725 -- access-to-subprogram type.
13727 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
13730 -- A non-expanded RAS type (distribution is not enabled)
13732 Decl
:= Declaration_Node
(Nm
);
13735 if Nkind
(Decl
) = N_Full_Type_Declaration
13736 and then Nkind
(Type_Definition
(Decl
)) =
13737 N_Access_Procedure_Definition
13739 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
13740 Process_Async_Pragma
;
13742 if Is_Asynchronous
(Nm
)
13743 and then Expander_Active
13744 and then Get_PCS_Name
/= Name_No_DSA
13746 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
13751 ("pragma% cannot reference access-to-function type",
13755 -- Only other possibility is Access-to-class-wide type
13757 elsif Is_Access_Type
(Nm
)
13758 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
13760 Check_First_Subtype
(Arg1
);
13761 Set_Is_Asynchronous
(Nm
);
13762 if Expander_Active
then
13763 RACW_Type_Is_Asynchronous
(Nm
);
13767 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
13775 -- pragma Atomic (LOCAL_NAME);
13777 when Pragma_Atomic
=>
13778 Process_Atomic_Independent_Shared_Volatile
;
13780 -----------------------
13781 -- Atomic_Components --
13782 -----------------------
13784 -- pragma Atomic_Components (array_LOCAL_NAME);
13786 -- This processing is shared by Volatile_Components
13788 when Pragma_Atomic_Components
13789 | Pragma_Volatile_Components
13791 Atomic_Components
: declare
13798 Check_Ada_83_Warning
;
13799 Check_No_Identifiers
;
13800 Check_Arg_Count
(1);
13801 Check_Arg_Is_Local_Name
(Arg1
);
13802 E_Id
:= Get_Pragma_Arg
(Arg1
);
13804 if Etype
(E_Id
) = Any_Type
then
13808 E
:= Entity
(E_Id
);
13810 -- A pragma that applies to a Ghost entity becomes Ghost for the
13811 -- purposes of legality checks and removal of ignored Ghost code.
13813 Mark_Ghost_Pragma
(N
, E
);
13814 Check_Duplicate_Pragma
(E
);
13816 if Rep_Item_Too_Early
(E
, N
)
13818 Rep_Item_Too_Late
(E
, N
)
13823 D
:= Declaration_Node
(E
);
13826 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13828 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13829 and then Nkind
(D
) = N_Object_Declaration
13830 and then Nkind
(Object_Definition
(D
)) =
13831 N_Constrained_Array_Definition
)
13833 -- The flag is set on the object, or on the base type
13835 if Nkind
(D
) /= N_Object_Declaration
then
13836 E
:= Base_Type
(E
);
13839 -- Atomic implies both Independent and Volatile
13841 if Prag_Id
= Pragma_Atomic_Components
then
13842 Set_Has_Atomic_Components
(E
);
13843 Set_Has_Independent_Components
(E
);
13846 Set_Has_Volatile_Components
(E
);
13849 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13851 end Atomic_Components
;
13853 --------------------
13854 -- Attach_Handler --
13855 --------------------
13857 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13859 when Pragma_Attach_Handler
=>
13860 Check_Ada_83_Warning
;
13861 Check_No_Identifiers
;
13862 Check_Arg_Count
(2);
13864 if No_Run_Time_Mode
then
13865 Error_Msg_CRT
("Attach_Handler pragma", N
);
13867 Check_Interrupt_Or_Attach_Handler
;
13869 -- The expression that designates the attribute may depend on a
13870 -- discriminant, and is therefore a per-object expression, to
13871 -- be expanded in the init proc. If expansion is enabled, then
13872 -- perform semantic checks on a copy only.
13877 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13880 -- In Relaxed_RM_Semantics mode, we allow any static
13881 -- integer value, for compatibility with other compilers.
13883 if Relaxed_RM_Semantics
13884 and then Nkind
(Parg2
) = N_Integer_Literal
13886 Typ
:= Standard_Integer
;
13888 Typ
:= RTE
(RE_Interrupt_ID
);
13891 if Expander_Active
then
13892 Temp
:= New_Copy_Tree
(Parg2
);
13893 Set_Parent
(Temp
, N
);
13894 Preanalyze_And_Resolve
(Temp
, Typ
);
13897 Resolve
(Parg2
, Typ
);
13901 Process_Interrupt_Or_Attach_Handler
;
13904 --------------------
13905 -- C_Pass_By_Copy --
13906 --------------------
13908 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13910 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13916 Check_Valid_Configuration_Pragma
;
13917 Check_Arg_Count
(1);
13918 Check_Optional_Identifier
(Arg1
, "max_size");
13920 Arg
:= Get_Pragma_Arg
(Arg1
);
13921 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13923 Val
:= Expr_Value
(Arg
);
13927 ("maximum size for pragma% must be positive", Arg1
);
13929 elsif UI_Is_In_Int_Range
(Val
) then
13930 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13932 -- If a giant value is given, Int'Last will do well enough.
13933 -- If sometime someone complains that a record larger than
13934 -- two gigabytes is not copied, we will worry about it then.
13937 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13939 end C_Pass_By_Copy
;
13945 -- pragma Check ([Name =>] CHECK_KIND,
13946 -- [Check =>] Boolean_EXPRESSION
13947 -- [,[Message =>] String_EXPRESSION]);
13949 -- CHECK_KIND ::= IDENTIFIER |
13952 -- Invariant'Class |
13953 -- Type_Invariant'Class
13955 -- The identifiers Assertions and Statement_Assertions are not
13956 -- allowed, since they have special meaning for Check_Policy.
13958 -- WARNING: The code below manages Ghost regions. Return statements
13959 -- must be replaced by gotos which jump to the end of the code and
13960 -- restore the Ghost mode.
13962 when Pragma_Check
=> Check
: declare
13963 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13964 Saved_IGR
: constant Node_Id
:= Ignored_Ghost_Region
;
13965 -- Save the Ghost-related attributes to restore on exit
13971 pragma Warnings
(Off
, Str
);
13974 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13975 -- the mode now to ensure that any nodes generated during analysis
13976 -- and expansion are marked as Ghost.
13978 Set_Ghost_Mode
(N
);
13981 Check_At_Least_N_Arguments
(2);
13982 Check_At_Most_N_Arguments
(3);
13983 Check_Optional_Identifier
(Arg1
, Name_Name
);
13984 Check_Optional_Identifier
(Arg2
, Name_Check
);
13986 if Arg_Count
= 3 then
13987 Check_Optional_Identifier
(Arg3
, Name_Message
);
13988 Str
:= Get_Pragma_Arg
(Arg3
);
13991 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13992 Check_Arg_Is_Identifier
(Arg1
);
13993 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13995 -- Check forbidden name Assertions or Statement_Assertions
13998 when Name_Assertions
=>
14000 ("""Assertions"" is not allowed as a check kind for "
14001 & "pragma%", Arg1
);
14003 when Name_Statement_Assertions
=>
14005 ("""Statement_Assertions"" is not allowed as a check kind "
14006 & "for pragma%", Arg1
);
14012 -- Check applicable policy. We skip this if Checked/Ignored status
14013 -- is already set (e.g. in the case of a pragma from an aspect).
14015 if Is_Checked
(N
) or else Is_Ignored
(N
) then
14018 -- For a non-source pragma that is a rewriting of another pragma,
14019 -- copy the Is_Checked/Ignored status from the rewritten pragma.
14021 elsif Is_Rewrite_Substitution
(N
)
14022 and then Nkind
(Original_Node
(N
)) = N_Pragma
14024 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
14025 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
14027 -- Otherwise query the applicable policy at this point
14030 case Check_Kind
(Cname
) is
14031 when Name_Ignore
=>
14032 Set_Is_Ignored
(N
, True);
14033 Set_Is_Checked
(N
, False);
14036 Set_Is_Ignored
(N
, False);
14037 Set_Is_Checked
(N
, True);
14039 -- For disable, rewrite pragma as null statement and skip
14040 -- rest of the analysis of the pragma.
14042 when Name_Disable
=>
14043 Rewrite
(N
, Make_Null_Statement
(Loc
));
14047 -- No other possibilities
14050 raise Program_Error
;
14054 -- If check kind was not Disable, then continue pragma analysis
14056 Expr
:= Get_Pragma_Arg
(Arg2
);
14058 -- Deal with SCO generation
14060 if Is_Checked
(N
) and then not Split_PPC
(N
) then
14061 Set_SCO_Pragma_Enabled
(Loc
);
14064 -- Deal with analyzing the string argument. If checks are not
14065 -- on we don't want any expansion (since such expansion would
14066 -- not get properly deleted) but we do want to analyze (to get
14067 -- proper references). The Preanalyze_And_Resolve routine does
14068 -- just what we want. Ditto if pragma is active, because it will
14069 -- be rewritten as an if-statement whose analysis will complete
14070 -- analysis and expansion of the string message. This makes a
14071 -- difference in the unusual case where the expression for the
14072 -- string may have a side effect, such as raising an exception.
14073 -- This is mandated by RM 11.4.2, which specifies that the string
14074 -- expression is only evaluated if the check fails and
14075 -- Assertion_Error is to be raised.
14077 if Arg_Count
= 3 then
14078 Preanalyze_And_Resolve
(Str
, Standard_String
);
14081 -- Now you might think we could just do the same with the Boolean
14082 -- expression if checks are off (and expansion is on) and then
14083 -- rewrite the check as a null statement. This would work but we
14084 -- would lose the useful warnings about an assertion being bound
14085 -- to fail even if assertions are turned off.
14087 -- So instead we wrap the boolean expression in an if statement
14088 -- that looks like:
14090 -- if False and then condition then
14094 -- The reason we do this rewriting during semantic analysis rather
14095 -- than as part of normal expansion is that we cannot analyze and
14096 -- expand the code for the boolean expression directly, or it may
14097 -- cause insertion of actions that would escape the attempt to
14098 -- suppress the check code.
14100 -- Note that the Sloc for the if statement corresponds to the
14101 -- argument condition, not the pragma itself. The reason for
14102 -- this is that we may generate a warning if the condition is
14103 -- False at compile time, and we do not want to delete this
14104 -- warning when we delete the if statement.
14106 if Expander_Active
and Is_Ignored
(N
) then
14107 Eloc
:= Sloc
(Expr
);
14110 Make_If_Statement
(Eloc
,
14112 Make_And_Then
(Eloc
,
14113 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
14114 Right_Opnd
=> Expr
),
14115 Then_Statements
=> New_List
(
14116 Make_Null_Statement
(Eloc
))));
14118 -- Now go ahead and analyze the if statement
14120 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14122 -- One rather special treatment. If we are now in Eliminated
14123 -- overflow mode, then suppress overflow checking since we do
14124 -- not want to drag in the bignum stuff if we are in Ignore
14125 -- mode anyway. This is particularly important if we are using
14126 -- a configurable run time that does not support bignum ops.
14128 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
14130 Svo
: constant Boolean :=
14131 Scope_Suppress
.Suppress
(Overflow_Check
);
14133 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
14134 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
14136 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
14137 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
14140 -- Not that special case
14146 -- All done with this check
14148 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14150 -- Check is active or expansion not active. In these cases we can
14151 -- just go ahead and analyze the boolean with no worries.
14154 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
14155 Analyze_And_Resolve
(Expr
, Any_Boolean
);
14156 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
14159 Restore_Ghost_Region
(Saved_GM
, Saved_IGR
);
14162 --------------------------
14163 -- Check_Float_Overflow --
14164 --------------------------
14166 -- pragma Check_Float_Overflow;
14168 when Pragma_Check_Float_Overflow
=>
14170 Check_Valid_Configuration_Pragma
;
14171 Check_Arg_Count
(0);
14172 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
14178 -- pragma Check_Name (check_IDENTIFIER);
14180 when Pragma_Check_Name
=>
14182 Check_No_Identifiers
;
14183 Check_Valid_Configuration_Pragma
;
14184 Check_Arg_Count
(1);
14185 Check_Arg_Is_Identifier
(Arg1
);
14188 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
14191 for J
in Check_Names
.First
.. Check_Names
.Last
loop
14192 if Check_Names
.Table
(J
) = Nam
then
14197 Check_Names
.Append
(Nam
);
14204 -- This is the old style syntax, which is still allowed in all modes:
14206 -- pragma Check_Policy ([Name =>] CHECK_KIND
14207 -- [Policy =>] POLICY_IDENTIFIER);
14209 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
14211 -- CHECK_KIND ::= IDENTIFIER |
14214 -- Type_Invariant'Class |
14217 -- This is the new style syntax, compatible with Assertion_Policy
14218 -- and also allowed in all modes.
14220 -- Pragma Check_Policy (
14221 -- CHECK_KIND => POLICY_IDENTIFIER
14222 -- {, CHECK_KIND => POLICY_IDENTIFIER});
14224 -- Note: the identifiers Name and Policy are not allowed as
14225 -- Check_Kind values. This avoids ambiguities between the old and
14226 -- new form syntax.
14228 when Pragma_Check_Policy
=> Check_Policy
: declare
14233 Check_At_Least_N_Arguments
(1);
14235 -- A Check_Policy pragma can appear either as a configuration
14236 -- pragma, or in a declarative part or a package spec (see RM
14237 -- 11.5(5) for rules for Suppress/Unsuppress which are also
14238 -- followed for Check_Policy).
14240 if not Is_Configuration_Pragma
then
14241 Check_Is_In_Decl_Part_Or_Package_Spec
;
14244 -- Figure out if we have the old or new syntax. We have the
14245 -- old syntax if the first argument has no identifier, or the
14246 -- identifier is Name.
14248 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
14249 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
14253 Check_Arg_Count
(2);
14254 Check_Optional_Identifier
(Arg1
, Name_Name
);
14255 Kind
:= Get_Pragma_Arg
(Arg1
);
14256 Rewrite_Assertion_Kind
(Kind
,
14257 From_Policy
=> Comes_From_Source
(N
));
14258 Check_Arg_Is_Identifier
(Arg1
);
14260 -- Check forbidden check kind
14262 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
14263 Error_Msg_Name_2
:= Chars
(Kind
);
14265 ("pragma% does not allow% as check name", Arg1
);
14270 Check_Optional_Identifier
(Arg2
, Name_Policy
);
14271 Check_Arg_Is_One_Of
14273 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
14275 -- And chain pragma on the Check_Policy_List for search
14277 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
14278 Opt
.Check_Policy_List
:= N
;
14280 -- For the new syntax, what we do is to convert each argument to
14281 -- an old syntax equivalent. We do that because we want to chain
14282 -- old style Check_Policy pragmas for the search (we don't want
14283 -- to have to deal with multiple arguments in the search).
14294 while Present
(Arg
) loop
14295 LocP
:= Sloc
(Arg
);
14296 Argx
:= Get_Pragma_Arg
(Arg
);
14298 -- Kind must be specified
14300 if Nkind
(Arg
) /= N_Pragma_Argument_Association
14301 or else Chars
(Arg
) = No_Name
14304 ("missing assertion kind for pragma%", Arg
);
14307 -- Construct equivalent old form syntax Check_Policy
14308 -- pragma and insert it to get remaining checks.
14312 Chars
=> Name_Check_Policy
,
14313 Pragma_Argument_Associations
=> New_List
(
14314 Make_Pragma_Argument_Association
(LocP
,
14316 Make_Identifier
(LocP
, Chars
(Arg
))),
14317 Make_Pragma_Argument_Association
(Sloc
(Argx
),
14318 Expression
=> Argx
)));
14322 -- For a configuration pragma, insert old form in
14323 -- the corresponding file.
14325 if Is_Configuration_Pragma
then
14326 Insert_After
(N
, New_P
);
14330 Insert_Action
(N
, New_P
);
14334 -- Rewrite original Check_Policy pragma to null, since we
14335 -- have converted it into a series of old syntax pragmas.
14337 Rewrite
(N
, Make_Null_Statement
(Loc
));
14347 -- pragma Comment (static_string_EXPRESSION)
14349 -- Processing for pragma Comment shares the circuitry for pragma
14350 -- Ident. The only differences are that Ident enforces a limit of 31
14351 -- characters on its argument, and also enforces limitations on
14352 -- placement for DEC compatibility. Pragma Comment shares neither of
14353 -- these restrictions.
14355 -------------------
14356 -- Common_Object --
14357 -------------------
14359 -- pragma Common_Object (
14360 -- [Internal =>] LOCAL_NAME
14361 -- [, [External =>] EXTERNAL_SYMBOL]
14362 -- [, [Size =>] EXTERNAL_SYMBOL]);
14364 -- Processing for this pragma is shared with Psect_Object
14366 ------------------------
14367 -- Compile_Time_Error --
14368 ------------------------
14370 -- pragma Compile_Time_Error
14371 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14373 when Pragma_Compile_Time_Error
=>
14375 Process_Compile_Time_Warning_Or_Error
;
14377 --------------------------
14378 -- Compile_Time_Warning --
14379 --------------------------
14381 -- pragma Compile_Time_Warning
14382 -- (boolean_EXPRESSION, static_string_EXPRESSION);
14384 when Pragma_Compile_Time_Warning
=>
14386 Process_Compile_Time_Warning_Or_Error
;
14388 ---------------------------
14389 -- Compiler_Unit_Warning --
14390 ---------------------------
14392 -- pragma Compiler_Unit_Warning;
14396 -- Originally, we had only pragma Compiler_Unit, and it resulted in
14397 -- errors not warnings. This means that we had introduced a big extra
14398 -- inertia to compiler changes, since even if we implemented a new
14399 -- feature, and even if all versions to be used for bootstrapping
14400 -- implemented this new feature, we could not use it, since old
14401 -- compilers would give errors for using this feature in units
14402 -- having Compiler_Unit pragmas.
14404 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
14405 -- problem. We no longer have any units mentioning Compiler_Unit,
14406 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
14407 -- and thus generates a warning which can be ignored. So that deals
14408 -- with the problem of old compilers not implementing the newer form
14411 -- Newer compilers recognize the new pragma, but generate warning
14412 -- messages instead of errors, which again can be ignored in the
14413 -- case of an old compiler which implements a wanted new feature
14414 -- but at the time felt like warning about it for older compilers.
14416 -- We retain Compiler_Unit so that new compilers can be used to build
14417 -- older run-times that use this pragma. That's an unusual case, but
14418 -- it's easy enough to handle, so why not?
14420 when Pragma_Compiler_Unit
14421 | Pragma_Compiler_Unit_Warning
14424 Check_Arg_Count
(0);
14426 -- Only recognized in main unit
14428 if Current_Sem_Unit
= Main_Unit
then
14429 Compiler_Unit
:= True;
14432 -----------------------------
14433 -- Complete_Representation --
14434 -----------------------------
14436 -- pragma Complete_Representation;
14438 when Pragma_Complete_Representation
=>
14440 Check_Arg_Count
(0);
14442 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
14444 ("pragma & must appear within record representation clause");
14447 ----------------------------
14448 -- Complex_Representation --
14449 ----------------------------
14451 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
14453 when Pragma_Complex_Representation
=> Complex_Representation
: declare
14460 Check_Arg_Count
(1);
14461 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14462 Check_Arg_Is_Local_Name
(Arg1
);
14463 E_Id
:= Get_Pragma_Arg
(Arg1
);
14465 if Etype
(E_Id
) = Any_Type
then
14469 E
:= Entity
(E_Id
);
14471 if not Is_Record_Type
(E
) then
14473 ("argument for pragma% must be record type", Arg1
);
14476 Ent
:= First_Entity
(E
);
14479 or else No
(Next_Entity
(Ent
))
14480 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
14481 or else not Is_Floating_Point_Type
(Etype
(Ent
))
14482 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
14485 ("record for pragma% must have two fields of the same "
14486 & "floating-point type", Arg1
);
14489 Set_Has_Complex_Representation
(Base_Type
(E
));
14491 -- We need to treat the type has having a non-standard
14492 -- representation, for back-end purposes, even though in
14493 -- general a complex will have the default representation
14494 -- of a record with two real components.
14496 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
14498 end Complex_Representation
;
14500 -------------------------
14501 -- Component_Alignment --
14502 -------------------------
14504 -- pragma Component_Alignment (
14505 -- [Form =>] ALIGNMENT_CHOICE
14506 -- [, [Name =>] type_LOCAL_NAME]);
14508 -- ALIGNMENT_CHOICE ::=
14510 -- | Component_Size_4
14514 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
14515 Args
: Args_List
(1 .. 2);
14516 Names
: constant Name_List
(1 .. 2) := (
14520 Form
: Node_Id
renames Args
(1);
14521 Name
: Node_Id
renames Args
(2);
14523 Atype
: Component_Alignment_Kind
;
14528 Gather_Associations
(Names
, Args
);
14531 Error_Pragma
("missing Form argument for pragma%");
14534 Check_Arg_Is_Identifier
(Form
);
14536 -- Get proper alignment, note that Default = Component_Size on all
14537 -- machines we have so far, and we want to set this value rather
14538 -- than the default value to indicate that it has been explicitly
14539 -- set (and thus will not get overridden by the default component
14540 -- alignment for the current scope)
14542 if Chars
(Form
) = Name_Component_Size
then
14543 Atype
:= Calign_Component_Size
;
14545 elsif Chars
(Form
) = Name_Component_Size_4
then
14546 Atype
:= Calign_Component_Size_4
;
14548 elsif Chars
(Form
) = Name_Default
then
14549 Atype
:= Calign_Component_Size
;
14551 elsif Chars
(Form
) = Name_Storage_Unit
then
14552 Atype
:= Calign_Storage_Unit
;
14556 ("invalid Form parameter for pragma%", Form
);
14559 -- The pragma appears in a configuration file
14561 if No
(Parent
(N
)) then
14562 Check_Valid_Configuration_Pragma
;
14564 -- Capture the component alignment in a global variable when
14565 -- the pragma appears in a configuration file. Note that the
14566 -- scope stack is empty at this point and cannot be used to
14567 -- store the alignment value.
14569 Configuration_Component_Alignment
:= Atype
;
14571 -- Case with no name, supplied, affects scope table entry
14573 elsif No
(Name
) then
14575 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
14577 -- Case of name supplied
14580 Check_Arg_Is_Local_Name
(Name
);
14582 Typ
:= Entity
(Name
);
14585 or else Rep_Item_Too_Early
(Typ
, N
)
14589 Typ
:= Underlying_Type
(Typ
);
14592 if not Is_Record_Type
(Typ
)
14593 and then not Is_Array_Type
(Typ
)
14596 ("Name parameter of pragma% must identify record or "
14597 & "array type", Name
);
14600 -- An explicit Component_Alignment pragma overrides an
14601 -- implicit pragma Pack, but not an explicit one.
14603 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
14604 Set_Is_Packed
(Base_Type
(Typ
), False);
14605 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
14608 end Component_AlignmentP
;
14610 --------------------------------
14611 -- Constant_After_Elaboration --
14612 --------------------------------
14614 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
14616 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
14618 Obj_Decl
: Node_Id
;
14619 Obj_Id
: Entity_Id
;
14623 Check_No_Identifiers
;
14624 Check_At_Most_N_Arguments
(1);
14626 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
14628 if Nkind
(Obj_Decl
) /= N_Object_Declaration
then
14633 Obj_Id
:= Defining_Entity
(Obj_Decl
);
14635 -- The object declaration must be a library-level variable which
14636 -- is either explicitly initialized or obtains a value during the
14637 -- elaboration of a package body (SPARK RM 3.3.1).
14639 if Ekind
(Obj_Id
) = E_Variable
then
14640 if not Is_Library_Level_Entity
(Obj_Id
) then
14642 ("pragma % must apply to a library level variable");
14646 -- Otherwise the pragma applies to a constant, which is illegal
14649 Error_Pragma
("pragma % must apply to a variable declaration");
14653 -- A pragma that applies to a Ghost entity becomes Ghost for the
14654 -- purposes of legality checks and removal of ignored Ghost code.
14656 Mark_Ghost_Pragma
(N
, Obj_Id
);
14658 -- Chain the pragma on the contract for completeness
14660 Add_Contract_Item
(N
, Obj_Id
);
14662 -- Analyze the Boolean expression (if any)
14664 if Present
(Arg1
) then
14665 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
14667 end Constant_After_Elaboration
;
14669 --------------------
14670 -- Contract_Cases --
14671 --------------------
14673 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
14675 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
14677 -- CASE_GUARD ::= boolean_EXPRESSION | others
14679 -- CONSEQUENCE ::= boolean_EXPRESSION
14681 -- Characteristics:
14683 -- * Analysis - The annotation undergoes initial checks to verify
14684 -- the legal placement and context. Secondary checks preanalyze the
14687 -- Analyze_Contract_Cases_In_Decl_Part
14689 -- * Expansion - The annotation is expanded during the expansion of
14690 -- the related subprogram [body] contract as performed in:
14692 -- Expand_Subprogram_Contract
14694 -- * Template - The annotation utilizes the generic template of the
14695 -- related subprogram [body] when it is:
14697 -- aspect on subprogram declaration
14698 -- aspect on stand-alone subprogram body
14699 -- pragma on stand-alone subprogram body
14701 -- The annotation must prepare its own template when it is:
14703 -- pragma on subprogram declaration
14705 -- * Globals - Capture of global references must occur after full
14708 -- * Instance - The annotation is instantiated automatically when
14709 -- the related generic subprogram [body] is instantiated except for
14710 -- the "pragma on subprogram declaration" case. In that scenario
14711 -- the annotation must instantiate itself.
14713 when Pragma_Contract_Cases
=> Contract_Cases
: declare
14714 Spec_Id
: Entity_Id
;
14715 Subp_Decl
: Node_Id
;
14716 Subp_Spec
: Node_Id
;
14720 Check_No_Identifiers
;
14721 Check_Arg_Count
(1);
14723 -- Ensure the proper placement of the pragma. Contract_Cases must
14724 -- be associated with a subprogram declaration or a body that acts
14728 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14732 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
14735 -- Generic subprogram
14737 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14740 -- Body acts as spec
14742 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14743 and then No
(Corresponding_Spec
(Subp_Decl
))
14747 -- Body stub acts as spec
14749 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14750 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14756 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14757 Subp_Spec
:= Specification
(Subp_Decl
);
14759 -- Pragma Contract_Cases is forbidden on null procedures, as
14760 -- this may lead to potential ambiguities in behavior when
14761 -- interface null procedures are involved.
14763 if Nkind
(Subp_Spec
) = N_Procedure_Specification
14764 and then Null_Present
(Subp_Spec
)
14766 Error_Msg_N
(Fix_Error
14767 ("pragma % cannot apply to null procedure"), N
);
14776 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14778 -- A pragma that applies to a Ghost entity becomes Ghost for the
14779 -- purposes of legality checks and removal of ignored Ghost code.
14781 Mark_Ghost_Pragma
(N
, Spec_Id
);
14782 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
14784 -- Chain the pragma on the contract for further processing by
14785 -- Analyze_Contract_Cases_In_Decl_Part.
14787 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14789 -- Fully analyze the pragma when it appears inside an entry
14790 -- or subprogram body because it cannot benefit from forward
14793 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14795 N_Subprogram_Body_Stub
)
14797 -- The legality checks of pragma Contract_Cases are affected by
14798 -- the SPARK mode in effect and the volatility of the context.
14799 -- Analyze all pragmas in a specific order.
14801 Analyze_If_Present
(Pragma_SPARK_Mode
);
14802 Analyze_If_Present
(Pragma_Volatile_Function
);
14803 Analyze_Contract_Cases_In_Decl_Part
(N
);
14805 end Contract_Cases
;
14811 -- pragma Controlled (first_subtype_LOCAL_NAME);
14813 when Pragma_Controlled
=> Controlled
: declare
14817 Check_No_Identifiers
;
14818 Check_Arg_Count
(1);
14819 Check_Arg_Is_Local_Name
(Arg1
);
14820 Arg
:= Get_Pragma_Arg
(Arg1
);
14822 if not Is_Entity_Name
(Arg
)
14823 or else not Is_Access_Type
(Entity
(Arg
))
14825 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14827 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14835 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14836 -- [Entity =>] LOCAL_NAME);
14838 when Pragma_Convention
=> Convention
: declare
14841 pragma Warnings
(Off
, C
);
14842 pragma Warnings
(Off
, E
);
14845 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14846 Check_Ada_83_Warning
;
14847 Check_Arg_Count
(2);
14848 Process_Convention
(C
, E
);
14850 -- A pragma that applies to a Ghost entity becomes Ghost for the
14851 -- purposes of legality checks and removal of ignored Ghost code.
14853 Mark_Ghost_Pragma
(N
, E
);
14856 ---------------------------
14857 -- Convention_Identifier --
14858 ---------------------------
14860 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14861 -- [Convention =>] convention_IDENTIFIER);
14863 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14869 Check_Arg_Order
((Name_Name
, Name_Convention
));
14870 Check_Arg_Count
(2);
14871 Check_Optional_Identifier
(Arg1
, Name_Name
);
14872 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14873 Check_Arg_Is_Identifier
(Arg1
);
14874 Check_Arg_Is_Identifier
(Arg2
);
14875 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14876 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14878 if Is_Convention_Name
(Cname
) then
14879 Record_Convention_Identifier
14880 (Idnam
, Get_Convention_Id
(Cname
));
14883 ("second arg for % pragma must be convention", Arg2
);
14885 end Convention_Identifier
;
14891 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14893 when Pragma_CPP_Class
=>
14896 if Warn_On_Obsolescent_Feature
then
14898 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14899 & "effect; replace it by pragma import?j?", N
);
14902 Check_Arg_Count
(1);
14906 Chars
=> Name_Import
,
14907 Pragma_Argument_Associations
=> New_List
(
14908 Make_Pragma_Argument_Association
(Loc
,
14909 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14910 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14913 ---------------------
14914 -- CPP_Constructor --
14915 ---------------------
14917 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14918 -- [, [External_Name =>] static_string_EXPRESSION ]
14919 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14921 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14924 Def_Id
: Entity_Id
;
14925 Tag_Typ
: Entity_Id
;
14929 Check_At_Least_N_Arguments
(1);
14930 Check_At_Most_N_Arguments
(3);
14931 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14932 Check_Arg_Is_Local_Name
(Arg1
);
14934 Id
:= Get_Pragma_Arg
(Arg1
);
14935 Find_Program_Unit_Name
(Id
);
14937 -- If we did not find the name, we are done
14939 if Etype
(Id
) = Any_Type
then
14943 Def_Id
:= Entity
(Id
);
14945 -- Check if already defined as constructor
14947 if Is_Constructor
(Def_Id
) then
14949 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14953 if Ekind
(Def_Id
) = E_Function
14954 and then (Is_CPP_Class
(Etype
(Def_Id
))
14955 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14957 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14959 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14961 ("'C'P'P constructor must be defined in the scope of "
14962 & "its returned type", Arg1
);
14965 if Arg_Count
>= 2 then
14966 Set_Imported
(Def_Id
);
14967 Set_Is_Public
(Def_Id
);
14968 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14971 Set_Has_Completion
(Def_Id
);
14972 Set_Is_Constructor
(Def_Id
);
14973 Set_Convention
(Def_Id
, Convention_CPP
);
14975 -- Imported C++ constructors are not dispatching primitives
14976 -- because in C++ they don't have a dispatch table slot.
14977 -- However, in Ada the constructor has the profile of a
14978 -- function that returns a tagged type and therefore it has
14979 -- been treated as a primitive operation during semantic
14980 -- analysis. We now remove it from the list of primitive
14981 -- operations of the type.
14983 if Is_Tagged_Type
(Etype
(Def_Id
))
14984 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14985 and then Is_Dispatching_Operation
(Def_Id
)
14987 Tag_Typ
:= Etype
(Def_Id
);
14989 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14990 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
14994 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
14995 Set_Is_Dispatching_Operation
(Def_Id
, False);
14998 -- For backward compatibility, if the constructor returns a
14999 -- class wide type, and we internally change the return type to
15000 -- the corresponding root type.
15002 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
15003 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
15007 ("pragma% requires function returning a 'C'P'P_Class type",
15010 end CPP_Constructor
;
15016 when Pragma_CPP_Virtual
=>
15019 if Warn_On_Obsolescent_Feature
then
15021 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
15029 when Pragma_CPP_Vtable
=>
15032 if Warn_On_Obsolescent_Feature
then
15034 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
15042 -- pragma CPU (EXPRESSION);
15044 when Pragma_CPU
=> CPU
: declare
15045 P
: constant Node_Id
:= Parent
(N
);
15051 Check_No_Identifiers
;
15052 Check_Arg_Count
(1);
15056 if Nkind
(P
) = N_Subprogram_Body
then
15057 Check_In_Main_Program
;
15059 Arg
:= Get_Pragma_Arg
(Arg1
);
15060 Analyze_And_Resolve
(Arg
, Any_Integer
);
15062 Ent
:= Defining_Unit_Name
(Specification
(P
));
15064 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
15065 Ent
:= Defining_Identifier
(Ent
);
15070 if not Is_OK_Static_Expression
(Arg
) then
15071 Flag_Non_Static_Expr
15072 ("main subprogram affinity is not static!", Arg
);
15075 -- If constraint error, then we already signalled an error
15077 elsif Raises_Constraint_Error
(Arg
) then
15080 -- Otherwise check in range
15084 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
15085 -- This is the entity System.Multiprocessors.CPU_Range;
15087 Val
: constant Uint
:= Expr_Value
(Arg
);
15090 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
15092 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
15095 ("main subprogram CPU is out of range", Arg1
);
15101 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
15105 elsif Nkind
(P
) = N_Task_Definition
then
15106 Arg
:= Get_Pragma_Arg
(Arg1
);
15107 Ent
:= Defining_Identifier
(Parent
(P
));
15109 -- The expression must be analyzed in the special manner
15110 -- described in "Handling of Default and Per-Object
15111 -- Expressions" in sem.ads.
15113 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
15115 -- Anything else is incorrect
15121 -- Check duplicate pragma before we chain the pragma in the Rep
15122 -- Item chain of Ent.
15124 Check_Duplicate_Pragma
(Ent
);
15125 Record_Rep_Item
(Ent
, N
);
15128 --------------------
15129 -- Deadline_Floor --
15130 --------------------
15132 -- pragma Deadline_Floor (time_span_EXPRESSION);
15134 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
15135 P
: constant Node_Id
:= Parent
(N
);
15141 Check_No_Identifiers
;
15142 Check_Arg_Count
(1);
15144 Arg
:= Get_Pragma_Arg
(Arg1
);
15146 -- The expression must be analyzed in the special manner described
15147 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
15149 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
15151 -- Only protected types allowed
15153 if Nkind
(P
) /= N_Protected_Definition
then
15157 Ent
:= Defining_Identifier
(Parent
(P
));
15159 -- Check duplicate pragma before we chain the pragma in the Rep
15160 -- Item chain of Ent.
15162 Check_Duplicate_Pragma
(Ent
);
15163 Record_Rep_Item
(Ent
, N
);
15165 end Deadline_Floor
;
15171 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
15173 when Pragma_Debug
=> Debug
: declare
15180 -- The condition for executing the call is that the expander
15181 -- is active and that we are not ignoring this debug pragma.
15186 (Expander_Active
and then not Is_Ignored
(N
)),
15189 if not Is_Ignored
(N
) then
15190 Set_SCO_Pragma_Enabled
(Loc
);
15193 if Arg_Count
= 2 then
15195 Make_And_Then
(Loc
,
15196 Left_Opnd
=> Relocate_Node
(Cond
),
15197 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
15198 Call
:= Get_Pragma_Arg
(Arg2
);
15200 Call
:= Get_Pragma_Arg
(Arg1
);
15203 if Nkind_In
(Call
, N_Expanded_Name
,
15206 N_Indexed_Component
,
15207 N_Selected_Component
)
15209 -- If this pragma Debug comes from source, its argument was
15210 -- parsed as a name form (which is syntactically identical).
15211 -- In a generic context a parameterless call will be left as
15212 -- an expanded name (if global) or selected_component if local.
15213 -- Change it to a procedure call statement now.
15215 Change_Name_To_Procedure_Call_Statement
(Call
);
15217 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
15219 -- Already in the form of a procedure call statement: nothing
15220 -- to do (could happen in case of an internally generated
15226 -- All other cases: diagnose error
15229 ("argument of pragma ""Debug"" is not procedure call",
15234 -- Rewrite into a conditional with an appropriate condition. We
15235 -- wrap the procedure call in a block so that overhead from e.g.
15236 -- use of the secondary stack does not generate execution overhead
15237 -- for suppressed conditions.
15239 -- Normally the analysis that follows will freeze the subprogram
15240 -- being called. However, if the call is to a null procedure,
15241 -- we want to freeze it before creating the block, because the
15242 -- analysis that follows may be done with expansion disabled, in
15243 -- which case the body will not be generated, leading to spurious
15246 if Nkind
(Call
) = N_Procedure_Call_Statement
15247 and then Is_Entity_Name
(Name
(Call
))
15249 Analyze
(Name
(Call
));
15250 Freeze_Before
(N
, Entity
(Name
(Call
)));
15254 Make_Implicit_If_Statement
(N
,
15256 Then_Statements
=> New_List
(
15257 Make_Block_Statement
(Loc
,
15258 Handled_Statement_Sequence
=>
15259 Make_Handled_Sequence_Of_Statements
(Loc
,
15260 Statements
=> New_List
(Relocate_Node
(Call
)))))));
15263 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
15264 -- after analysis of the normally rewritten node, to capture all
15265 -- references to entities, which avoids issuing wrong warnings
15266 -- about unused entities.
15268 if GNATprove_Mode
then
15269 Rewrite
(N
, Make_Null_Statement
(Loc
));
15277 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
15279 when Pragma_Debug_Policy
=>
15281 Check_Arg_Count
(1);
15282 Check_No_Identifiers
;
15283 Check_Arg_Is_Identifier
(Arg1
);
15285 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
15286 -- rewrite it that way, and let the rest of the checking come
15287 -- from analyzing the rewritten pragma.
15291 Chars
=> Name_Check_Policy
,
15292 Pragma_Argument_Associations
=> New_List
(
15293 Make_Pragma_Argument_Association
(Loc
,
15294 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
15296 Make_Pragma_Argument_Association
(Loc
,
15297 Expression
=> Get_Pragma_Arg
(Arg1
)))));
15300 -------------------------------
15301 -- Default_Initial_Condition --
15302 -------------------------------
15304 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
15306 when Pragma_Default_Initial_Condition
=> DIC
: declare
15313 Check_No_Identifiers
;
15314 Check_At_Most_N_Arguments
(1);
15318 while Present
(Stmt
) loop
15320 -- Skip prior pragmas, but check for duplicates
15322 if Nkind
(Stmt
) = N_Pragma
then
15323 if Pragma_Name
(Stmt
) = Pname
then
15330 -- Skip internally generated code. Note that derived type
15331 -- declarations of untagged types with discriminants are
15332 -- rewritten as private type declarations.
15334 elsif not Comes_From_Source
(Stmt
)
15335 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
15339 -- The associated private type [extension] has been found, stop
15342 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
15343 N_Private_Type_Declaration
)
15345 Typ
:= Defining_Entity
(Stmt
);
15348 -- The pragma does not apply to a legal construct, issue an
15349 -- error and stop the analysis.
15356 Stmt
:= Prev
(Stmt
);
15359 -- The pragma does not apply to a legal construct, issue an error
15360 -- and stop the analysis.
15367 -- A pragma that applies to a Ghost entity becomes Ghost for the
15368 -- purposes of legality checks and removal of ignored Ghost code.
15370 Mark_Ghost_Pragma
(N
, Typ
);
15372 -- The pragma signals that the type defines its own DIC assertion
15375 Set_Has_Own_DIC
(Typ
);
15377 -- Chain the pragma on the rep item chain for further processing
15379 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
15381 -- Create the declaration of the procedure which verifies the
15382 -- assertion expression of pragma DIC at runtime.
15384 Build_DIC_Procedure_Declaration
(Typ
);
15387 ----------------------------------
15388 -- Default_Scalar_Storage_Order --
15389 ----------------------------------
15391 -- pragma Default_Scalar_Storage_Order
15392 -- (High_Order_First | Low_Order_First);
15394 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
15395 Default
: Character;
15399 Check_Arg_Count
(1);
15401 -- Default_Scalar_Storage_Order can appear as a configuration
15402 -- pragma, or in a declarative part of a package spec.
15404 if not Is_Configuration_Pragma
then
15405 Check_Is_In_Decl_Part_Or_Package_Spec
;
15408 Check_No_Identifiers
;
15409 Check_Arg_Is_One_Of
15410 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
15411 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15412 Default
:= Fold_Upper
(Name_Buffer
(1));
15414 if not Support_Nondefault_SSO_On_Target
15415 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
15417 if Warn_On_Unrecognized_Pragma
then
15419 ("non-default Scalar_Storage_Order not supported "
15420 & "on target?g?", N
);
15422 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
15425 -- Here set the specified default
15428 Opt
.Default_SSO
:= Default
;
15432 --------------------------
15433 -- Default_Storage_Pool --
15434 --------------------------
15436 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
15438 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
15443 Check_Arg_Count
(1);
15445 -- Default_Storage_Pool can appear as a configuration pragma, or
15446 -- in a declarative part of a package spec.
15448 if not Is_Configuration_Pragma
then
15449 Check_Is_In_Decl_Part_Or_Package_Spec
;
15452 if From_Aspect_Specification
(N
) then
15454 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
15456 if not In_Open_Scopes
(E
) then
15458 ("aspect must apply to package or subprogram", N
);
15463 if Present
(Arg1
) then
15464 Pool
:= Get_Pragma_Arg
(Arg1
);
15466 -- Case of Default_Storage_Pool (null);
15468 if Nkind
(Pool
) = N_Null
then
15471 -- This is an odd case, this is not really an expression,
15472 -- so we don't have a type for it. So just set the type to
15475 Set_Etype
(Pool
, Empty
);
15477 -- Case of Default_Storage_Pool (storage_pool_NAME);
15480 -- If it's a configuration pragma, then the only allowed
15481 -- argument is "null".
15483 if Is_Configuration_Pragma
then
15484 Error_Pragma_Arg
("NULL expected", Arg1
);
15487 -- The expected type for a non-"null" argument is
15488 -- Root_Storage_Pool'Class, and the pool must be a variable.
15490 Analyze_And_Resolve
15491 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
15493 if Is_Variable
(Pool
) then
15495 -- A pragma that applies to a Ghost entity becomes Ghost
15496 -- for the purposes of legality checks and removal of
15497 -- ignored Ghost code.
15499 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
15503 ("default storage pool must be a variable", Arg1
);
15507 -- Record the pool name (or null). Freeze.Freeze_Entity for an
15508 -- access type will use this information to set the appropriate
15509 -- attributes of the access type. If the pragma appears in a
15510 -- generic unit it is ignored, given that it may refer to a
15513 if not Inside_A_Generic
then
15514 Default_Pool
:= Pool
;
15517 end Default_Storage_Pool
;
15523 -- pragma Depends (DEPENDENCY_RELATION);
15525 -- DEPENDENCY_RELATION ::=
15527 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
15529 -- DEPENDENCY_CLAUSE ::=
15530 -- OUTPUT_LIST =>[+] INPUT_LIST
15531 -- | NULL_DEPENDENCY_CLAUSE
15533 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
15535 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
15537 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
15539 -- OUTPUT ::= NAME | FUNCTION_RESULT
15542 -- where FUNCTION_RESULT is a function Result attribute_reference
15544 -- Characteristics:
15546 -- * Analysis - The annotation undergoes initial checks to verify
15547 -- the legal placement and context. Secondary checks fully analyze
15548 -- the dependency clauses in:
15550 -- Analyze_Depends_In_Decl_Part
15552 -- * Expansion - None.
15554 -- * Template - The annotation utilizes the generic template of the
15555 -- related subprogram [body] when it is:
15557 -- aspect on subprogram declaration
15558 -- aspect on stand-alone subprogram body
15559 -- pragma on stand-alone subprogram body
15561 -- The annotation must prepare its own template when it is:
15563 -- pragma on subprogram declaration
15565 -- * Globals - Capture of global references must occur after full
15568 -- * Instance - The annotation is instantiated automatically when
15569 -- the related generic subprogram [body] is instantiated except for
15570 -- the "pragma on subprogram declaration" case. In that scenario
15571 -- the annotation must instantiate itself.
15573 when Pragma_Depends
=> Depends
: declare
15575 Spec_Id
: Entity_Id
;
15576 Subp_Decl
: Node_Id
;
15579 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15583 -- Chain the pragma on the contract for further processing by
15584 -- Analyze_Depends_In_Decl_Part.
15586 Add_Contract_Item
(N
, Spec_Id
);
15588 -- Fully analyze the pragma when it appears inside an entry
15589 -- or subprogram body because it cannot benefit from forward
15592 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15594 N_Subprogram_Body_Stub
)
15596 -- The legality checks of pragmas Depends and Global are
15597 -- affected by the SPARK mode in effect and the volatility
15598 -- of the context. In addition these two pragmas are subject
15599 -- to an inherent order:
15604 -- Analyze all these pragmas in the order outlined above
15606 Analyze_If_Present
(Pragma_SPARK_Mode
);
15607 Analyze_If_Present
(Pragma_Volatile_Function
);
15608 Analyze_If_Present
(Pragma_Global
);
15609 Analyze_Depends_In_Decl_Part
(N
);
15614 ---------------------
15615 -- Detect_Blocking --
15616 ---------------------
15618 -- pragma Detect_Blocking;
15620 when Pragma_Detect_Blocking
=>
15622 Check_Arg_Count
(0);
15623 Check_Valid_Configuration_Pragma
;
15624 Detect_Blocking
:= True;
15626 ------------------------------------
15627 -- Disable_Atomic_Synchronization --
15628 ------------------------------------
15630 -- pragma Disable_Atomic_Synchronization [(Entity)];
15632 when Pragma_Disable_Atomic_Synchronization
=>
15634 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
15636 -------------------
15637 -- Discard_Names --
15638 -------------------
15640 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
15642 when Pragma_Discard_Names
=> Discard_Names
: declare
15647 Check_Ada_83_Warning
;
15649 -- Deal with configuration pragma case
15651 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
15652 Global_Discard_Names
:= True;
15655 -- Otherwise, check correct appropriate context
15658 Check_Is_In_Decl_Part_Or_Package_Spec
;
15660 if Arg_Count
= 0 then
15662 -- If there is no parameter, then from now on this pragma
15663 -- applies to any enumeration, exception or tagged type
15664 -- defined in the current declarative part, and recursively
15665 -- to any nested scope.
15667 Set_Discard_Names
(Current_Scope
);
15671 Check_Arg_Count
(1);
15672 Check_Optional_Identifier
(Arg1
, Name_On
);
15673 Check_Arg_Is_Local_Name
(Arg1
);
15675 E_Id
:= Get_Pragma_Arg
(Arg1
);
15677 if Etype
(E_Id
) = Any_Type
then
15681 E
:= Entity
(E_Id
);
15683 -- A pragma that applies to a Ghost entity becomes Ghost for
15684 -- the purposes of legality checks and removal of ignored
15687 Mark_Ghost_Pragma
(N
, E
);
15689 if (Is_First_Subtype
(E
)
15691 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
15692 or else Ekind
(E
) = E_Exception
15694 Set_Discard_Names
(E
);
15695 Record_Rep_Item
(E
, N
);
15699 ("inappropriate entity for pragma%", Arg1
);
15705 ------------------------
15706 -- Dispatching_Domain --
15707 ------------------------
15709 -- pragma Dispatching_Domain (EXPRESSION);
15711 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
15712 P
: constant Node_Id
:= Parent
(N
);
15718 Check_No_Identifiers
;
15719 Check_Arg_Count
(1);
15721 -- This pragma is born obsolete, but not the aspect
15723 if not From_Aspect_Specification
(N
) then
15725 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
15728 if Nkind
(P
) = N_Task_Definition
then
15729 Arg
:= Get_Pragma_Arg
(Arg1
);
15730 Ent
:= Defining_Identifier
(Parent
(P
));
15732 -- A pragma that applies to a Ghost entity becomes Ghost for
15733 -- the purposes of legality checks and removal of ignored Ghost
15736 Mark_Ghost_Pragma
(N
, Ent
);
15738 -- The expression must be analyzed in the special manner
15739 -- described in "Handling of Default and Per-Object
15740 -- Expressions" in sem.ads.
15742 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
15744 -- Check duplicate pragma before we chain the pragma in the Rep
15745 -- Item chain of Ent.
15747 Check_Duplicate_Pragma
(Ent
);
15748 Record_Rep_Item
(Ent
, N
);
15750 -- Anything else is incorrect
15755 end Dispatching_Domain
;
15761 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
15763 when Pragma_Elaborate
=> Elaborate
: declare
15768 -- Pragma must be in context items list of a compilation unit
15770 if not Is_In_Context_Clause
then
15774 -- Must be at least one argument
15776 if Arg_Count
= 0 then
15777 Error_Pragma
("pragma% requires at least one argument");
15780 -- In Ada 83 mode, there can be no items following it in the
15781 -- context list except other pragmas and implicit with clauses
15782 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
15783 -- placement rule does not apply.
15785 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
15787 while Present
(Citem
) loop
15788 if Nkind
(Citem
) = N_Pragma
15789 or else (Nkind
(Citem
) = N_With_Clause
15790 and then Implicit_With
(Citem
))
15795 ("(Ada 83) pragma% must be at end of context clause");
15802 -- Finally, the arguments must all be units mentioned in a with
15803 -- clause in the same context clause. Note we already checked (in
15804 -- Par.Prag) that the arguments are all identifiers or selected
15808 Outer
: while Present
(Arg
) loop
15809 Citem
:= First
(List_Containing
(N
));
15810 Inner
: while Citem
/= N
loop
15811 if Nkind
(Citem
) = N_With_Clause
15812 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15814 Set_Elaborate_Present
(Citem
, True);
15815 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15817 -- With the pragma present, elaboration calls on
15818 -- subprograms from the named unit need no further
15819 -- checks, as long as the pragma appears in the current
15820 -- compilation unit. If the pragma appears in some unit
15821 -- in the context, there might still be a need for an
15822 -- Elaborate_All_Desirable from the current compilation
15823 -- to the named unit, so we keep the check enabled. This
15824 -- does not apply in SPARK mode, where we allow pragma
15825 -- Elaborate, but we don't trust it to be right so we
15826 -- will still insist on the Elaborate_All.
15828 if Legacy_Elaboration_Checks
15829 and then In_Extended_Main_Source_Unit
(N
)
15830 and then SPARK_Mode
/= On
15832 Set_Suppress_Elaboration_Warnings
15833 (Entity
(Name
(Citem
)));
15844 ("argument of pragma% is not withed unit", Arg
);
15851 -------------------
15852 -- Elaborate_All --
15853 -------------------
15855 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15857 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15862 Check_Ada_83_Warning
;
15864 -- Pragma must be in context items list of a compilation unit
15866 if not Is_In_Context_Clause
then
15870 -- Must be at least one argument
15872 if Arg_Count
= 0 then
15873 Error_Pragma
("pragma% requires at least one argument");
15876 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15877 -- have to appear at the end of the context clause, but may
15878 -- appear mixed in with other items, even in Ada 83 mode.
15880 -- Final check: the arguments must all be units mentioned in
15881 -- a with clause in the same context clause. Note that we
15882 -- already checked (in Par.Prag) that all the arguments are
15883 -- either identifiers or selected components.
15886 Outr
: while Present
(Arg
) loop
15887 Citem
:= First
(List_Containing
(N
));
15888 Innr
: while Citem
/= N
loop
15889 if Nkind
(Citem
) = N_With_Clause
15890 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15892 Set_Elaborate_All_Present
(Citem
, True);
15893 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15895 -- Suppress warnings and elaboration checks on the named
15896 -- unit if the pragma is in the current compilation, as
15897 -- for pragma Elaborate.
15899 if Legacy_Elaboration_Checks
15900 and then In_Extended_Main_Source_Unit
(N
)
15902 Set_Suppress_Elaboration_Warnings
15903 (Entity
(Name
(Citem
)));
15913 Set_Error_Posted
(N
);
15915 ("argument of pragma% is not withed unit", Arg
);
15922 --------------------
15923 -- Elaborate_Body --
15924 --------------------
15926 -- pragma Elaborate_Body [( library_unit_NAME )];
15928 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15929 Cunit_Node
: Node_Id
;
15930 Cunit_Ent
: Entity_Id
;
15933 Check_Ada_83_Warning
;
15934 Check_Valid_Library_Unit_Pragma
;
15936 if Nkind
(N
) = N_Null_Statement
then
15940 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15941 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15943 -- A pragma that applies to a Ghost entity becomes Ghost for the
15944 -- purposes of legality checks and removal of ignored Ghost code.
15946 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15948 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15951 Error_Pragma
("pragma% must refer to a spec, not a body");
15953 Set_Body_Required
(Cunit_Node
);
15954 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15956 -- If we are in dynamic elaboration mode, then we suppress
15957 -- elaboration warnings for the unit, since it is definitely
15958 -- fine NOT to do dynamic checks at the first level (and such
15959 -- checks will be suppressed because no elaboration boolean
15960 -- is created for Elaborate_Body packages).
15962 -- But in the static model of elaboration, Elaborate_Body is
15963 -- definitely NOT good enough to ensure elaboration safety on
15964 -- its own, since the body may WITH other units that are not
15965 -- safe from an elaboration point of view, so a client must
15966 -- still do an Elaborate_All on such units.
15968 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15969 -- Elaborate_Body always suppressed elab warnings.
15971 if Legacy_Elaboration_Checks
15972 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
15974 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
15977 end Elaborate_Body
;
15979 ------------------------
15980 -- Elaboration_Checks --
15981 ------------------------
15983 -- pragma Elaboration_Checks (Static | Dynamic);
15985 when Pragma_Elaboration_Checks
=> Elaboration_Checks
: declare
15986 procedure Check_Duplicate_Elaboration_Checks_Pragma
;
15987 -- Emit an error if the current context list already contains
15988 -- a previous Elaboration_Checks pragma. This routine raises
15989 -- Pragma_Exit if a duplicate is found.
15991 procedure Ignore_Elaboration_Checks_Pragma
;
15992 -- Warn that the effects of the pragma are ignored. This routine
15993 -- raises Pragma_Exit.
15995 -----------------------------------------------
15996 -- Check_Duplicate_Elaboration_Checks_Pragma --
15997 -----------------------------------------------
15999 procedure Check_Duplicate_Elaboration_Checks_Pragma
is
16004 while Present
(Item
) loop
16005 if Nkind
(Item
) = N_Pragma
16006 and then Pragma_Name
(Item
) = Name_Elaboration_Checks
16016 end Check_Duplicate_Elaboration_Checks_Pragma
;
16018 --------------------------------------
16019 -- Ignore_Elaboration_Checks_Pragma --
16020 --------------------------------------
16022 procedure Ignore_Elaboration_Checks_Pragma
is
16024 Error_Msg_Name_1
:= Pname
;
16025 Error_Msg_N
("??effects of pragma % are ignored", N
);
16027 ("\place pragma on initial declaration of library unit", N
);
16030 end Ignore_Elaboration_Checks_Pragma
;
16034 Context
: constant Node_Id
:= Parent
(N
);
16037 -- Start of processing for Elaboration_Checks
16041 Check_Arg_Count
(1);
16042 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
16044 -- The pragma appears in a configuration file
16046 if No
(Context
) then
16047 Check_Valid_Configuration_Pragma
;
16048 Check_Duplicate_Elaboration_Checks_Pragma
;
16050 -- The pragma acts as a configuration pragma in a compilation unit
16052 -- pragma Elaboration_Checks (...);
16053 -- package Pack is ...;
16055 elsif Nkind
(Context
) = N_Compilation_Unit
16056 and then List_Containing
(N
) = Context_Items
(Context
)
16058 Check_Valid_Configuration_Pragma
;
16059 Check_Duplicate_Elaboration_Checks_Pragma
;
16061 Unt
:= Unit
(Context
);
16063 -- The pragma must appear on the initial declaration of a unit.
16064 -- If this is not the case, warn that the effects of the pragma
16067 if Nkind
(Unt
) = N_Package_Body
then
16068 Ignore_Elaboration_Checks_Pragma
;
16070 -- Check the Acts_As_Spec flag of the compilation units itself
16071 -- to determine whether the subprogram body completes since it
16072 -- has not been analyzed yet. This is safe because compilation
16073 -- units are not overloadable.
16075 elsif Nkind
(Unt
) = N_Subprogram_Body
16076 and then not Acts_As_Spec
(Context
)
16078 Ignore_Elaboration_Checks_Pragma
;
16080 elsif Nkind
(Unt
) = N_Subunit
then
16081 Ignore_Elaboration_Checks_Pragma
;
16084 -- Otherwise the pragma does not appear at the configuration level
16091 -- At this point the pragma is not a duplicate, and appears in the
16092 -- proper context. Set the elaboration model in effect.
16094 Dynamic_Elaboration_Checks
:=
16095 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
16096 end Elaboration_Checks
;
16102 -- pragma Eliminate (
16103 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
16104 -- [Entity =>] IDENTIFIER |
16105 -- SELECTED_COMPONENT |
16107 -- [, Source_Location => SOURCE_TRACE]);
16109 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
16110 -- SOURCE_TRACE ::= STRING_LITERAL
16112 when Pragma_Eliminate
=> Eliminate
: declare
16113 Args
: Args_List
(1 .. 5);
16114 Names
: constant Name_List
(1 .. 5) := (
16117 Name_Parameter_Types
,
16119 Name_Source_Location
);
16121 -- Note : Parameter_Types and Result_Type are leftovers from
16122 -- prior implementations of the pragma. They are not generated
16123 -- by the gnatelim tool, and play no role in selecting which
16124 -- of a set of overloaded names is chosen for elimination.
16126 Unit_Name
: Node_Id
renames Args
(1);
16127 Entity
: Node_Id
renames Args
(2);
16128 Parameter_Types
: Node_Id
renames Args
(3);
16129 Result_Type
: Node_Id
renames Args
(4);
16130 Source_Location
: Node_Id
renames Args
(5);
16134 Check_Valid_Configuration_Pragma
;
16135 Gather_Associations
(Names
, Args
);
16137 if No
(Unit_Name
) then
16138 Error_Pragma
("missing Unit_Name argument for pragma%");
16142 and then (Present
(Parameter_Types
)
16144 Present
(Result_Type
)
16146 Present
(Source_Location
))
16148 Error_Pragma
("missing Entity argument for pragma%");
16151 if (Present
(Parameter_Types
)
16153 Present
(Result_Type
))
16155 Present
(Source_Location
)
16158 ("parameter profile and source location cannot be used "
16159 & "together in pragma%");
16162 Process_Eliminate_Pragma
16171 -----------------------------------
16172 -- Enable_Atomic_Synchronization --
16173 -----------------------------------
16175 -- pragma Enable_Atomic_Synchronization [(Entity)];
16177 when Pragma_Enable_Atomic_Synchronization
=>
16179 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
16186 -- [ Convention =>] convention_IDENTIFIER,
16187 -- [ Entity =>] LOCAL_NAME
16188 -- [, [External_Name =>] static_string_EXPRESSION ]
16189 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16191 when Pragma_Export
=> Export
: declare
16193 Def_Id
: Entity_Id
;
16195 pragma Warnings
(Off
, C
);
16198 Check_Ada_83_Warning
;
16202 Name_External_Name
,
16205 Check_At_Least_N_Arguments
(2);
16206 Check_At_Most_N_Arguments
(4);
16208 -- In Relaxed_RM_Semantics, support old Ada 83 style:
16209 -- pragma Export (Entity, "external name");
16211 if Relaxed_RM_Semantics
16212 and then Arg_Count
= 2
16213 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
16216 Def_Id
:= Get_Pragma_Arg
(Arg1
);
16219 if not Is_Entity_Name
(Def_Id
) then
16220 Error_Pragma_Arg
("entity name required", Arg1
);
16223 Def_Id
:= Entity
(Def_Id
);
16224 Set_Exported
(Def_Id
, Arg1
);
16227 Process_Convention
(C
, Def_Id
);
16229 -- A pragma that applies to a Ghost entity becomes Ghost for
16230 -- the purposes of legality checks and removal of ignored Ghost
16233 Mark_Ghost_Pragma
(N
, Def_Id
);
16235 if Ekind
(Def_Id
) /= E_Constant
then
16236 Note_Possible_Modification
16237 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16240 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
16241 Set_Exported
(Def_Id
, Arg2
);
16244 -- If the entity is a deferred constant, propagate the information
16245 -- to the full view, because gigi elaborates the full view only.
16247 if Ekind
(Def_Id
) = E_Constant
16248 and then Present
(Full_View
(Def_Id
))
16251 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
16253 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
16254 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
16255 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
16260 ---------------------
16261 -- Export_Function --
16262 ---------------------
16264 -- pragma Export_Function (
16265 -- [Internal =>] LOCAL_NAME
16266 -- [, [External =>] EXTERNAL_SYMBOL]
16267 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16268 -- [, [Result_Type =>] TYPE_DESIGNATOR]
16269 -- [, [Mechanism =>] MECHANISM]
16270 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16272 -- EXTERNAL_SYMBOL ::=
16274 -- | static_string_EXPRESSION
16276 -- PARAMETER_TYPES ::=
16278 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16280 -- TYPE_DESIGNATOR ::=
16282 -- | subtype_Name ' Access
16286 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16288 -- MECHANISM_ASSOCIATION ::=
16289 -- [formal_parameter_NAME =>] MECHANISM_NAME
16291 -- MECHANISM_NAME ::=
16295 when Pragma_Export_Function
=> Export_Function
: declare
16296 Args
: Args_List
(1 .. 6);
16297 Names
: constant Name_List
(1 .. 6) := (
16300 Name_Parameter_Types
,
16303 Name_Result_Mechanism
);
16305 Internal
: Node_Id
renames Args
(1);
16306 External
: Node_Id
renames Args
(2);
16307 Parameter_Types
: Node_Id
renames Args
(3);
16308 Result_Type
: Node_Id
renames Args
(4);
16309 Mechanism
: Node_Id
renames Args
(5);
16310 Result_Mechanism
: Node_Id
renames Args
(6);
16314 Gather_Associations
(Names
, Args
);
16315 Process_Extended_Import_Export_Subprogram_Pragma
(
16316 Arg_Internal
=> Internal
,
16317 Arg_External
=> External
,
16318 Arg_Parameter_Types
=> Parameter_Types
,
16319 Arg_Result_Type
=> Result_Type
,
16320 Arg_Mechanism
=> Mechanism
,
16321 Arg_Result_Mechanism
=> Result_Mechanism
);
16322 end Export_Function
;
16324 -------------------
16325 -- Export_Object --
16326 -------------------
16328 -- pragma Export_Object (
16329 -- [Internal =>] LOCAL_NAME
16330 -- [, [External =>] EXTERNAL_SYMBOL]
16331 -- [, [Size =>] EXTERNAL_SYMBOL]);
16333 -- EXTERNAL_SYMBOL ::=
16335 -- | static_string_EXPRESSION
16337 -- PARAMETER_TYPES ::=
16339 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16341 -- TYPE_DESIGNATOR ::=
16343 -- | subtype_Name ' Access
16347 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16349 -- MECHANISM_ASSOCIATION ::=
16350 -- [formal_parameter_NAME =>] MECHANISM_NAME
16352 -- MECHANISM_NAME ::=
16356 when Pragma_Export_Object
=> Export_Object
: declare
16357 Args
: Args_List
(1 .. 3);
16358 Names
: constant Name_List
(1 .. 3) := (
16363 Internal
: Node_Id
renames Args
(1);
16364 External
: Node_Id
renames Args
(2);
16365 Size
: Node_Id
renames Args
(3);
16369 Gather_Associations
(Names
, Args
);
16370 Process_Extended_Import_Export_Object_Pragma
(
16371 Arg_Internal
=> Internal
,
16372 Arg_External
=> External
,
16376 ----------------------
16377 -- Export_Procedure --
16378 ----------------------
16380 -- pragma Export_Procedure (
16381 -- [Internal =>] LOCAL_NAME
16382 -- [, [External =>] EXTERNAL_SYMBOL]
16383 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16384 -- [, [Mechanism =>] MECHANISM]);
16386 -- EXTERNAL_SYMBOL ::=
16388 -- | static_string_EXPRESSION
16390 -- PARAMETER_TYPES ::=
16392 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16394 -- TYPE_DESIGNATOR ::=
16396 -- | subtype_Name ' Access
16400 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16402 -- MECHANISM_ASSOCIATION ::=
16403 -- [formal_parameter_NAME =>] MECHANISM_NAME
16405 -- MECHANISM_NAME ::=
16409 when Pragma_Export_Procedure
=> Export_Procedure
: declare
16410 Args
: Args_List
(1 .. 4);
16411 Names
: constant Name_List
(1 .. 4) := (
16414 Name_Parameter_Types
,
16417 Internal
: Node_Id
renames Args
(1);
16418 External
: Node_Id
renames Args
(2);
16419 Parameter_Types
: Node_Id
renames Args
(3);
16420 Mechanism
: Node_Id
renames Args
(4);
16424 Gather_Associations
(Names
, Args
);
16425 Process_Extended_Import_Export_Subprogram_Pragma
(
16426 Arg_Internal
=> Internal
,
16427 Arg_External
=> External
,
16428 Arg_Parameter_Types
=> Parameter_Types
,
16429 Arg_Mechanism
=> Mechanism
);
16430 end Export_Procedure
;
16436 -- pragma Export_Value (
16437 -- [Value =>] static_integer_EXPRESSION,
16438 -- [Link_Name =>] static_string_EXPRESSION);
16440 when Pragma_Export_Value
=>
16442 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
16443 Check_Arg_Count
(2);
16445 Check_Optional_Identifier
(Arg1
, Name_Value
);
16446 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16448 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
16449 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16451 -----------------------------
16452 -- Export_Valued_Procedure --
16453 -----------------------------
16455 -- pragma Export_Valued_Procedure (
16456 -- [Internal =>] LOCAL_NAME
16457 -- [, [External =>] EXTERNAL_SYMBOL,]
16458 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16459 -- [, [Mechanism =>] MECHANISM]);
16461 -- EXTERNAL_SYMBOL ::=
16463 -- | static_string_EXPRESSION
16465 -- PARAMETER_TYPES ::=
16467 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16469 -- TYPE_DESIGNATOR ::=
16471 -- | subtype_Name ' Access
16475 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16477 -- MECHANISM_ASSOCIATION ::=
16478 -- [formal_parameter_NAME =>] MECHANISM_NAME
16480 -- MECHANISM_NAME ::=
16484 when Pragma_Export_Valued_Procedure
=>
16485 Export_Valued_Procedure
: declare
16486 Args
: Args_List
(1 .. 4);
16487 Names
: constant Name_List
(1 .. 4) := (
16490 Name_Parameter_Types
,
16493 Internal
: Node_Id
renames Args
(1);
16494 External
: Node_Id
renames Args
(2);
16495 Parameter_Types
: Node_Id
renames Args
(3);
16496 Mechanism
: Node_Id
renames Args
(4);
16500 Gather_Associations
(Names
, Args
);
16501 Process_Extended_Import_Export_Subprogram_Pragma
(
16502 Arg_Internal
=> Internal
,
16503 Arg_External
=> External
,
16504 Arg_Parameter_Types
=> Parameter_Types
,
16505 Arg_Mechanism
=> Mechanism
);
16506 end Export_Valued_Procedure
;
16508 -------------------
16509 -- Extend_System --
16510 -------------------
16512 -- pragma Extend_System ([Name =>] Identifier);
16514 when Pragma_Extend_System
=>
16516 Check_Valid_Configuration_Pragma
;
16517 Check_Arg_Count
(1);
16518 Check_Optional_Identifier
(Arg1
, Name_Name
);
16519 Check_Arg_Is_Identifier
(Arg1
);
16521 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
16524 and then Name_Buffer
(1 .. 4) = "aux_"
16526 if Present
(System_Extend_Pragma_Arg
) then
16527 if Chars
(Get_Pragma_Arg
(Arg1
)) =
16528 Chars
(Expression
(System_Extend_Pragma_Arg
))
16532 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
16533 Error_Pragma
("pragma% conflicts with that #");
16537 System_Extend_Pragma_Arg
:= Arg1
;
16539 if not GNAT_Mode
then
16540 System_Extend_Unit
:= Arg1
;
16544 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
16547 ------------------------
16548 -- Extensions_Allowed --
16549 ------------------------
16551 -- pragma Extensions_Allowed (ON | OFF);
16553 when Pragma_Extensions_Allowed
=>
16555 Check_Arg_Count
(1);
16556 Check_No_Identifiers
;
16557 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
16559 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
16560 Extensions_Allowed
:= True;
16561 Ada_Version
:= Ada_Version_Type
'Last;
16564 Extensions_Allowed
:= False;
16565 Ada_Version
:= Ada_Version_Explicit
;
16566 Ada_Version_Pragma
:= Empty
;
16569 ------------------------
16570 -- Extensions_Visible --
16571 ------------------------
16573 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
16575 -- Characteristics:
16577 -- * Analysis - The annotation is fully analyzed immediately upon
16578 -- elaboration as its expression must be static.
16580 -- * Expansion - None.
16582 -- * Template - The annotation utilizes the generic template of the
16583 -- related subprogram [body] when it is:
16585 -- aspect on subprogram declaration
16586 -- aspect on stand-alone subprogram body
16587 -- pragma on stand-alone subprogram body
16589 -- The annotation must prepare its own template when it is:
16591 -- pragma on subprogram declaration
16593 -- * Globals - Capture of global references must occur after full
16596 -- * Instance - The annotation is instantiated automatically when
16597 -- the related generic subprogram [body] is instantiated except for
16598 -- the "pragma on subprogram declaration" case. In that scenario
16599 -- the annotation must instantiate itself.
16601 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
16602 Formal
: Entity_Id
;
16603 Has_OK_Formal
: Boolean := False;
16604 Spec_Id
: Entity_Id
;
16605 Subp_Decl
: Node_Id
;
16609 Check_No_Identifiers
;
16610 Check_At_Most_N_Arguments
(1);
16613 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
16615 -- Abstract subprogram declaration
16617 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
16620 -- Generic subprogram declaration
16622 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
16625 -- Body acts as spec
16627 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
16628 and then No
(Corresponding_Spec
(Subp_Decl
))
16632 -- Body stub acts as spec
16634 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
16635 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
16639 -- Subprogram declaration
16641 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
16644 -- Otherwise the pragma is associated with an illegal construct
16647 Error_Pragma
("pragma % must apply to a subprogram");
16651 -- Mark the pragma as Ghost if the related subprogram is also
16652 -- Ghost. This also ensures that any expansion performed further
16653 -- below will produce Ghost nodes.
16655 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
16656 Mark_Ghost_Pragma
(N
, Spec_Id
);
16658 -- Chain the pragma on the contract for completeness
16660 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
16662 -- The legality checks of pragma Extension_Visible are affected
16663 -- by the SPARK mode in effect. Analyze all pragmas in specific
16666 Analyze_If_Present
(Pragma_SPARK_Mode
);
16668 -- Examine the formals of the related subprogram
16670 Formal
:= First_Formal
(Spec_Id
);
16671 while Present
(Formal
) loop
16673 -- At least one of the formals is of a specific tagged type,
16674 -- the pragma is legal.
16676 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
16677 Has_OK_Formal
:= True;
16680 -- A generic subprogram with at least one formal of a private
16681 -- type ensures the legality of the pragma because the actual
16682 -- may be specifically tagged. Note that this is verified by
16683 -- the check above at instantiation time.
16685 elsif Is_Private_Type
(Etype
(Formal
))
16686 and then Is_Generic_Type
(Etype
(Formal
))
16688 Has_OK_Formal
:= True;
16692 Next_Formal
(Formal
);
16695 if not Has_OK_Formal
then
16696 Error_Msg_Name_1
:= Pname
;
16697 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
16699 ("\subprogram & lacks parameter of specific tagged or "
16700 & "generic private type", N
, Spec_Id
);
16705 -- Analyze the Boolean expression (if any)
16707 if Present
(Arg1
) then
16708 Check_Static_Boolean_Expression
16709 (Expression
(Get_Argument
(N
, Spec_Id
)));
16711 end Extensions_Visible
;
16717 -- pragma External (
16718 -- [ Convention =>] convention_IDENTIFIER,
16719 -- [ Entity =>] LOCAL_NAME
16720 -- [, [External_Name =>] static_string_EXPRESSION ]
16721 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16723 when Pragma_External
=> External
: declare
16726 pragma Warnings
(Off
, C
);
16733 Name_External_Name
,
16735 Check_At_Least_N_Arguments
(2);
16736 Check_At_Most_N_Arguments
(4);
16737 Process_Convention
(C
, E
);
16739 -- A pragma that applies to a Ghost entity becomes Ghost for the
16740 -- purposes of legality checks and removal of ignored Ghost code.
16742 Mark_Ghost_Pragma
(N
, E
);
16744 Note_Possible_Modification
16745 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
16746 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
16747 Set_Exported
(E
, Arg2
);
16750 --------------------------
16751 -- External_Name_Casing --
16752 --------------------------
16754 -- pragma External_Name_Casing (
16755 -- UPPERCASE | LOWERCASE
16756 -- [, AS_IS | UPPERCASE | LOWERCASE]);
16758 when Pragma_External_Name_Casing
=>
16760 Check_No_Identifiers
;
16762 if Arg_Count
= 2 then
16763 Check_Arg_Is_One_Of
16764 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
16766 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16768 Opt
.External_Name_Exp_Casing
:= As_Is
;
16770 when Name_Uppercase
=>
16771 Opt
.External_Name_Exp_Casing
:= Uppercase
;
16773 when Name_Lowercase
=>
16774 Opt
.External_Name_Exp_Casing
:= Lowercase
;
16781 Check_Arg_Count
(1);
16784 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
16786 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16787 when Name_Uppercase
=>
16788 Opt
.External_Name_Imp_Casing
:= Uppercase
;
16790 when Name_Lowercase
=>
16791 Opt
.External_Name_Imp_Casing
:= Lowercase
;
16801 -- pragma Fast_Math;
16803 when Pragma_Fast_Math
=>
16805 Check_No_Identifiers
;
16806 Check_Valid_Configuration_Pragma
;
16809 --------------------------
16810 -- Favor_Top_Level --
16811 --------------------------
16813 -- pragma Favor_Top_Level (type_NAME);
16815 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
16820 Check_No_Identifiers
;
16821 Check_Arg_Count
(1);
16822 Check_Arg_Is_Local_Name
(Arg1
);
16823 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
16825 -- A pragma that applies to a Ghost entity becomes Ghost for the
16826 -- purposes of legality checks and removal of ignored Ghost code.
16828 Mark_Ghost_Pragma
(N
, Typ
);
16830 -- If it's an access-to-subprogram type (in particular, not a
16831 -- subtype), set the flag on that type.
16833 if Is_Access_Subprogram_Type
(Typ
) then
16834 Set_Can_Use_Internal_Rep
(Typ
, False);
16836 -- Otherwise it's an error (name denotes the wrong sort of entity)
16840 ("access-to-subprogram type expected",
16841 Get_Pragma_Arg
(Arg1
));
16843 end Favor_Top_Level
;
16845 ---------------------------
16846 -- Finalize_Storage_Only --
16847 ---------------------------
16849 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
16851 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
16852 Assoc
: constant Node_Id
:= Arg1
;
16853 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
16858 Check_No_Identifiers
;
16859 Check_Arg_Count
(1);
16860 Check_Arg_Is_Local_Name
(Arg1
);
16862 Find_Type
(Type_Id
);
16863 Typ
:= Entity
(Type_Id
);
16866 or else Rep_Item_Too_Early
(Typ
, N
)
16870 Typ
:= Underlying_Type
(Typ
);
16873 if not Is_Controlled
(Typ
) then
16874 Error_Pragma
("pragma% must specify controlled type");
16877 Check_First_Subtype
(Arg1
);
16879 if Finalize_Storage_Only
(Typ
) then
16880 Error_Pragma
("duplicate pragma%, only one allowed");
16882 elsif not Rep_Item_Too_Late
(Typ
, N
) then
16883 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
16885 end Finalize_Storage
;
16891 -- pragma Ghost [ (boolean_EXPRESSION) ];
16893 when Pragma_Ghost
=> Ghost
: declare
16897 Orig_Stmt
: Node_Id
;
16898 Prev_Id
: Entity_Id
;
16903 Check_No_Identifiers
;
16904 Check_At_Most_N_Arguments
(1);
16908 while Present
(Stmt
) loop
16910 -- Skip prior pragmas, but check for duplicates
16912 if Nkind
(Stmt
) = N_Pragma
then
16913 if Pragma_Name
(Stmt
) = Pname
then
16920 -- Task unit declared without a definition cannot be subject to
16921 -- pragma Ghost (SPARK RM 6.9(19)).
16923 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
16924 N_Task_Type_Declaration
)
16926 Error_Pragma
("pragma % cannot apply to a task type");
16929 -- Skip internally generated code
16931 elsif not Comes_From_Source
(Stmt
) then
16932 Orig_Stmt
:= Original_Node
(Stmt
);
16934 -- When pragma Ghost applies to an untagged derivation, the
16935 -- derivation is transformed into a [sub]type declaration.
16937 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
16938 N_Subtype_Declaration
)
16939 and then Comes_From_Source
(Orig_Stmt
)
16940 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
16941 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
16942 N_Derived_Type_Definition
16944 Id
:= Defining_Entity
(Stmt
);
16947 -- When pragma Ghost applies to an object declaration which
16948 -- is initialized by means of a function call that returns
16949 -- on the secondary stack, the object declaration becomes a
16952 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16953 and then Comes_From_Source
(Orig_Stmt
)
16954 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16956 Id
:= Defining_Entity
(Stmt
);
16959 -- When pragma Ghost applies to an expression function, the
16960 -- expression function is transformed into a subprogram.
16962 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16963 and then Comes_From_Source
(Orig_Stmt
)
16964 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16966 Id
:= Defining_Entity
(Stmt
);
16970 -- The pragma applies to a legal construct, stop the traversal
16972 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16973 N_Full_Type_Declaration
,
16974 N_Generic_Subprogram_Declaration
,
16975 N_Object_Declaration
,
16976 N_Private_Extension_Declaration
,
16977 N_Private_Type_Declaration
,
16978 N_Subprogram_Declaration
,
16979 N_Subtype_Declaration
)
16981 Id
:= Defining_Entity
(Stmt
);
16984 -- The pragma does not apply to a legal construct, issue an
16985 -- error and stop the analysis.
16989 ("pragma % must apply to an object, package, subprogram "
16994 Stmt
:= Prev
(Stmt
);
16997 Context
:= Parent
(N
);
16999 -- Handle compilation units
17001 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
17002 Context
:= Unit
(Parent
(Context
));
17005 -- Protected and task types cannot be subject to pragma Ghost
17006 -- (SPARK RM 6.9(19)).
17008 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
17010 Error_Pragma
("pragma % cannot apply to a protected type");
17013 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
17014 Error_Pragma
("pragma % cannot apply to a task type");
17020 -- When pragma Ghost is associated with a [generic] package, it
17021 -- appears in the visible declarations.
17023 if Nkind
(Context
) = N_Package_Specification
17024 and then Present
(Visible_Declarations
(Context
))
17025 and then List_Containing
(N
) = Visible_Declarations
(Context
)
17027 Id
:= Defining_Entity
(Context
);
17029 -- Pragma Ghost applies to a stand-alone subprogram body
17031 elsif Nkind
(Context
) = N_Subprogram_Body
17032 and then No
(Corresponding_Spec
(Context
))
17034 Id
:= Defining_Entity
(Context
);
17036 -- Pragma Ghost applies to a subprogram declaration that acts
17037 -- as a compilation unit.
17039 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
17040 Id
:= Defining_Entity
(Context
);
17042 -- Pragma Ghost applies to a generic subprogram
17044 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
17045 Id
:= Defining_Entity
(Specification
(Context
));
17051 ("pragma % must apply to an object, package, subprogram or "
17056 -- Handle completions of types and constants that are subject to
17059 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
17060 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
17062 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
17063 Error_Msg_Name_1
:= Pname
;
17065 -- The full declaration of a deferred constant cannot be
17066 -- subject to pragma Ghost unless the deferred declaration
17067 -- is also Ghost (SPARK RM 6.9(9)).
17069 if Ekind
(Prev_Id
) = E_Constant
then
17070 Error_Msg_Name_1
:= Pname
;
17071 Error_Msg_NE
(Fix_Error
17072 ("pragma % must apply to declaration of deferred "
17073 & "constant &"), N
, Id
);
17076 -- Pragma Ghost may appear on the full view of an incomplete
17077 -- type because the incomplete declaration lacks aspects and
17078 -- cannot be subject to pragma Ghost.
17080 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
17083 -- The full declaration of a type cannot be subject to
17084 -- pragma Ghost unless the partial view is also Ghost
17085 -- (SPARK RM 6.9(9)).
17088 Error_Msg_NE
(Fix_Error
17089 ("pragma % must apply to partial view of type &"),
17095 -- A synchronized object cannot be subject to pragma Ghost
17096 -- (SPARK RM 6.9(19)).
17098 elsif Ekind
(Id
) = E_Variable
then
17099 if Is_Protected_Type
(Etype
(Id
)) then
17100 Error_Pragma
("pragma % cannot apply to a protected object");
17103 elsif Is_Task_Type
(Etype
(Id
)) then
17104 Error_Pragma
("pragma % cannot apply to a task object");
17109 -- Analyze the Boolean expression (if any)
17111 if Present
(Arg1
) then
17112 Expr
:= Get_Pragma_Arg
(Arg1
);
17114 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
17116 if Is_OK_Static_Expression
(Expr
) then
17118 -- "Ghostness" cannot be turned off once enabled within a
17119 -- region (SPARK RM 6.9(6)).
17121 if Is_False
(Expr_Value
(Expr
))
17122 and then Ghost_Mode
> None
17125 ("pragma % with value False cannot appear in enabled "
17130 -- Otherwie the expression is not static
17134 ("expression of pragma % must be static", Expr
);
17139 Set_Is_Ghost_Entity
(Id
);
17146 -- pragma Global (GLOBAL_SPECIFICATION);
17148 -- GLOBAL_SPECIFICATION ::=
17151 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
17153 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
17155 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
17156 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
17157 -- GLOBAL_ITEM ::= NAME
17159 -- Characteristics:
17161 -- * Analysis - The annotation undergoes initial checks to verify
17162 -- the legal placement and context. Secondary checks fully analyze
17163 -- the dependency clauses in:
17165 -- Analyze_Global_In_Decl_Part
17167 -- * Expansion - None.
17169 -- * Template - The annotation utilizes the generic template of the
17170 -- related subprogram [body] when it is:
17172 -- aspect on subprogram declaration
17173 -- aspect on stand-alone subprogram body
17174 -- pragma on stand-alone subprogram body
17176 -- The annotation must prepare its own template when it is:
17178 -- pragma on subprogram declaration
17180 -- * Globals - Capture of global references must occur after full
17183 -- * Instance - The annotation is instantiated automatically when
17184 -- the related generic subprogram [body] is instantiated except for
17185 -- the "pragma on subprogram declaration" case. In that scenario
17186 -- the annotation must instantiate itself.
17188 when Pragma_Global
=> Global
: declare
17190 Spec_Id
: Entity_Id
;
17191 Subp_Decl
: Node_Id
;
17194 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
17198 -- Chain the pragma on the contract for further processing by
17199 -- Analyze_Global_In_Decl_Part.
17201 Add_Contract_Item
(N
, Spec_Id
);
17203 -- Fully analyze the pragma when it appears inside an entry
17204 -- or subprogram body because it cannot benefit from forward
17207 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
17209 N_Subprogram_Body_Stub
)
17211 -- The legality checks of pragmas Depends and Global are
17212 -- affected by the SPARK mode in effect and the volatility
17213 -- of the context. In addition these two pragmas are subject
17214 -- to an inherent order:
17219 -- Analyze all these pragmas in the order outlined above
17221 Analyze_If_Present
(Pragma_SPARK_Mode
);
17222 Analyze_If_Present
(Pragma_Volatile_Function
);
17223 Analyze_Global_In_Decl_Part
(N
);
17224 Analyze_If_Present
(Pragma_Depends
);
17233 -- pragma Ident (static_string_EXPRESSION)
17235 -- Note: pragma Comment shares this processing. Pragma Ident is
17236 -- identical in effect to pragma Commment.
17238 when Pragma_Comment
17246 Check_Arg_Count
(1);
17247 Check_No_Identifiers
;
17248 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17251 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
17258 GP
:= Parent
(Parent
(N
));
17260 if Nkind_In
(GP
, N_Package_Declaration
,
17261 N_Generic_Package_Declaration
)
17266 -- If we have a compilation unit, then record the ident value,
17267 -- checking for improper duplication.
17269 if Nkind
(GP
) = N_Compilation_Unit
then
17270 CS
:= Ident_String
(Current_Sem_Unit
);
17272 if Present
(CS
) then
17274 -- If we have multiple instances, concatenate them, but
17275 -- not in ASIS, where we want the original tree.
17277 if not ASIS_Mode
then
17278 Start_String
(Strval
(CS
));
17279 Store_String_Char
(' ');
17280 Store_String_Chars
(Strval
(Str
));
17281 Set_Strval
(CS
, End_String
);
17285 Set_Ident_String
(Current_Sem_Unit
, Str
);
17288 -- For subunits, we just ignore the Ident, since in GNAT these
17289 -- are not separate object files, and hence not separate units
17290 -- in the unit table.
17292 elsif Nkind
(GP
) = N_Subunit
then
17298 -------------------
17299 -- Ignore_Pragma --
17300 -------------------
17302 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
17304 -- Entirely handled in the parser, nothing to do here
17306 when Pragma_Ignore_Pragma
=>
17309 ----------------------------
17310 -- Implementation_Defined --
17311 ----------------------------
17313 -- pragma Implementation_Defined (LOCAL_NAME);
17315 -- Marks previously declared entity as implementation defined. For
17316 -- an overloaded entity, applies to the most recent homonym.
17318 -- pragma Implementation_Defined;
17320 -- The form with no arguments appears anywhere within a scope, most
17321 -- typically a package spec, and indicates that all entities that are
17322 -- defined within the package spec are Implementation_Defined.
17324 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
17329 Check_No_Identifiers
;
17331 -- Form with no arguments
17333 if Arg_Count
= 0 then
17334 Set_Is_Implementation_Defined
(Current_Scope
);
17336 -- Form with one argument
17339 Check_Arg_Count
(1);
17340 Check_Arg_Is_Local_Name
(Arg1
);
17341 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
17342 Set_Is_Implementation_Defined
(Ent
);
17344 end Implementation_Defined
;
17350 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
17352 -- IMPLEMENTATION_KIND ::=
17353 -- By_Entry | By_Protected_Procedure | By_Any | Optional
17355 -- "By_Any" and "Optional" are treated as synonyms in order to
17356 -- support Ada 2012 aspect Synchronization.
17358 when Pragma_Implemented
=> Implemented
: declare
17359 Proc_Id
: Entity_Id
;
17364 Check_Arg_Count
(2);
17365 Check_No_Identifiers
;
17366 Check_Arg_Is_Identifier
(Arg1
);
17367 Check_Arg_Is_Local_Name
(Arg1
);
17368 Check_Arg_Is_One_Of
(Arg2
,
17371 Name_By_Protected_Procedure
,
17374 -- Extract the name of the local procedure
17376 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17378 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
17379 -- primitive procedure of a synchronized tagged type.
17381 if Ekind
(Proc_Id
) = E_Procedure
17382 and then Is_Primitive
(Proc_Id
)
17383 and then Present
(First_Formal
(Proc_Id
))
17385 Typ
:= Etype
(First_Formal
(Proc_Id
));
17387 if Is_Tagged_Type
(Typ
)
17390 -- Check for a protected, a synchronized or a task interface
17392 ((Is_Interface
(Typ
)
17393 and then Is_Synchronized_Interface
(Typ
))
17395 -- Check for a protected type or a task type that implements
17399 (Is_Concurrent_Record_Type
(Typ
)
17400 and then Present
(Interfaces
(Typ
)))
17402 -- In analysis-only mode, examine original protected type
17405 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
17406 and then Present
(Interface_List
(Parent
(Typ
))))
17408 -- Check for a private record extension with keyword
17412 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
17413 E_Record_Subtype_With_Private
)
17414 and then Synchronized_Present
(Parent
(Typ
))))
17419 ("controlling formal must be of synchronized tagged type",
17424 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
17425 -- By_Protected_Procedure to the primitive procedure of a task
17428 if Chars
(Arg2
) = Name_By_Protected_Procedure
17429 and then Is_Interface
(Typ
)
17430 and then Is_Task_Interface
(Typ
)
17433 ("implementation kind By_Protected_Procedure cannot be "
17434 & "applied to a task interface primitive", Arg2
);
17438 -- Procedures declared inside a protected type must be accepted
17440 elsif Ekind
(Proc_Id
) = E_Procedure
17441 and then Is_Protected_Type
(Scope
(Proc_Id
))
17445 -- The first argument is not a primitive procedure
17449 ("pragma % must be applied to a primitive procedure", Arg1
);
17453 Record_Rep_Item
(Proc_Id
, N
);
17456 ----------------------
17457 -- Implicit_Packing --
17458 ----------------------
17460 -- pragma Implicit_Packing;
17462 when Pragma_Implicit_Packing
=>
17464 Check_Arg_Count
(0);
17465 Implicit_Packing
:= True;
17472 -- [Convention =>] convention_IDENTIFIER,
17473 -- [Entity =>] LOCAL_NAME
17474 -- [, [External_Name =>] static_string_EXPRESSION ]
17475 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17477 when Pragma_Import
=>
17478 Check_Ada_83_Warning
;
17482 Name_External_Name
,
17485 Check_At_Least_N_Arguments
(2);
17486 Check_At_Most_N_Arguments
(4);
17487 Process_Import_Or_Interface
;
17489 ---------------------
17490 -- Import_Function --
17491 ---------------------
17493 -- pragma Import_Function (
17494 -- [Internal =>] LOCAL_NAME,
17495 -- [, [External =>] EXTERNAL_SYMBOL]
17496 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17497 -- [, [Result_Type =>] SUBTYPE_MARK]
17498 -- [, [Mechanism =>] MECHANISM]
17499 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
17501 -- EXTERNAL_SYMBOL ::=
17503 -- | static_string_EXPRESSION
17505 -- PARAMETER_TYPES ::=
17507 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17509 -- TYPE_DESIGNATOR ::=
17511 -- | subtype_Name ' Access
17515 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17517 -- MECHANISM_ASSOCIATION ::=
17518 -- [formal_parameter_NAME =>] MECHANISM_NAME
17520 -- MECHANISM_NAME ::=
17524 when Pragma_Import_Function
=> Import_Function
: declare
17525 Args
: Args_List
(1 .. 6);
17526 Names
: constant Name_List
(1 .. 6) := (
17529 Name_Parameter_Types
,
17532 Name_Result_Mechanism
);
17534 Internal
: Node_Id
renames Args
(1);
17535 External
: Node_Id
renames Args
(2);
17536 Parameter_Types
: Node_Id
renames Args
(3);
17537 Result_Type
: Node_Id
renames Args
(4);
17538 Mechanism
: Node_Id
renames Args
(5);
17539 Result_Mechanism
: Node_Id
renames Args
(6);
17543 Gather_Associations
(Names
, Args
);
17544 Process_Extended_Import_Export_Subprogram_Pragma
(
17545 Arg_Internal
=> Internal
,
17546 Arg_External
=> External
,
17547 Arg_Parameter_Types
=> Parameter_Types
,
17548 Arg_Result_Type
=> Result_Type
,
17549 Arg_Mechanism
=> Mechanism
,
17550 Arg_Result_Mechanism
=> Result_Mechanism
);
17551 end Import_Function
;
17553 -------------------
17554 -- Import_Object --
17555 -------------------
17557 -- pragma Import_Object (
17558 -- [Internal =>] LOCAL_NAME
17559 -- [, [External =>] EXTERNAL_SYMBOL]
17560 -- [, [Size =>] EXTERNAL_SYMBOL]);
17562 -- EXTERNAL_SYMBOL ::=
17564 -- | static_string_EXPRESSION
17566 when Pragma_Import_Object
=> Import_Object
: declare
17567 Args
: Args_List
(1 .. 3);
17568 Names
: constant Name_List
(1 .. 3) := (
17573 Internal
: Node_Id
renames Args
(1);
17574 External
: Node_Id
renames Args
(2);
17575 Size
: Node_Id
renames Args
(3);
17579 Gather_Associations
(Names
, Args
);
17580 Process_Extended_Import_Export_Object_Pragma
(
17581 Arg_Internal
=> Internal
,
17582 Arg_External
=> External
,
17586 ----------------------
17587 -- Import_Procedure --
17588 ----------------------
17590 -- pragma Import_Procedure (
17591 -- [Internal =>] LOCAL_NAME
17592 -- [, [External =>] EXTERNAL_SYMBOL]
17593 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17594 -- [, [Mechanism =>] MECHANISM]);
17596 -- EXTERNAL_SYMBOL ::=
17598 -- | static_string_EXPRESSION
17600 -- PARAMETER_TYPES ::=
17602 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17604 -- TYPE_DESIGNATOR ::=
17606 -- | subtype_Name ' Access
17610 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17612 -- MECHANISM_ASSOCIATION ::=
17613 -- [formal_parameter_NAME =>] MECHANISM_NAME
17615 -- MECHANISM_NAME ::=
17619 when Pragma_Import_Procedure
=> Import_Procedure
: declare
17620 Args
: Args_List
(1 .. 4);
17621 Names
: constant Name_List
(1 .. 4) := (
17624 Name_Parameter_Types
,
17627 Internal
: Node_Id
renames Args
(1);
17628 External
: Node_Id
renames Args
(2);
17629 Parameter_Types
: Node_Id
renames Args
(3);
17630 Mechanism
: Node_Id
renames Args
(4);
17634 Gather_Associations
(Names
, Args
);
17635 Process_Extended_Import_Export_Subprogram_Pragma
(
17636 Arg_Internal
=> Internal
,
17637 Arg_External
=> External
,
17638 Arg_Parameter_Types
=> Parameter_Types
,
17639 Arg_Mechanism
=> Mechanism
);
17640 end Import_Procedure
;
17642 -----------------------------
17643 -- Import_Valued_Procedure --
17644 -----------------------------
17646 -- pragma Import_Valued_Procedure (
17647 -- [Internal =>] LOCAL_NAME
17648 -- [, [External =>] EXTERNAL_SYMBOL]
17649 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
17650 -- [, [Mechanism =>] MECHANISM]);
17652 -- EXTERNAL_SYMBOL ::=
17654 -- | static_string_EXPRESSION
17656 -- PARAMETER_TYPES ::=
17658 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
17660 -- TYPE_DESIGNATOR ::=
17662 -- | subtype_Name ' Access
17666 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
17668 -- MECHANISM_ASSOCIATION ::=
17669 -- [formal_parameter_NAME =>] MECHANISM_NAME
17671 -- MECHANISM_NAME ::=
17675 when Pragma_Import_Valued_Procedure
=>
17676 Import_Valued_Procedure
: declare
17677 Args
: Args_List
(1 .. 4);
17678 Names
: constant Name_List
(1 .. 4) := (
17681 Name_Parameter_Types
,
17684 Internal
: Node_Id
renames Args
(1);
17685 External
: Node_Id
renames Args
(2);
17686 Parameter_Types
: Node_Id
renames Args
(3);
17687 Mechanism
: Node_Id
renames Args
(4);
17691 Gather_Associations
(Names
, Args
);
17692 Process_Extended_Import_Export_Subprogram_Pragma
(
17693 Arg_Internal
=> Internal
,
17694 Arg_External
=> External
,
17695 Arg_Parameter_Types
=> Parameter_Types
,
17696 Arg_Mechanism
=> Mechanism
);
17697 end Import_Valued_Procedure
;
17703 -- pragma Independent (LOCAL_NAME);
17705 when Pragma_Independent
=>
17706 Process_Atomic_Independent_Shared_Volatile
;
17708 ----------------------------
17709 -- Independent_Components --
17710 ----------------------------
17712 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
17714 when Pragma_Independent_Components
=> Independent_Components
: declare
17722 Check_Ada_83_Warning
;
17724 Check_No_Identifiers
;
17725 Check_Arg_Count
(1);
17726 Check_Arg_Is_Local_Name
(Arg1
);
17727 E_Id
:= Get_Pragma_Arg
(Arg1
);
17729 if Etype
(E_Id
) = Any_Type
then
17733 E
:= Entity
(E_Id
);
17735 -- A record type with a self-referential component of anonymous
17736 -- access type is given an incomplete view in order to handle the
17739 -- type Rec is record
17740 -- Self : access Rec;
17746 -- type Ptr is access Rec;
17747 -- type Rec is record
17751 -- Since the incomplete view is now the initial view of the type,
17752 -- the argument of the pragma will reference the incomplete view,
17753 -- but this view is illegal according to the semantics of the
17756 -- Obtain the full view of an internally-generated incomplete type
17757 -- only. This way an attempt to associate the pragma with a source
17758 -- incomplete type is still caught.
17760 if Ekind
(E
) = E_Incomplete_Type
17761 and then not Comes_From_Source
(E
)
17762 and then Present
(Full_View
(E
))
17764 E
:= Full_View
(E
);
17767 -- A pragma that applies to a Ghost entity becomes Ghost for the
17768 -- purposes of legality checks and removal of ignored Ghost code.
17770 Mark_Ghost_Pragma
(N
, E
);
17772 -- Check duplicate before we chain ourselves
17774 Check_Duplicate_Pragma
(E
);
17776 -- Check appropriate entity
17778 if Rep_Item_Too_Early
(E
, N
)
17780 Rep_Item_Too_Late
(E
, N
)
17785 D
:= Declaration_Node
(E
);
17788 -- The flag is set on the base type, or on the object
17790 if K
= N_Full_Type_Declaration
17791 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
17793 Set_Has_Independent_Components
(Base_Type
(E
));
17794 Record_Independence_Check
(N
, Base_Type
(E
));
17796 -- For record type, set all components independent
17798 if Is_Record_Type
(E
) then
17799 C
:= First_Component
(E
);
17800 while Present
(C
) loop
17801 Set_Is_Independent
(C
);
17802 Next_Component
(C
);
17806 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
17807 and then Nkind
(D
) = N_Object_Declaration
17808 and then Nkind
(Object_Definition
(D
)) =
17809 N_Constrained_Array_Definition
17811 Set_Has_Independent_Components
(E
);
17812 Record_Independence_Check
(N
, E
);
17815 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
17817 end Independent_Components
;
17819 -----------------------
17820 -- Initial_Condition --
17821 -----------------------
17823 -- pragma Initial_Condition (boolean_EXPRESSION);
17825 -- Characteristics:
17827 -- * Analysis - The annotation undergoes initial checks to verify
17828 -- the legal placement and context. Secondary checks preanalyze the
17831 -- Analyze_Initial_Condition_In_Decl_Part
17833 -- * Expansion - The annotation is expanded during the expansion of
17834 -- the package body whose declaration is subject to the annotation
17837 -- Expand_Pragma_Initial_Condition
17839 -- * Template - The annotation utilizes the generic template of the
17840 -- related package declaration.
17842 -- * Globals - Capture of global references must occur after full
17845 -- * Instance - The annotation is instantiated automatically when
17846 -- the related generic package is instantiated.
17848 when Pragma_Initial_Condition
=> Initial_Condition
: declare
17849 Pack_Decl
: Node_Id
;
17850 Pack_Id
: Entity_Id
;
17854 Check_No_Identifiers
;
17855 Check_Arg_Count
(1);
17857 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17859 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17860 N_Package_Declaration
)
17866 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17868 -- A pragma that applies to a Ghost entity becomes Ghost for the
17869 -- purposes of legality checks and removal of ignored Ghost code.
17871 Mark_Ghost_Pragma
(N
, Pack_Id
);
17873 -- Chain the pragma on the contract for further processing by
17874 -- Analyze_Initial_Condition_In_Decl_Part.
17876 Add_Contract_Item
(N
, Pack_Id
);
17878 -- The legality checks of pragmas Abstract_State, Initializes, and
17879 -- Initial_Condition are affected by the SPARK mode in effect. In
17880 -- addition, these three pragmas are subject to an inherent order:
17882 -- 1) Abstract_State
17884 -- 3) Initial_Condition
17886 -- Analyze all these pragmas in the order outlined above
17888 Analyze_If_Present
(Pragma_SPARK_Mode
);
17889 Analyze_If_Present
(Pragma_Abstract_State
);
17890 Analyze_If_Present
(Pragma_Initializes
);
17891 end Initial_Condition
;
17893 ------------------------
17894 -- Initialize_Scalars --
17895 ------------------------
17897 -- pragma Initialize_Scalars
17898 -- [ ( TYPE_VALUE_PAIR {, TYPE_VALUE_PAIR} ) ];
17900 -- TYPE_VALUE_PAIR ::=
17901 -- SCALAR_TYPE => static_EXPRESSION
17907 -- | Long_Long_Flat
17917 when Pragma_Initialize_Scalars
=> Do_Initialize_Scalars
: declare
17918 Seen
: array (Scalar_Id
) of Node_Id
:= (others => Empty
);
17919 -- This collection holds the individual pairs which specify the
17920 -- invalid values of their respective scalar types.
17922 procedure Analyze_Float_Value
17923 (Scal_Typ
: Float_Scalar_Id
;
17924 Val_Expr
: Node_Id
);
17925 -- Analyze a type value pair associated with float type Scal_Typ
17926 -- and expression Val_Expr.
17928 procedure Analyze_Integer_Value
17929 (Scal_Typ
: Integer_Scalar_Id
;
17930 Val_Expr
: Node_Id
);
17931 -- Analyze a type value pair associated with integer type Scal_Typ
17932 -- and expression Val_Expr.
17934 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
);
17935 -- Analyze type value pair Pair
17937 -------------------------
17938 -- Analyze_Float_Value --
17939 -------------------------
17941 procedure Analyze_Float_Value
17942 (Scal_Typ
: Float_Scalar_Id
;
17943 Val_Expr
: Node_Id
)
17946 Analyze_And_Resolve
(Val_Expr
, Any_Real
);
17948 if Is_OK_Static_Expression
(Val_Expr
) then
17949 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value_R
(Val_Expr
));
17952 Error_Msg_Name_1
:= Scal_Typ
;
17953 Error_Msg_N
("value for type % must be static", Val_Expr
);
17955 end Analyze_Float_Value
;
17957 ---------------------------
17958 -- Analyze_Integer_Value --
17959 ---------------------------
17961 procedure Analyze_Integer_Value
17962 (Scal_Typ
: Integer_Scalar_Id
;
17963 Val_Expr
: Node_Id
)
17966 Analyze_And_Resolve
(Val_Expr
, Any_Integer
);
17968 if Is_OK_Static_Expression
(Val_Expr
) then
17969 Set_Invalid_Scalar_Value
(Scal_Typ
, Expr_Value
(Val_Expr
));
17972 Error_Msg_Name_1
:= Scal_Typ
;
17973 Error_Msg_N
("value for type % must be static", Val_Expr
);
17975 end Analyze_Integer_Value
;
17977 -----------------------------
17978 -- Analyze_Type_Value_Pair --
17979 -----------------------------
17981 procedure Analyze_Type_Value_Pair
(Pair
: Node_Id
) is
17982 Scal_Typ
: constant Name_Id
:= Chars
(Pair
);
17983 Val_Expr
: constant Node_Id
:= Expression
(Pair
);
17984 Prev_Pair
: Node_Id
;
17987 if Scal_Typ
in Scalar_Id
then
17988 Prev_Pair
:= Seen
(Scal_Typ
);
17990 -- Prevent multiple attempts to set a value for a scalar
17993 if Present
(Prev_Pair
) then
17994 Error_Msg_Name_1
:= Scal_Typ
;
17996 ("cannot specify multiple invalid values for type %",
17999 Error_Msg_Sloc
:= Sloc
(Prev_Pair
);
18000 Error_Msg_N
("previous value set #", Pair
);
18002 -- Ignore the effects of the pair, but do not halt the
18003 -- analysis of the pragma altogether.
18007 -- Otherwise capture the first pair for this scalar type
18010 Seen
(Scal_Typ
) := Pair
;
18013 if Scal_Typ
in Float_Scalar_Id
then
18014 Analyze_Float_Value
(Scal_Typ
, Val_Expr
);
18016 else pragma Assert
(Scal_Typ
in Integer_Scalar_Id
);
18017 Analyze_Integer_Value
(Scal_Typ
, Val_Expr
);
18020 -- Otherwise the scalar family is illegal
18023 Error_Msg_Name_1
:= Pname
;
18025 ("argument of pragma % must denote valid scalar family",
18028 end Analyze_Type_Value_Pair
;
18032 Pairs
: constant List_Id
:= Pragma_Argument_Associations
(N
);
18035 -- Start of processing for Do_Initialize_Scalars
18039 Check_Valid_Configuration_Pragma
;
18040 Check_Restriction
(No_Initialize_Scalars
, N
);
18042 -- Ignore the effects of the pragma when No_Initialize_Scalars is
18045 if Restriction_Active
(No_Initialize_Scalars
) then
18048 -- Initialize_Scalars creates false positives in CodePeer, and
18049 -- incorrect negative results in GNATprove mode, so ignore this
18050 -- pragma in these modes.
18052 elsif CodePeer_Mode
or GNATprove_Mode
then
18055 -- Otherwise analyze the pragma
18058 if Present
(Pairs
) then
18060 -- Install Standard in order to provide access to primitive
18061 -- types in case the expressions contain attributes such as
18064 Push_Scope
(Standard_Standard
);
18066 Pair
:= First
(Pairs
);
18067 while Present
(Pair
) loop
18068 Analyze_Type_Value_Pair
(Pair
);
18077 Init_Or_Norm_Scalars
:= True;
18078 Initialize_Scalars
:= True;
18080 end Do_Initialize_Scalars
;
18086 -- pragma Initializes (INITIALIZATION_LIST);
18088 -- INITIALIZATION_LIST ::=
18090 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
18092 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
18097 -- | (INPUT {, INPUT})
18101 -- Characteristics:
18103 -- * Analysis - The annotation undergoes initial checks to verify
18104 -- the legal placement and context. Secondary checks preanalyze the
18107 -- Analyze_Initializes_In_Decl_Part
18109 -- * Expansion - None.
18111 -- * Template - The annotation utilizes the generic template of the
18112 -- related package declaration.
18114 -- * Globals - Capture of global references must occur after full
18117 -- * Instance - The annotation is instantiated automatically when
18118 -- the related generic package is instantiated.
18120 when Pragma_Initializes
=> Initializes
: declare
18121 Pack_Decl
: Node_Id
;
18122 Pack_Id
: Entity_Id
;
18126 Check_No_Identifiers
;
18127 Check_Arg_Count
(1);
18129 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
18131 if not Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
18132 N_Package_Declaration
)
18138 Pack_Id
:= Defining_Entity
(Pack_Decl
);
18140 -- A pragma that applies to a Ghost entity becomes Ghost for the
18141 -- purposes of legality checks and removal of ignored Ghost code.
18143 Mark_Ghost_Pragma
(N
, Pack_Id
);
18144 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
18146 -- Chain the pragma on the contract for further processing by
18147 -- Analyze_Initializes_In_Decl_Part.
18149 Add_Contract_Item
(N
, Pack_Id
);
18151 -- The legality checks of pragmas Abstract_State, Initializes, and
18152 -- Initial_Condition are affected by the SPARK mode in effect. In
18153 -- addition, these three pragmas are subject to an inherent order:
18155 -- 1) Abstract_State
18157 -- 3) Initial_Condition
18159 -- Analyze all these pragmas in the order outlined above
18161 Analyze_If_Present
(Pragma_SPARK_Mode
);
18162 Analyze_If_Present
(Pragma_Abstract_State
);
18163 Analyze_If_Present
(Pragma_Initial_Condition
);
18170 -- pragma Inline ( NAME {, NAME} );
18172 when Pragma_Inline
=>
18174 -- Pragma always active unless in GNATprove mode. It is disabled
18175 -- in GNATprove mode because frontend inlining is applied
18176 -- independently of pragmas Inline and Inline_Always for
18177 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
18180 if not GNATprove_Mode
then
18182 -- Inline status is Enabled if option -gnatn is specified.
18183 -- However this status determines only the value of the
18184 -- Is_Inlined flag on the subprogram and does not prevent
18185 -- the pragma itself from being recorded for later use,
18186 -- in particular for a later modification of Is_Inlined
18187 -- independently of the -gnatn option.
18189 -- In other words, if -gnatn is specified for a unit, then
18190 -- all Inline pragmas processed for the compilation of this
18191 -- unit, including those in the spec of other units, are
18192 -- activated, so subprograms will be inlined across units.
18194 -- If -gnatn is not specified, no Inline pragma is activated
18195 -- here, which means that subprograms will not be inlined
18196 -- across units. The Is_Inlined flag will nevertheless be
18197 -- set later when bodies are analyzed, so subprograms will
18198 -- be inlined within the unit.
18200 if Inline_Active
then
18201 Process_Inline
(Enabled
);
18203 Process_Inline
(Disabled
);
18207 -------------------
18208 -- Inline_Always --
18209 -------------------
18211 -- pragma Inline_Always ( NAME {, NAME} );
18213 when Pragma_Inline_Always
=>
18216 -- Pragma always active unless in CodePeer mode or GNATprove
18217 -- mode. It is disabled in CodePeer mode because inlining is
18218 -- not helpful, and enabling it caused walk order issues. It
18219 -- is disabled in GNATprove mode because frontend inlining is
18220 -- applied independently of pragmas Inline and Inline_Always for
18221 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
18224 if not CodePeer_Mode
and not GNATprove_Mode
then
18225 Process_Inline
(Enabled
);
18228 --------------------
18229 -- Inline_Generic --
18230 --------------------
18232 -- pragma Inline_Generic (NAME {, NAME});
18234 when Pragma_Inline_Generic
=>
18236 Process_Generic_List
;
18238 ----------------------
18239 -- Inspection_Point --
18240 ----------------------
18242 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
18244 when Pragma_Inspection_Point
=> Inspection_Point
: declare
18251 if Arg_Count
> 0 then
18254 Exp
:= Get_Pragma_Arg
(Arg
);
18257 if not Is_Entity_Name
(Exp
)
18258 or else not Is_Object
(Entity
(Exp
))
18260 Error_Pragma_Arg
("object name required", Arg
);
18264 exit when No
(Arg
);
18267 end Inspection_Point
;
18273 -- pragma Interface (
18274 -- [ Convention =>] convention_IDENTIFIER,
18275 -- [ Entity =>] LOCAL_NAME
18276 -- [, [External_Name =>] static_string_EXPRESSION ]
18277 -- [, [Link_Name =>] static_string_EXPRESSION ]);
18279 when Pragma_Interface
=>
18284 Name_External_Name
,
18286 Check_At_Least_N_Arguments
(2);
18287 Check_At_Most_N_Arguments
(4);
18288 Process_Import_Or_Interface
;
18290 -- In Ada 2005, the permission to use Interface (a reserved word)
18291 -- as a pragma name is considered an obsolescent feature, and this
18292 -- pragma was already obsolescent in Ada 95.
18294 if Ada_Version
>= Ada_95
then
18296 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
18298 if Warn_On_Obsolescent_Feature
then
18300 ("pragma Interface is an obsolescent feature?j?", N
);
18302 ("|use pragma Import instead?j?", N
);
18306 --------------------
18307 -- Interface_Name --
18308 --------------------
18310 -- pragma Interface_Name (
18311 -- [ Entity =>] LOCAL_NAME
18312 -- [,[External_Name =>] static_string_EXPRESSION ]
18313 -- [,[Link_Name =>] static_string_EXPRESSION ]);
18315 when Pragma_Interface_Name
=> Interface_Name
: declare
18317 Def_Id
: Entity_Id
;
18318 Hom_Id
: Entity_Id
;
18324 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
18325 Check_At_Least_N_Arguments
(2);
18326 Check_At_Most_N_Arguments
(3);
18327 Id
:= Get_Pragma_Arg
(Arg1
);
18330 -- This is obsolete from Ada 95 on, but it is an implementation
18331 -- defined pragma, so we do not consider that it violates the
18332 -- restriction (No_Obsolescent_Features).
18334 if Ada_Version
>= Ada_95
then
18335 if Warn_On_Obsolescent_Feature
then
18337 ("pragma Interface_Name is an obsolescent feature?j?", N
);
18339 ("|use pragma Import instead?j?", N
);
18343 if not Is_Entity_Name
(Id
) then
18345 ("first argument for pragma% must be entity name", Arg1
);
18346 elsif Etype
(Id
) = Any_Type
then
18349 Def_Id
:= Entity
(Id
);
18352 -- Special DEC-compatible processing for the object case, forces
18353 -- object to be imported.
18355 if Ekind
(Def_Id
) = E_Variable
then
18356 Kill_Size_Check_Code
(Def_Id
);
18357 Note_Possible_Modification
(Id
, Sure
=> False);
18359 -- Initialization is not allowed for imported variable
18361 if Present
(Expression
(Parent
(Def_Id
)))
18362 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
18364 Error_Msg_Sloc
:= Sloc
(Def_Id
);
18366 ("no initialization allowed for declaration of& #",
18370 -- For compatibility, support VADS usage of providing both
18371 -- pragmas Interface and Interface_Name to obtain the effect
18372 -- of a single Import pragma.
18374 if Is_Imported
(Def_Id
)
18375 and then Present
(First_Rep_Item
(Def_Id
))
18376 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
18377 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
18382 Set_Imported
(Def_Id
);
18385 Set_Is_Public
(Def_Id
);
18386 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18389 -- Otherwise must be subprogram
18391 elsif not Is_Subprogram
(Def_Id
) then
18393 ("argument of pragma% is not subprogram", Arg1
);
18396 Check_At_Most_N_Arguments
(3);
18400 -- Loop through homonyms
18403 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
18405 if Is_Imported
(Def_Id
) then
18406 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
18410 exit when From_Aspect_Specification
(N
);
18411 Hom_Id
:= Homonym
(Hom_Id
);
18413 exit when No
(Hom_Id
)
18414 or else Scope
(Hom_Id
) /= Current_Scope
;
18419 ("argument of pragma% is not imported subprogram",
18423 end Interface_Name
;
18425 -----------------------
18426 -- Interrupt_Handler --
18427 -----------------------
18429 -- pragma Interrupt_Handler (handler_NAME);
18431 when Pragma_Interrupt_Handler
=>
18432 Check_Ada_83_Warning
;
18433 Check_Arg_Count
(1);
18434 Check_No_Identifiers
;
18436 if No_Run_Time_Mode
then
18437 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
18439 Check_Interrupt_Or_Attach_Handler
;
18440 Process_Interrupt_Or_Attach_Handler
;
18443 ------------------------
18444 -- Interrupt_Priority --
18445 ------------------------
18447 -- pragma Interrupt_Priority [(EXPRESSION)];
18449 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
18450 P
: constant Node_Id
:= Parent
(N
);
18455 Check_Ada_83_Warning
;
18457 if Arg_Count
/= 0 then
18458 Arg
:= Get_Pragma_Arg
(Arg1
);
18459 Check_Arg_Count
(1);
18460 Check_No_Identifiers
;
18462 -- The expression must be analyzed in the special manner
18463 -- described in "Handling of Default and Per-Object
18464 -- Expressions" in sem.ads.
18466 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
18469 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
18474 Ent
:= Defining_Identifier
(Parent
(P
));
18476 -- Check duplicate pragma before we chain the pragma in the Rep
18477 -- Item chain of Ent.
18479 Check_Duplicate_Pragma
(Ent
);
18480 Record_Rep_Item
(Ent
, N
);
18482 -- Check the No_Task_At_Interrupt_Priority restriction
18484 if Nkind
(P
) = N_Task_Definition
then
18485 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
18488 end Interrupt_Priority
;
18490 ---------------------
18491 -- Interrupt_State --
18492 ---------------------
18494 -- pragma Interrupt_State (
18495 -- [Name =>] INTERRUPT_ID,
18496 -- [State =>] INTERRUPT_STATE);
18498 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
18499 -- INTERRUPT_STATE => System | Runtime | User
18501 -- Note: if the interrupt id is given as an identifier, then it must
18502 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
18503 -- given as a static integer expression which must be in the range of
18504 -- Ada.Interrupts.Interrupt_ID.
18506 when Pragma_Interrupt_State
=> Interrupt_State
: declare
18507 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
18508 -- This is the entity Ada.Interrupts.Interrupt_ID;
18510 State_Type
: Character;
18511 -- Set to 's'/'r'/'u' for System/Runtime/User
18514 -- Index to entry in Interrupt_States table
18517 -- Value of interrupt
18519 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18520 -- The first argument to the pragma
18522 Int_Ent
: Entity_Id
;
18523 -- Interrupt entity in Ada.Interrupts.Names
18527 Check_Arg_Order
((Name_Name
, Name_State
));
18528 Check_Arg_Count
(2);
18530 Check_Optional_Identifier
(Arg1
, Name_Name
);
18531 Check_Optional_Identifier
(Arg2
, Name_State
);
18532 Check_Arg_Is_Identifier
(Arg2
);
18534 -- First argument is identifier
18536 if Nkind
(Arg1X
) = N_Identifier
then
18538 -- Search list of names in Ada.Interrupts.Names
18540 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
18542 if No
(Int_Ent
) then
18543 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
18545 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
18546 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
18550 Next_Entity
(Int_Ent
);
18553 -- First argument is not an identifier, so it must be a static
18554 -- expression of type Ada.Interrupts.Interrupt_ID.
18557 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
18558 Int_Val
:= Expr_Value
(Arg1X
);
18560 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
18562 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
18565 ("value not in range of type "
18566 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
18572 case Chars
(Get_Pragma_Arg
(Arg2
)) is
18573 when Name_Runtime
=> State_Type
:= 'r';
18574 when Name_System
=> State_Type
:= 's';
18575 when Name_User
=> State_Type
:= 'u';
18578 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
18581 -- Check if entry is already stored
18583 IST_Num
:= Interrupt_States
.First
;
18585 -- If entry not found, add it
18587 if IST_Num
> Interrupt_States
.Last
then
18588 Interrupt_States
.Append
18589 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
18590 Interrupt_State
=> State_Type
,
18591 Pragma_Loc
=> Loc
));
18594 -- Case of entry for the same entry
18596 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
18599 -- If state matches, done, no need to make redundant entry
18602 State_Type
= Interrupt_States
.Table
(IST_Num
).
18605 -- Otherwise if state does not match, error
18608 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
18610 ("state conflicts with that given #", Arg2
);
18614 IST_Num
:= IST_Num
+ 1;
18616 end Interrupt_State
;
18622 -- pragma Invariant
18623 -- ([Entity =>] type_LOCAL_NAME,
18624 -- [Check =>] EXPRESSION
18625 -- [,[Message =>] String_Expression]);
18627 when Pragma_Invariant
=> Invariant
: declare
18634 Check_At_Least_N_Arguments
(2);
18635 Check_At_Most_N_Arguments
(3);
18636 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18637 Check_Optional_Identifier
(Arg2
, Name_Check
);
18639 if Arg_Count
= 3 then
18640 Check_Optional_Identifier
(Arg3
, Name_Message
);
18641 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
18644 Check_Arg_Is_Local_Name
(Arg1
);
18646 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
18647 Find_Type
(Typ_Arg
);
18648 Typ
:= Entity
(Typ_Arg
);
18650 -- Nothing to do of the related type is erroneous in some way
18652 if Typ
= Any_Type
then
18655 -- AI12-0041: Invariants are allowed in interface types
18657 elsif Is_Interface
(Typ
) then
18660 -- An invariant must apply to a private type, or appear in the
18661 -- private part of a package spec and apply to a completion.
18662 -- a class-wide invariant can only appear on a private declaration
18663 -- or private extension, not a completion.
18665 -- A [class-wide] invariant may be associated a [limited] private
18666 -- type or a private extension.
18668 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
18670 E_Record_Type_With_Private
)
18674 -- A non-class-wide invariant may be associated with the full view
18675 -- of a [limited] private type or a private extension.
18677 elsif Has_Private_Declaration
(Typ
)
18678 and then not Class_Present
(N
)
18682 -- A class-wide invariant may appear on the partial view only
18684 elsif Class_Present
(N
) then
18686 ("pragma % only allowed for private type", Arg1
);
18689 -- A regular invariant may appear on both views
18693 ("pragma % only allowed for private type or corresponding "
18694 & "full view", Arg1
);
18698 -- An invariant associated with an abstract type (this includes
18699 -- interfaces) must be class-wide.
18701 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
18703 ("pragma % not allowed for abstract type", Arg1
);
18707 -- A pragma that applies to a Ghost entity becomes Ghost for the
18708 -- purposes of legality checks and removal of ignored Ghost code.
18710 Mark_Ghost_Pragma
(N
, Typ
);
18712 -- The pragma defines a type-specific invariant, the type is said
18713 -- to have invariants of its "own".
18715 Set_Has_Own_Invariants
(Typ
);
18717 -- If the invariant is class-wide, then it can be inherited by
18718 -- derived or interface implementing types. The type is said to
18719 -- have "inheritable" invariants.
18721 if Class_Present
(N
) then
18722 Set_Has_Inheritable_Invariants
(Typ
);
18725 -- Chain the pragma on to the rep item chain, for processing when
18726 -- the type is frozen.
18728 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18730 -- Create the declaration of the invariant procedure that will
18731 -- verify the invariant at run time. Interfaces are treated as the
18732 -- partial view of a private type in order to achieve uniformity
18733 -- with the general case. As a result, an interface receives only
18734 -- a "partial" invariant procedure, which is never called.
18736 Build_Invariant_Procedure_Declaration
18738 Partial_Invariant
=> Is_Interface
(Typ
));
18745 -- pragma Keep_Names ([On => ] LOCAL_NAME);
18747 when Pragma_Keep_Names
=> Keep_Names
: declare
18752 Check_Arg_Count
(1);
18753 Check_Optional_Identifier
(Arg1
, Name_On
);
18754 Check_Arg_Is_Local_Name
(Arg1
);
18756 Arg
:= Get_Pragma_Arg
(Arg1
);
18759 if Etype
(Arg
) = Any_Type
then
18763 if not Is_Entity_Name
(Arg
)
18764 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
18767 ("pragma% requires a local enumeration type", Arg1
);
18770 Set_Discard_Names
(Entity
(Arg
), False);
18777 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
18779 when Pragma_License
=>
18782 -- Do not analyze pragma any further in CodePeer mode, to avoid
18783 -- extraneous errors in this implementation-dependent pragma,
18784 -- which has a different profile on other compilers.
18786 if CodePeer_Mode
then
18790 Check_Arg_Count
(1);
18791 Check_No_Identifiers
;
18792 Check_Valid_Configuration_Pragma
;
18793 Check_Arg_Is_Identifier
(Arg1
);
18796 Sind
: constant Source_File_Index
:=
18797 Source_Index
(Current_Sem_Unit
);
18800 case Chars
(Get_Pragma_Arg
(Arg1
)) is
18802 Set_License
(Sind
, GPL
);
18804 when Name_Modified_GPL
=>
18805 Set_License
(Sind
, Modified_GPL
);
18807 when Name_Restricted
=>
18808 Set_License
(Sind
, Restricted
);
18810 when Name_Unrestricted
=>
18811 Set_License
(Sind
, Unrestricted
);
18814 Error_Pragma_Arg
("invalid license name", Arg1
);
18822 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
18824 when Pragma_Link_With
=> Link_With
: declare
18830 if Operating_Mode
= Generate_Code
18831 and then In_Extended_Main_Source_Unit
(N
)
18833 Check_At_Least_N_Arguments
(1);
18834 Check_No_Identifiers
;
18835 Check_Is_In_Decl_Part_Or_Package_Spec
;
18836 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18840 while Present
(Arg
) loop
18841 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18843 -- Store argument, converting sequences of spaces to a
18844 -- single null character (this is one of the differences
18845 -- in processing between Link_With and Linker_Options).
18847 Arg_Store
: declare
18848 C
: constant Char_Code
:= Get_Char_Code
(' ');
18849 S
: constant String_Id
:=
18850 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
18851 L
: constant Nat
:= String_Length
(S
);
18854 procedure Skip_Spaces
;
18855 -- Advance F past any spaces
18861 procedure Skip_Spaces
is
18863 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
18868 -- Start of processing for Arg_Store
18871 Skip_Spaces
; -- skip leading spaces
18873 -- Loop through characters, changing any embedded
18874 -- sequence of spaces to a single null character (this
18875 -- is how Link_With/Linker_Options differ)
18878 if Get_String_Char
(S
, F
) = C
then
18881 Store_String_Char
(ASCII
.NUL
);
18884 Store_String_Char
(Get_String_Char
(S
, F
));
18892 if Present
(Arg
) then
18893 Store_String_Char
(ASCII
.NUL
);
18897 Store_Linker_Option_String
(End_String
);
18905 -- pragma Linker_Alias (
18906 -- [Entity =>] LOCAL_NAME
18907 -- [Target =>] static_string_EXPRESSION);
18909 when Pragma_Linker_Alias
=>
18911 Check_Arg_Order
((Name_Entity
, Name_Target
));
18912 Check_Arg_Count
(2);
18913 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18914 Check_Optional_Identifier
(Arg2
, Name_Target
);
18915 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18916 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18918 -- The only processing required is to link this item on to the
18919 -- list of rep items for the given entity. This is accomplished
18920 -- by the call to Rep_Item_Too_Late (when no error is detected
18921 -- and False is returned).
18923 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
18926 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18929 ------------------------
18930 -- Linker_Constructor --
18931 ------------------------
18933 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
18935 -- Code is shared with Linker_Destructor
18937 -----------------------
18938 -- Linker_Destructor --
18939 -----------------------
18941 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
18943 when Pragma_Linker_Constructor
18944 | Pragma_Linker_Destructor
18946 Linker_Constructor
: declare
18952 Check_Arg_Count
(1);
18953 Check_No_Identifiers
;
18954 Check_Arg_Is_Local_Name
(Arg1
);
18955 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
18957 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
18959 if not Is_Library_Level_Entity
(Proc
) then
18961 ("argument for pragma% must be library level entity", Arg1
);
18964 -- The only processing required is to link this item on to the
18965 -- list of rep items for the given entity. This is accomplished
18966 -- by the call to Rep_Item_Too_Late (when no error is detected
18967 -- and False is returned).
18969 if Rep_Item_Too_Late
(Proc
, N
) then
18972 Set_Has_Gigi_Rep_Item
(Proc
);
18974 end Linker_Constructor
;
18976 --------------------
18977 -- Linker_Options --
18978 --------------------
18980 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
18982 when Pragma_Linker_Options
=> Linker_Options
: declare
18986 Check_Ada_83_Warning
;
18987 Check_No_Identifiers
;
18988 Check_Arg_Count
(1);
18989 Check_Is_In_Decl_Part_Or_Package_Spec
;
18990 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18991 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
18994 while Present
(Arg
) loop
18995 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
18996 Store_String_Char
(ASCII
.NUL
);
18998 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
19002 if Operating_Mode
= Generate_Code
19003 and then In_Extended_Main_Source_Unit
(N
)
19005 Store_Linker_Option_String
(End_String
);
19007 end Linker_Options
;
19009 --------------------
19010 -- Linker_Section --
19011 --------------------
19013 -- pragma Linker_Section (
19014 -- [Entity =>] LOCAL_NAME
19015 -- [Section =>] static_string_EXPRESSION);
19017 when Pragma_Linker_Section
=> Linker_Section
: declare
19022 Ghost_Error_Posted
: Boolean := False;
19023 -- Flag set when an error concerning the illegal mix of Ghost and
19024 -- non-Ghost subprograms is emitted.
19026 Ghost_Id
: Entity_Id
:= Empty
;
19027 -- The entity of the first Ghost subprogram encountered while
19028 -- processing the arguments of the pragma.
19032 Check_Arg_Order
((Name_Entity
, Name_Section
));
19033 Check_Arg_Count
(2);
19034 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19035 Check_Optional_Identifier
(Arg2
, Name_Section
);
19036 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19037 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19039 -- Check kind of entity
19041 Arg
:= Get_Pragma_Arg
(Arg1
);
19042 Ent
:= Entity
(Arg
);
19044 case Ekind
(Ent
) is
19046 -- Objects (constants and variables) and types. For these cases
19047 -- all we need to do is to set the Linker_Section_pragma field,
19048 -- checking that we do not have a duplicate.
19054 LPE
:= Linker_Section_Pragma
(Ent
);
19056 if Present
(LPE
) then
19057 Error_Msg_Sloc
:= Sloc
(LPE
);
19059 ("Linker_Section already specified for &#", Arg1
, Ent
);
19062 Set_Linker_Section_Pragma
(Ent
, N
);
19064 -- A pragma that applies to a Ghost entity becomes Ghost for
19065 -- the purposes of legality checks and removal of ignored
19068 Mark_Ghost_Pragma
(N
, Ent
);
19072 when Subprogram_Kind
=>
19074 -- Aspect case, entity already set
19076 if From_Aspect_Specification
(N
) then
19077 Set_Linker_Section_Pragma
19078 (Entity
(Corresponding_Aspect
(N
)), N
);
19080 -- Pragma case, we must climb the homonym chain, but skip
19081 -- any for which the linker section is already set.
19085 if No
(Linker_Section_Pragma
(Ent
)) then
19086 Set_Linker_Section_Pragma
(Ent
, N
);
19088 -- A pragma that applies to a Ghost entity becomes
19089 -- Ghost for the purposes of legality checks and
19090 -- removal of ignored Ghost code.
19092 Mark_Ghost_Pragma
(N
, Ent
);
19094 -- Capture the entity of the first Ghost subprogram
19095 -- being processed for error detection purposes.
19097 if Is_Ghost_Entity
(Ent
) then
19098 if No
(Ghost_Id
) then
19102 -- Otherwise the subprogram is non-Ghost. It is
19103 -- illegal to mix references to Ghost and non-Ghost
19104 -- entities (SPARK RM 6.9).
19106 elsif Present
(Ghost_Id
)
19107 and then not Ghost_Error_Posted
19109 Ghost_Error_Posted
:= True;
19111 Error_Msg_Name_1
:= Pname
;
19113 ("pragma % cannot mention ghost and "
19114 & "non-ghost subprograms", N
);
19116 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19118 ("\& # declared as ghost", N
, Ghost_Id
);
19120 Error_Msg_Sloc
:= Sloc
(Ent
);
19122 ("\& # declared as non-ghost", N
, Ent
);
19126 Ent
:= Homonym
(Ent
);
19128 or else Scope
(Ent
) /= Current_Scope
;
19132 -- All other cases are illegal
19136 ("pragma% applies only to objects, subprograms, and types",
19139 end Linker_Section
;
19145 -- pragma List (On | Off)
19147 -- There is nothing to do here, since we did all the processing for
19148 -- this pragma in Par.Prag (so that it works properly even in syntax
19151 when Pragma_List
=>
19158 -- pragma Lock_Free [(Boolean_EXPRESSION)];
19160 when Pragma_Lock_Free
=> Lock_Free
: declare
19161 P
: constant Node_Id
:= Parent
(N
);
19167 Check_No_Identifiers
;
19168 Check_At_Most_N_Arguments
(1);
19170 -- Protected definition case
19172 if Nkind
(P
) = N_Protected_Definition
then
19173 Ent
:= Defining_Identifier
(Parent
(P
));
19177 if Arg_Count
= 1 then
19178 Arg
:= Get_Pragma_Arg
(Arg1
);
19179 Val
:= Is_True
(Static_Boolean
(Arg
));
19181 -- No arguments (expression is considered to be True)
19187 -- Check duplicate pragma before we chain the pragma in the Rep
19188 -- Item chain of Ent.
19190 Check_Duplicate_Pragma
(Ent
);
19191 Record_Rep_Item
(Ent
, N
);
19192 Set_Uses_Lock_Free
(Ent
, Val
);
19194 -- Anything else is incorrect placement
19201 --------------------
19202 -- Locking_Policy --
19203 --------------------
19205 -- pragma Locking_Policy (policy_IDENTIFIER);
19207 when Pragma_Locking_Policy
=> declare
19208 subtype LP_Range
is Name_Id
19209 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
19214 Check_Ada_83_Warning
;
19215 Check_Arg_Count
(1);
19216 Check_No_Identifiers
;
19217 Check_Arg_Is_Locking_Policy
(Arg1
);
19218 Check_Valid_Configuration_Pragma
;
19219 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19222 when Name_Ceiling_Locking
=> LP
:= 'C';
19223 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
19224 when Name_Inheritance_Locking
=> LP
:= 'I';
19227 if Locking_Policy
/= ' '
19228 and then Locking_Policy
/= LP
19230 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19231 Error_Pragma
("locking policy incompatible with policy#");
19233 -- Set new policy, but always preserve System_Location since we
19234 -- like the error message with the run time name.
19237 Locking_Policy
:= LP
;
19239 if Locking_Policy_Sloc
/= System_Location
then
19240 Locking_Policy_Sloc
:= Loc
;
19245 -------------------
19246 -- Loop_Optimize --
19247 -------------------
19249 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
19251 -- OPTIMIZATION_HINT ::=
19252 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
19254 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
19259 Check_At_Least_N_Arguments
(1);
19260 Check_No_Identifiers
;
19262 Hint
:= First
(Pragma_Argument_Associations
(N
));
19263 while Present
(Hint
) loop
19264 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
19272 Check_Loop_Pragma_Placement
;
19279 -- pragma Loop_Variant
19280 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
19282 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
19284 -- CHANGE_DIRECTION ::= Increases | Decreases
19286 when Pragma_Loop_Variant
=> Loop_Variant
: declare
19291 Check_At_Least_N_Arguments
(1);
19292 Check_Loop_Pragma_Placement
;
19294 -- Process all increasing / decreasing expressions
19296 Variant
:= First
(Pragma_Argument_Associations
(N
));
19297 while Present
(Variant
) loop
19298 if Chars
(Variant
) = No_Name
then
19299 Error_Pragma_Arg_Ident
("expect name `Increases`", Variant
);
19301 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
19305 Name
: String := Get_Name_String
(Chars
(Variant
));
19308 -- It is a common mistake to write "Increasing" for
19309 -- "Increases" or "Decreasing" for "Decreases". Recognize
19310 -- specially names starting with "incr" or "decr" to
19311 -- suggest the corresponding name.
19313 System
.Case_Util
.To_Lower
(Name
);
19315 if Name
'Length >= 4
19316 and then Name
(1 .. 4) = "incr"
19318 Error_Pragma_Arg_Ident
19319 ("expect name `Increases`", Variant
);
19321 elsif Name
'Length >= 4
19322 and then Name
(1 .. 4) = "decr"
19324 Error_Pragma_Arg_Ident
19325 ("expect name `Decreases`", Variant
);
19328 Error_Pragma_Arg_Ident
19329 ("expect name `Increases` or `Decreases`", Variant
);
19334 Preanalyze_Assert_Expression
19335 (Expression
(Variant
), Any_Discrete
);
19341 -----------------------
19342 -- Machine_Attribute --
19343 -----------------------
19345 -- pragma Machine_Attribute (
19346 -- [Entity =>] LOCAL_NAME,
19347 -- [Attribute_Name =>] static_string_EXPRESSION
19348 -- [, [Info =>] static_EXPRESSION] );
19350 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
19351 Def_Id
: Entity_Id
;
19355 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
19357 if Arg_Count
= 3 then
19358 Check_Optional_Identifier
(Arg3
, Name_Info
);
19359 Check_Arg_Is_OK_Static_Expression
(Arg3
);
19361 Check_Arg_Count
(2);
19364 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19365 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
19366 Check_Arg_Is_Local_Name
(Arg1
);
19367 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
19368 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
19370 if Is_Access_Type
(Def_Id
) then
19371 Def_Id
:= Designated_Type
(Def_Id
);
19374 if Rep_Item_Too_Early
(Def_Id
, N
) then
19378 Def_Id
:= Underlying_Type
(Def_Id
);
19380 -- The only processing required is to link this item on to the
19381 -- list of rep items for the given entity. This is accomplished
19382 -- by the call to Rep_Item_Too_Late (when no error is detected
19383 -- and False is returned).
19385 if Rep_Item_Too_Late
(Def_Id
, N
) then
19388 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
19390 end Machine_Attribute
;
19397 -- (MAIN_OPTION [, MAIN_OPTION]);
19400 -- [STACK_SIZE =>] static_integer_EXPRESSION
19401 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
19402 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
19404 when Pragma_Main
=> Main
: declare
19405 Args
: Args_List
(1 .. 3);
19406 Names
: constant Name_List
(1 .. 3) := (
19408 Name_Task_Stack_Size_Default
,
19409 Name_Time_Slicing_Enabled
);
19415 Gather_Associations
(Names
, Args
);
19417 for J
in 1 .. 2 loop
19418 if Present
(Args
(J
)) then
19419 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19423 if Present
(Args
(3)) then
19424 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
19428 while Present
(Nod
) loop
19429 if Nkind
(Nod
) = N_Pragma
19430 and then Pragma_Name
(Nod
) = Name_Main
19432 Error_Msg_Name_1
:= Pname
;
19433 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19444 -- pragma Main_Storage
19445 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
19447 -- MAIN_STORAGE_OPTION ::=
19448 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
19449 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
19451 when Pragma_Main_Storage
=> Main_Storage
: declare
19452 Args
: Args_List
(1 .. 2);
19453 Names
: constant Name_List
(1 .. 2) := (
19454 Name_Working_Storage
,
19461 Gather_Associations
(Names
, Args
);
19463 for J
in 1 .. 2 loop
19464 if Present
(Args
(J
)) then
19465 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
19469 Check_In_Main_Program
;
19472 while Present
(Nod
) loop
19473 if Nkind
(Nod
) = N_Pragma
19474 and then Pragma_Name
(Nod
) = Name_Main_Storage
19476 Error_Msg_Name_1
:= Pname
;
19477 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
19484 ----------------------
19485 -- Max_Queue_Length --
19486 ----------------------
19488 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
19490 -- This processing is shared by Pragma_Max_Entry_Queue_Depth
19492 when Pragma_Max_Queue_Length
19493 | Pragma_Max_Entry_Queue_Depth
19495 Max_Queue_Length
: declare
19497 Entry_Decl
: Node_Id
;
19498 Entry_Id
: Entity_Id
;
19502 if Prag_Id
= Pragma_Max_Queue_Length
then
19506 Check_Arg_Count
(1);
19509 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
19511 -- Entry declaration
19513 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
19515 -- Entry illegally within a task
19517 if Nkind
(Parent
(N
)) = N_Task_Definition
then
19518 Error_Pragma
("pragma % cannot apply to task entries");
19522 Entry_Id
:= Defining_Entity
(Entry_Decl
);
19524 -- Otherwise the pragma is associated with an illegal construct
19527 Error_Pragma
("pragma % must apply to a protected entry");
19531 -- Mark the pragma as Ghost if the related subprogram is also
19532 -- Ghost. This also ensures that any expansion performed further
19533 -- below will produce Ghost nodes.
19535 Mark_Ghost_Pragma
(N
, Entry_Id
);
19537 -- Analyze the Integer expression
19539 Arg
:= Get_Pragma_Arg
(Arg1
);
19540 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
19542 Val
:= Expr_Value
(Arg
);
19546 ("argument for pragma% must be positive", Arg1
);
19548 elsif not UI_Is_In_Int_Range
(Val
) then
19550 ("argument for pragma% out of range of Integer", Arg1
);
19554 -- Manually substitute the expression value of the pragma argument
19555 -- if it's not an integer literal because this is not taken care
19556 -- of automatically elsewhere.
19558 if Nkind
(Arg
) /= N_Integer_Literal
then
19559 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
19560 Set_Etype
(Arg
, Etype
(Original_Node
(Arg
)));
19563 Record_Rep_Item
(Entry_Id
, N
);
19564 end Max_Queue_Length
;
19570 -- pragma Memory_Size (NUMERIC_LITERAL)
19572 when Pragma_Memory_Size
=>
19575 -- Memory size is simply ignored
19577 Check_No_Identifiers
;
19578 Check_Arg_Count
(1);
19579 Check_Arg_Is_Integer_Literal
(Arg1
);
19587 -- The only correct use of this pragma is on its own in a file, in
19588 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
19589 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
19590 -- check for a file containing nothing but a No_Body pragma). If we
19591 -- attempt to process it during normal semantics processing, it means
19592 -- it was misplaced.
19594 when Pragma_No_Body
=>
19598 -----------------------------
19599 -- No_Elaboration_Code_All --
19600 -----------------------------
19602 -- pragma No_Elaboration_Code_All;
19604 when Pragma_No_Elaboration_Code_All
=>
19606 Check_Valid_Library_Unit_Pragma
;
19608 if Nkind
(N
) = N_Null_Statement
then
19612 -- Must appear for a spec or generic spec
19614 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
19615 N_Generic_Package_Declaration
,
19616 N_Generic_Subprogram_Declaration
,
19617 N_Package_Declaration
,
19618 N_Subprogram_Declaration
)
19622 ("pragma% can only occur for package "
19623 & "or subprogram spec"));
19626 -- Set flag in unit table
19628 Set_No_Elab_Code_All
(Current_Sem_Unit
);
19630 -- Set restriction No_Elaboration_Code if this is the main unit
19632 if Current_Sem_Unit
= Main_Unit
then
19633 Set_Restriction
(No_Elaboration_Code
, N
);
19636 -- If we are in the main unit or in an extended main source unit,
19637 -- then we also add it to the configuration restrictions so that
19638 -- it will apply to all units in the extended main source.
19640 if Current_Sem_Unit
= Main_Unit
19641 or else In_Extended_Main_Source_Unit
(N
)
19643 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
19646 -- If in main extended unit, activate transitive with test
19648 if In_Extended_Main_Source_Unit
(N
) then
19649 Opt
.No_Elab_Code_All_Pragma
:= N
;
19652 -----------------------------
19653 -- No_Component_Reordering --
19654 -----------------------------
19656 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
19658 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
19664 Check_At_Most_N_Arguments
(1);
19666 if Arg_Count
= 0 then
19667 Check_Valid_Configuration_Pragma
;
19668 Opt
.No_Component_Reordering
:= True;
19671 Check_Optional_Identifier
(Arg2
, Name_Entity
);
19672 Check_Arg_Is_Local_Name
(Arg1
);
19673 E_Id
:= Get_Pragma_Arg
(Arg1
);
19675 if Etype
(E_Id
) = Any_Type
then
19679 E
:= Entity
(E_Id
);
19681 if not Is_Record_Type
(E
) then
19682 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
19685 Set_No_Reordering
(Base_Type
(E
));
19687 end No_Comp_Reordering
;
19689 --------------------------
19690 -- No_Heap_Finalization --
19691 --------------------------
19693 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
19695 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
19696 Context
: constant Node_Id
:= Parent
(N
);
19697 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19703 Check_No_Identifiers
;
19705 -- The pragma appears in a configuration file
19707 if No
(Context
) then
19708 Check_Arg_Count
(0);
19709 Check_Valid_Configuration_Pragma
;
19711 -- Detect a duplicate pragma
19713 if Present
(No_Heap_Finalization_Pragma
) then
19716 Prev
=> No_Heap_Finalization_Pragma
);
19720 No_Heap_Finalization_Pragma
:= N
;
19722 -- Otherwise the pragma should be associated with a library-level
19723 -- named access-to-object type.
19726 Check_Arg_Count
(1);
19727 Check_Arg_Is_Local_Name
(Arg1
);
19729 Find_Type
(Typ_Arg
);
19730 Typ
:= Entity
(Typ_Arg
);
19732 -- The type being subjected to the pragma is erroneous
19734 if Typ
= Any_Type
then
19735 Error_Pragma
("cannot find type referenced by pragma %");
19737 -- The pragma is applied to an incomplete or generic formal
19738 -- type way too early.
19740 elsif Rep_Item_Too_Early
(Typ
, N
) then
19744 Typ
:= Underlying_Type
(Typ
);
19747 -- The pragma must apply to an access-to-object type
19749 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
19752 -- Give a detailed error message on all other access type kinds
19754 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
19756 ("pragma % cannot apply to access protected subprogram "
19759 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
19761 ("pragma % cannot apply to access subprogram type");
19763 elsif Is_Anonymous_Access_Type
(Typ
) then
19765 ("pragma % cannot apply to anonymous access type");
19767 -- Give a general error message in case the pragma applies to a
19768 -- non-access type.
19772 ("pragma % must apply to library level access type");
19775 -- At this point the argument denotes an access-to-object type.
19776 -- Ensure that the type is declared at the library level.
19778 if Is_Library_Level_Entity
(Typ
) then
19781 -- Quietly ignore an access-to-object type originally declared
19782 -- at the library level within a generic, but instantiated at
19783 -- a non-library level. As a result the access-to-object type
19784 -- "loses" its No_Heap_Finalization property.
19786 elsif In_Instance
then
19791 ("pragma % must apply to library level access type");
19794 -- Detect a duplicate pragma
19796 if Present
(No_Heap_Finalization_Pragma
) then
19799 Prev
=> No_Heap_Finalization_Pragma
);
19803 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
19805 if Present
(Prev
) then
19813 Record_Rep_Item
(Typ
, N
);
19815 end No_Heap_Finalization
;
19821 -- pragma No_Inline ( NAME {, NAME} );
19823 when Pragma_No_Inline
=>
19825 Process_Inline
(Suppressed
);
19831 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
19833 when Pragma_No_Return
=> No_Return
: declare
19839 Ghost_Error_Posted
: Boolean := False;
19840 -- Flag set when an error concerning the illegal mix of Ghost and
19841 -- non-Ghost subprograms is emitted.
19843 Ghost_Id
: Entity_Id
:= Empty
;
19844 -- The entity of the first Ghost procedure encountered while
19845 -- processing the arguments of the pragma.
19849 Check_At_Least_N_Arguments
(1);
19851 -- Loop through arguments of pragma
19854 while Present
(Arg
) loop
19855 Check_Arg_Is_Local_Name
(Arg
);
19856 Id
:= Get_Pragma_Arg
(Arg
);
19859 if not Is_Entity_Name
(Id
) then
19860 Error_Pragma_Arg
("entity name required", Arg
);
19863 if Etype
(Id
) = Any_Type
then
19867 -- Loop to find matching procedures
19873 and then Scope
(E
) = Current_Scope
19875 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
19877 -- Check that the pragma is not applied to a body.
19878 -- First check the specless body case, to give a
19879 -- different error message. These checks do not apply
19880 -- if Relaxed_RM_Semantics, to accommodate other Ada
19881 -- compilers. Disable these checks under -gnatd.J.
19883 if not Debug_Flag_Dot_JJ
then
19884 if Nkind
(Parent
(Declaration_Node
(E
))) =
19886 and then not Relaxed_RM_Semantics
19889 ("pragma% requires separate spec and must come "
19893 -- Now the "specful" body case
19895 if Rep_Item_Too_Late
(E
, N
) then
19902 -- A pragma that applies to a Ghost entity becomes Ghost
19903 -- for the purposes of legality checks and removal of
19904 -- ignored Ghost code.
19906 Mark_Ghost_Pragma
(N
, E
);
19908 -- Capture the entity of the first Ghost procedure being
19909 -- processed for error detection purposes.
19911 if Is_Ghost_Entity
(E
) then
19912 if No
(Ghost_Id
) then
19916 -- Otherwise the subprogram is non-Ghost. It is illegal
19917 -- to mix references to Ghost and non-Ghost entities
19920 elsif Present
(Ghost_Id
)
19921 and then not Ghost_Error_Posted
19923 Ghost_Error_Posted
:= True;
19925 Error_Msg_Name_1
:= Pname
;
19927 ("pragma % cannot mention ghost and non-ghost "
19928 & "procedures", N
);
19930 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
19931 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
19933 Error_Msg_Sloc
:= Sloc
(E
);
19934 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
19937 -- Set flag on any alias as well
19939 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
19940 Set_No_Return
(Alias
(E
));
19946 exit when From_Aspect_Specification
(N
);
19950 -- If entity in not in current scope it may be the enclosing
19951 -- suprogram body to which the aspect applies.
19954 if Entity
(Id
) = Current_Scope
19955 and then From_Aspect_Specification
(N
)
19957 Set_No_Return
(Entity
(Id
));
19959 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
19971 -- pragma No_Run_Time;
19973 -- Note: this pragma is retained for backwards compatibility. See
19974 -- body of Rtsfind for full details on its handling.
19976 when Pragma_No_Run_Time
=>
19978 Check_Valid_Configuration_Pragma
;
19979 Check_Arg_Count
(0);
19981 -- Remove backward compatibility if Build_Type is FSF or GPL and
19982 -- generate a warning.
19985 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
19988 Error_Pragma
("pragma% is ignored, has no effect??");
19990 No_Run_Time_Mode
:= True;
19991 Configurable_Run_Time_Mode
:= True;
19993 -- Set Duration to 32 bits if word size is 32
19995 if Ttypes
.System_Word_Size
= 32 then
19996 Duration_32_Bits_On_Target
:= True;
19999 -- Set appropriate restrictions
20001 Set_Restriction
(No_Finalization
, N
);
20002 Set_Restriction
(No_Exception_Handlers
, N
);
20003 Set_Restriction
(Max_Tasks
, N
, 0);
20004 Set_Restriction
(No_Tasking
, N
);
20008 -----------------------
20009 -- No_Tagged_Streams --
20010 -----------------------
20012 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
20014 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
20020 Check_At_Most_N_Arguments
(1);
20022 -- One argument case
20024 if Arg_Count
= 1 then
20025 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20026 Check_Arg_Is_Local_Name
(Arg1
);
20027 E_Id
:= Get_Pragma_Arg
(Arg1
);
20029 if Etype
(E_Id
) = Any_Type
then
20033 E
:= Entity
(E_Id
);
20035 Check_Duplicate_Pragma
(E
);
20037 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
20039 ("argument for pragma% must be root tagged type", Arg1
);
20042 if Rep_Item_Too_Early
(E
, N
)
20044 Rep_Item_Too_Late
(E
, N
)
20048 Set_No_Tagged_Streams_Pragma
(E
, N
);
20051 -- Zero argument case
20054 Check_Is_In_Decl_Part_Or_Package_Spec
;
20055 No_Tagged_Streams
:= N
;
20057 end No_Tagged_Strms
;
20059 ------------------------
20060 -- No_Strict_Aliasing --
20061 ------------------------
20063 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
20065 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
20071 Check_At_Most_N_Arguments
(1);
20073 if Arg_Count
= 0 then
20074 Check_Valid_Configuration_Pragma
;
20075 Opt
.No_Strict_Aliasing
:= True;
20078 Check_Optional_Identifier
(Arg2
, Name_Entity
);
20079 Check_Arg_Is_Local_Name
(Arg1
);
20080 E_Id
:= Get_Pragma_Arg
(Arg1
);
20082 if Etype
(E_Id
) = Any_Type
then
20086 E
:= Entity
(E_Id
);
20088 if not Is_Access_Type
(E
) then
20089 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
20092 Set_No_Strict_Aliasing
(Base_Type
(E
));
20094 end No_Strict_Aliasing
;
20096 -----------------------
20097 -- Normalize_Scalars --
20098 -----------------------
20100 -- pragma Normalize_Scalars;
20102 when Pragma_Normalize_Scalars
=>
20103 Check_Ada_83_Warning
;
20104 Check_Arg_Count
(0);
20105 Check_Valid_Configuration_Pragma
;
20107 -- Normalize_Scalars creates false positives in CodePeer, and
20108 -- incorrect negative results in GNATprove mode, so ignore this
20109 -- pragma in these modes.
20111 if not (CodePeer_Mode
or GNATprove_Mode
) then
20112 Normalize_Scalars
:= True;
20113 Init_Or_Norm_Scalars
:= True;
20120 -- pragma Obsolescent;
20122 -- pragma Obsolescent (
20123 -- [Message =>] static_string_EXPRESSION
20124 -- [,[Version =>] Ada_05]]);
20126 -- pragma Obsolescent (
20127 -- [Entity =>] NAME
20128 -- [,[Message =>] static_string_EXPRESSION
20129 -- [,[Version =>] Ada_05]] );
20131 when Pragma_Obsolescent
=> Obsolescent
: declare
20135 procedure Set_Obsolescent
(E
: Entity_Id
);
20136 -- Given an entity Ent, mark it as obsolescent if appropriate
20138 ---------------------
20139 -- Set_Obsolescent --
20140 ---------------------
20142 procedure Set_Obsolescent
(E
: Entity_Id
) is
20151 -- A pragma that applies to a Ghost entity becomes Ghost for
20152 -- the purposes of legality checks and removal of ignored Ghost
20155 Mark_Ghost_Pragma
(N
, E
);
20157 -- Entity name was given
20159 if Present
(Ename
) then
20161 -- If entity name matches, we are fine. Save entity in
20162 -- pragma argument, for ASIS use.
20164 if Chars
(Ename
) = Chars
(Ent
) then
20165 Set_Entity
(Ename
, Ent
);
20166 Generate_Reference
(Ent
, Ename
);
20168 -- If entity name does not match, only possibility is an
20169 -- enumeration literal from an enumeration type declaration.
20171 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
20173 ("pragma % entity name does not match declaration");
20176 Ent
:= First_Literal
(E
);
20180 ("pragma % entity name does not match any "
20181 & "enumeration literal");
20183 elsif Chars
(Ent
) = Chars
(Ename
) then
20184 Set_Entity
(Ename
, Ent
);
20185 Generate_Reference
(Ent
, Ename
);
20189 Ent
:= Next_Literal
(Ent
);
20195 -- Ent points to entity to be marked
20197 if Arg_Count
>= 1 then
20199 -- Deal with static string argument
20201 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
20202 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
20204 for J
in 1 .. String_Length
(S
) loop
20205 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
20207 ("pragma% argument does not allow wide characters",
20212 Obsolescent_Warnings
.Append
20213 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
20215 -- Check for Ada_05 parameter
20217 if Arg_Count
/= 1 then
20218 Check_Arg_Count
(2);
20221 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
20224 Check_Arg_Is_Identifier
(Argx
);
20226 if Chars
(Argx
) /= Name_Ada_05
then
20227 Error_Msg_Name_2
:= Name_Ada_05
;
20229 ("only allowed argument for pragma% is %", Argx
);
20232 if Ada_Version_Explicit
< Ada_2005
20233 or else not Warn_On_Ada_2005_Compatibility
20241 -- Set flag if pragma active
20244 Set_Is_Obsolescent
(Ent
);
20248 end Set_Obsolescent
;
20250 -- Start of processing for pragma Obsolescent
20255 Check_At_Most_N_Arguments
(3);
20257 -- See if first argument specifies an entity name
20261 (Chars
(Arg1
) = Name_Entity
20263 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
20265 N_Operator_Symbol
))
20267 Ename
:= Get_Pragma_Arg
(Arg1
);
20269 -- Eliminate first argument, so we can share processing
20273 Arg_Count
:= Arg_Count
- 1;
20275 -- No Entity name argument given
20281 if Arg_Count
>= 1 then
20282 Check_Optional_Identifier
(Arg1
, Name_Message
);
20284 if Arg_Count
= 2 then
20285 Check_Optional_Identifier
(Arg2
, Name_Version
);
20289 -- Get immediately preceding declaration
20292 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
20296 -- Cases where we do not follow anything other than another pragma
20300 -- First case: library level compilation unit declaration with
20301 -- the pragma immediately following the declaration.
20303 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
20305 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
20308 -- Case 2: library unit placement for package
20312 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
20314 if Is_Package_Or_Generic_Package
(Ent
) then
20315 Set_Obsolescent
(Ent
);
20321 -- Cases where we must follow a declaration, including an
20322 -- abstract subprogram declaration, which is not in the
20323 -- other node subtypes.
20326 if Nkind
(Decl
) not in N_Declaration
20327 and then Nkind
(Decl
) not in N_Later_Decl_Item
20328 and then Nkind
(Decl
) not in N_Generic_Declaration
20329 and then Nkind
(Decl
) not in N_Renaming_Declaration
20330 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
20333 ("pragma% misplaced, "
20334 & "must immediately follow a declaration");
20337 Set_Obsolescent
(Defining_Entity
(Decl
));
20347 -- pragma Optimize (Time | Space | Off);
20349 -- The actual check for optimize is done in Gigi. Note that this
20350 -- pragma does not actually change the optimization setting, it
20351 -- simply checks that it is consistent with the pragma.
20353 when Pragma_Optimize
=>
20354 Check_No_Identifiers
;
20355 Check_Arg_Count
(1);
20356 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
20358 ------------------------
20359 -- Optimize_Alignment --
20360 ------------------------
20362 -- pragma Optimize_Alignment (Time | Space | Off);
20364 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
20366 Check_No_Identifiers
;
20367 Check_Arg_Count
(1);
20368 Check_Valid_Configuration_Pragma
;
20371 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
20374 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
20375 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
20376 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
20379 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
20383 -- Set indication that mode is set locally. If we are in fact in a
20384 -- configuration pragma file, this setting is harmless since the
20385 -- switch will get reset anyway at the start of each unit.
20387 Optimize_Alignment_Local
:= True;
20388 end Optimize_Alignment
;
20394 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
20396 when Pragma_Ordered
=> Ordered
: declare
20397 Assoc
: constant Node_Id
:= Arg1
;
20403 Check_No_Identifiers
;
20404 Check_Arg_Count
(1);
20405 Check_Arg_Is_Local_Name
(Arg1
);
20407 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20408 Find_Type
(Type_Id
);
20409 Typ
:= Entity
(Type_Id
);
20411 if Typ
= Any_Type
then
20414 Typ
:= Underlying_Type
(Typ
);
20417 if not Is_Enumeration_Type
(Typ
) then
20418 Error_Pragma
("pragma% must specify enumeration type");
20421 Check_First_Subtype
(Arg1
);
20422 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
20425 -------------------
20426 -- Overflow_Mode --
20427 -------------------
20429 -- pragma Overflow_Mode
20430 -- ([General => ] MODE [, [Assertions => ] MODE]);
20432 -- MODE := STRICT | MINIMIZED | ELIMINATED
20434 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
20435 -- since System.Bignums makes this assumption. This is true of nearly
20436 -- all (all?) targets.
20438 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
20439 function Get_Overflow_Mode
20441 Arg
: Node_Id
) return Overflow_Mode_Type
;
20442 -- Function to process one pragma argument, Arg. If an identifier
20443 -- is present, it must be Name. Mode type is returned if a valid
20444 -- argument exists, otherwise an error is signalled.
20446 -----------------------
20447 -- Get_Overflow_Mode --
20448 -----------------------
20450 function Get_Overflow_Mode
20452 Arg
: Node_Id
) return Overflow_Mode_Type
20454 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
20457 Check_Optional_Identifier
(Arg
, Name
);
20458 Check_Arg_Is_Identifier
(Argx
);
20460 if Chars
(Argx
) = Name_Strict
then
20463 elsif Chars
(Argx
) = Name_Minimized
then
20466 elsif Chars
(Argx
) = Name_Eliminated
then
20467 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
20469 ("Eliminated not implemented on this target", Argx
);
20475 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
20477 end Get_Overflow_Mode
;
20479 -- Start of processing for Overflow_Mode
20483 Check_At_Least_N_Arguments
(1);
20484 Check_At_Most_N_Arguments
(2);
20486 -- Process first argument
20488 Scope_Suppress
.Overflow_Mode_General
:=
20489 Get_Overflow_Mode
(Name_General
, Arg1
);
20491 -- Case of only one argument
20493 if Arg_Count
= 1 then
20494 Scope_Suppress
.Overflow_Mode_Assertions
:=
20495 Scope_Suppress
.Overflow_Mode_General
;
20497 -- Case of two arguments present
20500 Scope_Suppress
.Overflow_Mode_Assertions
:=
20501 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
20505 --------------------------
20506 -- Overriding Renamings --
20507 --------------------------
20509 -- pragma Overriding_Renamings;
20511 when Pragma_Overriding_Renamings
=>
20513 Check_Arg_Count
(0);
20514 Check_Valid_Configuration_Pragma
;
20515 Overriding_Renamings
:= True;
20521 -- pragma Pack (first_subtype_LOCAL_NAME);
20523 when Pragma_Pack
=> Pack
: declare
20524 Assoc
: constant Node_Id
:= Arg1
;
20526 Ignore
: Boolean := False;
20531 Check_No_Identifiers
;
20532 Check_Arg_Count
(1);
20533 Check_Arg_Is_Local_Name
(Arg1
);
20534 Type_Id
:= Get_Pragma_Arg
(Assoc
);
20536 if not Is_Entity_Name
(Type_Id
)
20537 or else not Is_Type
(Entity
(Type_Id
))
20540 ("argument for pragma% must be type or subtype", Arg1
);
20543 Find_Type
(Type_Id
);
20544 Typ
:= Entity
(Type_Id
);
20547 or else Rep_Item_Too_Early
(Typ
, N
)
20551 Typ
:= Underlying_Type
(Typ
);
20554 -- A pragma that applies to a Ghost entity becomes Ghost for the
20555 -- purposes of legality checks and removal of ignored Ghost code.
20557 Mark_Ghost_Pragma
(N
, Typ
);
20559 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
20560 Error_Pragma
("pragma% must specify array or record type");
20563 Check_First_Subtype
(Arg1
);
20564 Check_Duplicate_Pragma
(Typ
);
20568 if Is_Array_Type
(Typ
) then
20569 Ctyp
:= Component_Type
(Typ
);
20571 -- Ignore pack that does nothing
20573 if Known_Static_Esize
(Ctyp
)
20574 and then Known_Static_RM_Size
(Ctyp
)
20575 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
20576 and then Addressable
(Esize
(Ctyp
))
20581 -- Process OK pragma Pack. Note that if there is a separate
20582 -- component clause present, the Pack will be cancelled. This
20583 -- processing is in Freeze.
20585 if not Rep_Item_Too_Late
(Typ
, N
) then
20587 -- In CodePeer mode, we do not need complex front-end
20588 -- expansions related to pragma Pack, so disable handling
20591 if CodePeer_Mode
then
20594 -- Normal case where we do the pack action
20598 Set_Is_Packed
(Base_Type
(Typ
));
20599 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20602 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20606 -- For record types, the pack is always effective
20608 else pragma Assert
(Is_Record_Type
(Typ
));
20609 if not Rep_Item_Too_Late
(Typ
, N
) then
20610 Set_Is_Packed
(Base_Type
(Typ
));
20611 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
20612 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
20623 -- There is nothing to do here, since we did all the processing for
20624 -- this pragma in Par.Prag (so that it works properly even in syntax
20627 when Pragma_Page
=>
20634 -- pragma Part_Of (ABSTRACT_STATE);
20636 -- ABSTRACT_STATE ::= NAME
20638 when Pragma_Part_Of
=> Part_Of
: declare
20639 procedure Propagate_Part_Of
20640 (Pack_Id
: Entity_Id
;
20641 State_Id
: Entity_Id
;
20642 Instance
: Node_Id
);
20643 -- Propagate the Part_Of indicator to all abstract states and
20644 -- objects declared in the visible state space of a package
20645 -- denoted by Pack_Id. State_Id is the encapsulating state.
20646 -- Instance is the package instantiation node.
20648 -----------------------
20649 -- Propagate_Part_Of --
20650 -----------------------
20652 procedure Propagate_Part_Of
20653 (Pack_Id
: Entity_Id
;
20654 State_Id
: Entity_Id
;
20655 Instance
: Node_Id
)
20657 Has_Item
: Boolean := False;
20658 -- Flag set when the visible state space contains at least one
20659 -- abstract state or variable.
20661 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
20662 -- Propagate the Part_Of indicator to all abstract states and
20663 -- objects declared in the visible state space of a package
20664 -- denoted by Pack_Id.
20666 -----------------------
20667 -- Propagate_Part_Of --
20668 -----------------------
20670 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
20671 Constits
: Elist_Id
;
20672 Item_Id
: Entity_Id
;
20675 -- Traverse the entity chain of the package and set relevant
20676 -- attributes of abstract states and objects declared in the
20677 -- visible state space of the package.
20679 Item_Id
:= First_Entity
(Pack_Id
);
20680 while Present
(Item_Id
)
20681 and then not In_Private_Part
(Item_Id
)
20683 -- Do not consider internally generated items
20685 if not Comes_From_Source
(Item_Id
) then
20688 -- Do not consider generic formals or their corresponding
20689 -- actuals because they are not part of a visible state.
20690 -- Note that both entities are marked as hidden.
20692 elsif Is_Hidden
(Item_Id
) then
20695 -- The Part_Of indicator turns an abstract state or an
20696 -- object into a constituent of the encapsulating state.
20697 -- Note that constants are considered here even though
20698 -- they may not depend on variable input. This check is
20699 -- left to the SPARK prover.
20701 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
20706 Constits
:= Part_Of_Constituents
(State_Id
);
20708 if No
(Constits
) then
20709 Constits
:= New_Elmt_List
;
20710 Set_Part_Of_Constituents
(State_Id
, Constits
);
20713 Append_Elmt
(Item_Id
, Constits
);
20714 Set_Encapsulating_State
(Item_Id
, State_Id
);
20716 -- Recursively handle nested packages and instantiations
20718 elsif Ekind
(Item_Id
) = E_Package
then
20719 Propagate_Part_Of
(Item_Id
);
20722 Next_Entity
(Item_Id
);
20724 end Propagate_Part_Of
;
20726 -- Start of processing for Propagate_Part_Of
20729 Propagate_Part_Of
(Pack_Id
);
20731 -- Detect a package instantiation that is subject to a Part_Of
20732 -- indicator, but has no visible state.
20734 if not Has_Item
then
20736 ("package instantiation & has Part_Of indicator but "
20737 & "lacks visible state", Instance
, Pack_Id
);
20739 end Propagate_Part_Of
;
20743 Constits
: Elist_Id
;
20745 Encap_Id
: Entity_Id
;
20746 Item_Id
: Entity_Id
;
20750 -- Start of processing for Part_Of
20754 Check_No_Identifiers
;
20755 Check_Arg_Count
(1);
20757 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
20759 -- Object declaration
20761 if Nkind
(Stmt
) = N_Object_Declaration
then
20764 -- Package instantiation
20766 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
20769 -- Single concurrent type declaration
20771 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
20774 -- Otherwise the pragma is associated with an illegal construct
20781 -- Extract the entity of the related object declaration or package
20782 -- instantiation. In the case of the instantiation, use the entity
20783 -- of the instance spec.
20785 if Nkind
(Stmt
) = N_Package_Instantiation
then
20786 Stmt
:= Instance_Spec
(Stmt
);
20789 Item_Id
:= Defining_Entity
(Stmt
);
20791 -- A pragma that applies to a Ghost entity becomes Ghost for the
20792 -- purposes of legality checks and removal of ignored Ghost code.
20794 Mark_Ghost_Pragma
(N
, Item_Id
);
20796 -- Chain the pragma on the contract for further processing by
20797 -- Analyze_Part_Of_In_Decl_Part or for completeness.
20799 Add_Contract_Item
(N
, Item_Id
);
20801 -- A variable may act as constituent of a single concurrent type
20802 -- which in turn could be declared after the variable. Due to this
20803 -- discrepancy, the full analysis of indicator Part_Of is delayed
20804 -- until the end of the enclosing declarative region (see routine
20805 -- Analyze_Part_Of_In_Decl_Part).
20807 if Ekind
(Item_Id
) = E_Variable
then
20810 -- Otherwise indicator Part_Of applies to a constant or a package
20814 Encap
:= Get_Pragma_Arg
(Arg1
);
20816 -- Detect any discrepancies between the placement of the
20817 -- constant or package instantiation with respect to state
20818 -- space and the encapsulating state.
20822 Item_Id
=> Item_Id
,
20824 Encap_Id
=> Encap_Id
,
20828 pragma Assert
(Present
(Encap_Id
));
20830 if Ekind
(Item_Id
) = E_Constant
then
20831 Constits
:= Part_Of_Constituents
(Encap_Id
);
20833 if No
(Constits
) then
20834 Constits
:= New_Elmt_List
;
20835 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
20838 Append_Elmt
(Item_Id
, Constits
);
20839 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
20841 -- Propagate the Part_Of indicator to the visible state
20842 -- space of the package instantiation.
20846 (Pack_Id
=> Item_Id
,
20847 State_Id
=> Encap_Id
,
20854 ----------------------------------
20855 -- Partition_Elaboration_Policy --
20856 ----------------------------------
20858 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
20860 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
20861 subtype PEP_Range
is Name_Id
20862 range First_Partition_Elaboration_Policy_Name
20863 .. Last_Partition_Elaboration_Policy_Name
;
20864 PEP_Val
: PEP_Range
;
20869 Check_Arg_Count
(1);
20870 Check_No_Identifiers
;
20871 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
20872 Check_Valid_Configuration_Pragma
;
20873 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
20876 when Name_Concurrent
=> PEP
:= 'C';
20877 when Name_Sequential
=> PEP
:= 'S';
20880 if Partition_Elaboration_Policy
/= ' '
20881 and then Partition_Elaboration_Policy
/= PEP
20883 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
20885 ("partition elaboration policy incompatible with policy#");
20887 -- Set new policy, but always preserve System_Location since we
20888 -- like the error message with the run time name.
20891 Partition_Elaboration_Policy
:= PEP
;
20893 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
20894 Partition_Elaboration_Policy_Sloc
:= Loc
;
20903 -- pragma Passive [(PASSIVE_FORM)];
20905 -- PASSIVE_FORM ::= Semaphore | No
20907 when Pragma_Passive
=>
20910 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
20911 Error_Pragma
("pragma% must be within task definition");
20914 if Arg_Count
/= 0 then
20915 Check_Arg_Count
(1);
20916 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
20919 ----------------------------------
20920 -- Preelaborable_Initialization --
20921 ----------------------------------
20923 -- pragma Preelaborable_Initialization (DIRECT_NAME);
20925 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
20930 Check_Arg_Count
(1);
20931 Check_No_Identifiers
;
20932 Check_Arg_Is_Identifier
(Arg1
);
20933 Check_Arg_Is_Local_Name
(Arg1
);
20934 Check_First_Subtype
(Arg1
);
20935 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
20937 -- A pragma that applies to a Ghost entity becomes Ghost for the
20938 -- purposes of legality checks and removal of ignored Ghost code.
20940 Mark_Ghost_Pragma
(N
, Ent
);
20942 -- The pragma may come from an aspect on a private declaration,
20943 -- even if the freeze point at which this is analyzed in the
20944 -- private part after the full view.
20946 if Has_Private_Declaration
(Ent
)
20947 and then From_Aspect_Specification
(N
)
20951 -- Check appropriate type argument
20953 elsif Is_Private_Type
(Ent
)
20954 or else Is_Protected_Type
(Ent
)
20955 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
20957 -- AI05-0028: The pragma applies to all composite types. Note
20958 -- that we apply this binding interpretation to earlier versions
20959 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
20960 -- choice since there are other compilers that do the same.
20962 or else Is_Composite_Type
(Ent
)
20968 ("pragma % can only be applied to private, formal derived, "
20969 & "protected, or composite type", Arg1
);
20972 -- Give an error if the pragma is applied to a protected type that
20973 -- does not qualify (due to having entries, or due to components
20974 -- that do not qualify).
20976 if Is_Protected_Type
(Ent
)
20977 and then not Has_Preelaborable_Initialization
(Ent
)
20980 ("protected type & does not have preelaborable "
20981 & "initialization", Ent
);
20983 -- Otherwise mark the type as definitely having preelaborable
20987 Set_Known_To_Have_Preelab_Init
(Ent
);
20990 if Has_Pragma_Preelab_Init
(Ent
)
20991 and then Warn_On_Redundant_Constructs
20993 Error_Pragma
("?r?duplicate pragma%!");
20995 Set_Has_Pragma_Preelab_Init
(Ent
);
20999 --------------------
21000 -- Persistent_BSS --
21001 --------------------
21003 -- pragma Persistent_BSS [(object_NAME)];
21005 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
21012 Check_At_Most_N_Arguments
(1);
21014 -- Case of application to specific object (one argument)
21016 if Arg_Count
= 1 then
21017 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21019 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
21021 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
21024 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
21027 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
21029 -- A pragma that applies to a Ghost entity becomes Ghost for
21030 -- the purposes of legality checks and removal of ignored Ghost
21033 Mark_Ghost_Pragma
(N
, Ent
);
21035 -- Check for duplication before inserting in list of
21036 -- representation items.
21038 Check_Duplicate_Pragma
(Ent
);
21040 if Rep_Item_Too_Late
(Ent
, N
) then
21044 Decl
:= Parent
(Ent
);
21046 if Present
(Expression
(Decl
)) then
21048 ("object for pragma% cannot have initialization", Arg1
);
21051 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
21053 ("object type for pragma% is not potentially persistent",
21058 Make_Linker_Section_Pragma
21059 (Ent
, Sloc
(N
), ".persistent.bss");
21060 Insert_After
(N
, Prag
);
21063 -- Case of use as configuration pragma with no arguments
21066 Check_Valid_Configuration_Pragma
;
21067 Persistent_BSS_Mode
:= True;
21069 end Persistent_BSS
;
21071 --------------------
21072 -- Rename_Pragma --
21073 --------------------
21075 -- pragma Rename_Pragma (
21076 -- [New_Name =>] IDENTIFIER,
21077 -- [Renamed =>] pragma_IDENTIFIER);
21079 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
21080 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21081 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
21085 Check_Valid_Configuration_Pragma
;
21086 Check_Arg_Count
(2);
21087 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
21088 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
21090 if Nkind
(New_Name
) /= N_Identifier
then
21091 Error_Pragma_Arg
("identifier expected", Arg1
);
21094 if Nkind
(Old_Name
) /= N_Identifier
then
21095 Error_Pragma_Arg
("identifier expected", Arg2
);
21098 -- The New_Name arg should not be an existing pragma (but we allow
21099 -- it; it's just a warning). The Old_Name arg must be an existing
21102 if Is_Pragma_Name
(Chars
(New_Name
)) then
21103 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
21106 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
21107 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
21110 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
21117 -- pragma Polling (ON | OFF);
21119 when Pragma_Polling
=>
21121 Check_Arg_Count
(1);
21122 Check_No_Identifiers
;
21123 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21124 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
21126 -----------------------------------
21127 -- Post/Post_Class/Postcondition --
21128 -----------------------------------
21130 -- pragma Post (Boolean_EXPRESSION);
21131 -- pragma Post_Class (Boolean_EXPRESSION);
21132 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
21133 -- [,[Message =>] String_EXPRESSION]);
21135 -- Characteristics:
21137 -- * Analysis - The annotation undergoes initial checks to verify
21138 -- the legal placement and context. Secondary checks preanalyze the
21141 -- Analyze_Pre_Post_Condition_In_Decl_Part
21143 -- * Expansion - The annotation is expanded during the expansion of
21144 -- the related subprogram [body] contract as performed in:
21146 -- Expand_Subprogram_Contract
21148 -- * Template - The annotation utilizes the generic template of the
21149 -- related subprogram [body] when it is:
21151 -- aspect on subprogram declaration
21152 -- aspect on stand-alone subprogram body
21153 -- pragma on stand-alone subprogram body
21155 -- The annotation must prepare its own template when it is:
21157 -- pragma on subprogram declaration
21159 -- * Globals - Capture of global references must occur after full
21162 -- * Instance - The annotation is instantiated automatically when
21163 -- the related generic subprogram [body] is instantiated except for
21164 -- the "pragma on subprogram declaration" case. In that scenario
21165 -- the annotation must instantiate itself.
21168 | Pragma_Post_Class
21169 | Pragma_Postcondition
21171 Analyze_Pre_Post_Condition
;
21173 --------------------------------
21174 -- Pre/Pre_Class/Precondition --
21175 --------------------------------
21177 -- pragma Pre (Boolean_EXPRESSION);
21178 -- pragma Pre_Class (Boolean_EXPRESSION);
21179 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
21180 -- [,[Message =>] String_EXPRESSION]);
21182 -- Characteristics:
21184 -- * Analysis - The annotation undergoes initial checks to verify
21185 -- the legal placement and context. Secondary checks preanalyze the
21188 -- Analyze_Pre_Post_Condition_In_Decl_Part
21190 -- * Expansion - The annotation is expanded during the expansion of
21191 -- the related subprogram [body] contract as performed in:
21193 -- Expand_Subprogram_Contract
21195 -- * Template - The annotation utilizes the generic template of the
21196 -- related subprogram [body] when it is:
21198 -- aspect on subprogram declaration
21199 -- aspect on stand-alone subprogram body
21200 -- pragma on stand-alone subprogram body
21202 -- The annotation must prepare its own template when it is:
21204 -- pragma on subprogram declaration
21206 -- * Globals - Capture of global references must occur after full
21209 -- * Instance - The annotation is instantiated automatically when
21210 -- the related generic subprogram [body] is instantiated except for
21211 -- the "pragma on subprogram declaration" case. In that scenario
21212 -- the annotation must instantiate itself.
21216 | Pragma_Precondition
21218 Analyze_Pre_Post_Condition
;
21224 -- pragma Predicate
21225 -- ([Entity =>] type_LOCAL_NAME,
21226 -- [Check =>] boolean_EXPRESSION);
21228 when Pragma_Predicate
=> Predicate
: declare
21235 Check_Arg_Count
(2);
21236 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21237 Check_Optional_Identifier
(Arg2
, Name_Check
);
21239 Check_Arg_Is_Local_Name
(Arg1
);
21241 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21242 Find_Type
(Type_Id
);
21243 Typ
:= Entity
(Type_Id
);
21245 if Typ
= Any_Type
then
21249 -- A pragma that applies to a Ghost entity becomes Ghost for the
21250 -- purposes of legality checks and removal of ignored Ghost code.
21252 Mark_Ghost_Pragma
(N
, Typ
);
21254 -- The remaining processing is simply to link the pragma on to
21255 -- the rep item chain, for processing when the type is frozen.
21256 -- This is accomplished by a call to Rep_Item_Too_Late. We also
21257 -- mark the type as having predicates.
21259 -- If the current policy for predicate checking is Ignore mark the
21260 -- subtype accordingly. In the case of predicates we consider them
21261 -- enabled unless Ignore is specified (either directly or with a
21262 -- general Assertion_Policy pragma) to preserve existing warnings.
21264 Set_Has_Predicates
(Typ
);
21266 -- Indicate that the pragma must be processed at the point the
21267 -- type is frozen, as is done for the corresponding aspect.
21269 Set_Has_Delayed_Aspects
(Typ
);
21270 Set_Has_Delayed_Freeze
(Typ
);
21272 Set_Predicates_Ignored
(Typ
,
21273 Present
(Check_Policy_List
)
21275 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
21276 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21279 -----------------------
21280 -- Predicate_Failure --
21281 -----------------------
21283 -- pragma Predicate_Failure
21284 -- ([Entity =>] type_LOCAL_NAME,
21285 -- [Message =>] string_EXPRESSION);
21287 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
21294 Check_Arg_Count
(2);
21295 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21296 Check_Optional_Identifier
(Arg2
, Name_Message
);
21298 Check_Arg_Is_Local_Name
(Arg1
);
21300 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21301 Find_Type
(Type_Id
);
21302 Typ
:= Entity
(Type_Id
);
21304 if Typ
= Any_Type
then
21308 -- A pragma that applies to a Ghost entity becomes Ghost for the
21309 -- purposes of legality checks and removal of ignored Ghost code.
21311 Mark_Ghost_Pragma
(N
, Typ
);
21313 -- The remaining processing is simply to link the pragma on to
21314 -- the rep item chain, for processing when the type is frozen.
21315 -- This is accomplished by a call to Rep_Item_Too_Late.
21317 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
21318 end Predicate_Failure
;
21324 -- pragma Preelaborate [(library_unit_NAME)];
21326 -- Set the flag Is_Preelaborated of program unit name entity
21328 when Pragma_Preelaborate
=> Preelaborate
: declare
21329 Pa
: constant Node_Id
:= Parent
(N
);
21330 Pk
: constant Node_Kind
:= Nkind
(Pa
);
21334 Check_Ada_83_Warning
;
21335 Check_Valid_Library_Unit_Pragma
;
21337 if Nkind
(N
) = N_Null_Statement
then
21341 Ent
:= Find_Lib_Unit_Name
;
21343 -- A pragma that applies to a Ghost entity becomes Ghost for the
21344 -- purposes of legality checks and removal of ignored Ghost code.
21346 Mark_Ghost_Pragma
(N
, Ent
);
21347 Check_Duplicate_Pragma
(Ent
);
21349 -- This filters out pragmas inside generic parents that show up
21350 -- inside instantiations. Pragmas that come from aspects in the
21351 -- unit are not ignored.
21353 if Present
(Ent
) then
21354 if Pk
= N_Package_Specification
21355 and then Present
(Generic_Parent
(Pa
))
21356 and then not From_Aspect_Specification
(N
)
21361 if not Debug_Flag_U
then
21362 Set_Is_Preelaborated
(Ent
);
21364 if Legacy_Elaboration_Checks
then
21365 Set_Suppress_Elaboration_Warnings
(Ent
);
21372 -------------------------------
21373 -- Prefix_Exception_Messages --
21374 -------------------------------
21376 -- pragma Prefix_Exception_Messages;
21378 when Pragma_Prefix_Exception_Messages
=>
21380 Check_Valid_Configuration_Pragma
;
21381 Check_Arg_Count
(0);
21382 Prefix_Exception_Messages
:= True;
21388 -- pragma Priority (EXPRESSION);
21390 when Pragma_Priority
=> Priority
: declare
21391 P
: constant Node_Id
:= Parent
(N
);
21396 Check_No_Identifiers
;
21397 Check_Arg_Count
(1);
21401 if Nkind
(P
) = N_Subprogram_Body
then
21402 Check_In_Main_Program
;
21404 Ent
:= Defining_Unit_Name
(Specification
(P
));
21406 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
21407 Ent
:= Defining_Identifier
(Ent
);
21410 Arg
:= Get_Pragma_Arg
(Arg1
);
21411 Analyze_And_Resolve
(Arg
, Standard_Integer
);
21415 if not Is_OK_Static_Expression
(Arg
) then
21416 Flag_Non_Static_Expr
21417 ("main subprogram priority is not static!", Arg
);
21420 -- If constraint error, then we already signalled an error
21422 elsif Raises_Constraint_Error
(Arg
) then
21425 -- Otherwise check in range except if Relaxed_RM_Semantics
21426 -- where we ignore the value if out of range.
21429 if not Relaxed_RM_Semantics
21430 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
21433 ("main subprogram priority is out of range", Arg1
);
21436 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
21440 -- Load an arbitrary entity from System.Tasking.Stages or
21441 -- System.Tasking.Restricted.Stages (depending on the
21442 -- supported profile) to make sure that one of these packages
21443 -- is implicitly with'ed, since we need to have the tasking
21444 -- run time active for the pragma Priority to have any effect.
21445 -- Previously we with'ed the package System.Tasking, but this
21446 -- package does not trigger the required initialization of the
21447 -- run-time library.
21450 Discard
: Entity_Id
;
21451 pragma Warnings
(Off
, Discard
);
21453 if Restricted_Profile
then
21454 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
21456 Discard
:= RTE
(RE_Activate_Tasks
);
21460 -- Task or Protected, must be of type Integer
21462 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
21463 Arg
:= Get_Pragma_Arg
(Arg1
);
21464 Ent
:= Defining_Identifier
(Parent
(P
));
21466 -- The expression must be analyzed in the special manner
21467 -- described in "Handling of Default and Per-Object
21468 -- Expressions" in sem.ads.
21470 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
21472 if not Is_OK_Static_Expression
(Arg
) then
21473 Check_Restriction
(Static_Priorities
, Arg
);
21476 -- Anything else is incorrect
21482 -- Check duplicate pragma before we chain the pragma in the Rep
21483 -- Item chain of Ent.
21485 Check_Duplicate_Pragma
(Ent
);
21486 Record_Rep_Item
(Ent
, N
);
21489 -----------------------------------
21490 -- Priority_Specific_Dispatching --
21491 -----------------------------------
21493 -- pragma Priority_Specific_Dispatching (
21494 -- policy_IDENTIFIER,
21495 -- first_priority_EXPRESSION,
21496 -- last_priority_EXPRESSION);
21498 when Pragma_Priority_Specific_Dispatching
=>
21499 Priority_Specific_Dispatching
: declare
21500 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
21501 -- This is the entity System.Any_Priority;
21504 Lower_Bound
: Node_Id
;
21505 Upper_Bound
: Node_Id
;
21511 Check_Arg_Count
(3);
21512 Check_No_Identifiers
;
21513 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21514 Check_Valid_Configuration_Pragma
;
21515 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21516 DP
:= Fold_Upper
(Name_Buffer
(1));
21518 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
21519 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
21520 Lower_Val
:= Expr_Value
(Lower_Bound
);
21522 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
21523 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
21524 Upper_Val
:= Expr_Value
(Upper_Bound
);
21526 -- It is not allowed to use Task_Dispatching_Policy and
21527 -- Priority_Specific_Dispatching in the same partition.
21529 if Task_Dispatching_Policy
/= ' ' then
21530 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21532 ("pragma% incompatible with Task_Dispatching_Policy#");
21534 -- Check lower bound in range
21536 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21538 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21541 ("first_priority is out of range", Arg2
);
21543 -- Check upper bound in range
21545 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
21547 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
21550 ("last_priority is out of range", Arg3
);
21552 -- Check that the priority range is valid
21554 elsif Lower_Val
> Upper_Val
then
21556 ("last_priority_expression must be greater than or equal to "
21557 & "first_priority_expression");
21559 -- Store the new policy, but always preserve System_Location since
21560 -- we like the error message with the run-time name.
21563 -- Check overlapping in the priority ranges specified in other
21564 -- Priority_Specific_Dispatching pragmas within the same
21565 -- partition. We can only check those we know about.
21568 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
21570 if Specific_Dispatching
.Table
(J
).First_Priority
in
21571 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21572 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
21573 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
21576 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
21578 ("priority range overlaps with "
21579 & "Priority_Specific_Dispatching#");
21583 -- The use of Priority_Specific_Dispatching is incompatible
21584 -- with Task_Dispatching_Policy.
21586 if Task_Dispatching_Policy
/= ' ' then
21587 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21589 ("Priority_Specific_Dispatching incompatible "
21590 & "with Task_Dispatching_Policy#");
21593 -- The use of Priority_Specific_Dispatching forces ceiling
21596 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
21597 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
21599 ("Priority_Specific_Dispatching incompatible "
21600 & "with Locking_Policy#");
21602 -- Set the Ceiling_Locking policy, but preserve System_Location
21603 -- since we like the error message with the run time name.
21606 Locking_Policy
:= 'C';
21608 if Locking_Policy_Sloc
/= System_Location
then
21609 Locking_Policy_Sloc
:= Loc
;
21613 -- Add entry in the table
21615 Specific_Dispatching
.Append
21616 ((Dispatching_Policy
=> DP
,
21617 First_Priority
=> UI_To_Int
(Lower_Val
),
21618 Last_Priority
=> UI_To_Int
(Upper_Val
),
21619 Pragma_Loc
=> Loc
));
21621 end Priority_Specific_Dispatching
;
21627 -- pragma Profile (profile_IDENTIFIER);
21629 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
21631 when Pragma_Profile
=>
21633 Check_Arg_Count
(1);
21634 Check_Valid_Configuration_Pragma
;
21635 Check_No_Identifiers
;
21638 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21641 if Chars
(Argx
) = Name_Ravenscar
then
21642 Set_Ravenscar_Profile
(Ravenscar
, N
);
21644 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
21645 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
21647 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
21648 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
21650 elsif Chars
(Argx
) = Name_Restricted
then
21651 Set_Profile_Restrictions
21653 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21655 elsif Chars
(Argx
) = Name_Rational
then
21656 Set_Rational_Profile
;
21658 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21659 Set_Profile_Restrictions
21660 (No_Implementation_Extensions
,
21661 N
, Warn
=> Treat_Restrictions_As_Warnings
);
21664 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21668 ----------------------
21669 -- Profile_Warnings --
21670 ----------------------
21672 -- pragma Profile_Warnings (profile_IDENTIFIER);
21674 -- profile_IDENTIFIER => Restricted | Ravenscar
21676 when Pragma_Profile_Warnings
=>
21678 Check_Arg_Count
(1);
21679 Check_Valid_Configuration_Pragma
;
21680 Check_No_Identifiers
;
21683 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21686 if Chars
(Argx
) = Name_Ravenscar
then
21687 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
21689 elsif Chars
(Argx
) = Name_Restricted
then
21690 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
21692 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
21693 Set_Profile_Restrictions
21694 (No_Implementation_Extensions
, N
, Warn
=> True);
21697 Error_Pragma_Arg
("& is not a valid profile", Argx
);
21701 --------------------------
21702 -- Propagate_Exceptions --
21703 --------------------------
21705 -- pragma Propagate_Exceptions;
21707 -- Note: this pragma is obsolete and has no effect
21709 when Pragma_Propagate_Exceptions
=>
21711 Check_Arg_Count
(0);
21713 if Warn_On_Obsolescent_Feature
then
21715 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
21716 "and has no effect?j?", N
);
21719 -----------------------------
21720 -- Provide_Shift_Operators --
21721 -----------------------------
21723 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
21725 when Pragma_Provide_Shift_Operators
=>
21726 Provide_Shift_Operators
: declare
21729 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
21730 -- Insert declaration and pragma Instrinsic for named shift op
21732 ----------------------------
21733 -- Declare_Shift_Operator --
21734 ----------------------------
21736 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
21742 Make_Subprogram_Declaration
(Loc
,
21743 Make_Function_Specification
(Loc
,
21744 Defining_Unit_Name
=>
21745 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
21747 Result_Definition
=>
21748 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
21750 Parameter_Specifications
=> New_List
(
21751 Make_Parameter_Specification
(Loc
,
21752 Defining_Identifier
=>
21753 Make_Defining_Identifier
(Loc
, Name_Value
),
21755 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
21757 Make_Parameter_Specification
(Loc
,
21758 Defining_Identifier
=>
21759 Make_Defining_Identifier
(Loc
, Name_Amount
),
21761 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
21765 Chars
=> Name_Import
,
21766 Pragma_Argument_Associations
=> New_List
(
21767 Make_Pragma_Argument_Association
(Loc
,
21768 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
21769 Make_Pragma_Argument_Association
(Loc
,
21770 Expression
=> Make_Identifier
(Loc
, Nam
))));
21772 Insert_After
(N
, Import
);
21773 Insert_After
(N
, Func
);
21774 end Declare_Shift_Operator
;
21776 -- Start of processing for Provide_Shift_Operators
21780 Check_Arg_Count
(1);
21781 Check_Arg_Is_Local_Name
(Arg1
);
21783 Arg1
:= Get_Pragma_Arg
(Arg1
);
21785 -- We must have an entity name
21787 if not Is_Entity_Name
(Arg1
) then
21789 ("pragma % must apply to integer first subtype", Arg1
);
21792 -- If no Entity, means there was a prior error so ignore
21794 if Present
(Entity
(Arg1
)) then
21795 Ent
:= Entity
(Arg1
);
21797 -- Apply error checks
21799 if not Is_First_Subtype
(Ent
) then
21801 ("cannot apply pragma %",
21802 "\& is not a first subtype",
21805 elsif not Is_Integer_Type
(Ent
) then
21807 ("cannot apply pragma %",
21808 "\& is not an integer type",
21811 elsif Has_Shift_Operator
(Ent
) then
21813 ("cannot apply pragma %",
21814 "\& already has declared shift operators",
21817 elsif Is_Frozen
(Ent
) then
21819 ("pragma % appears too late",
21820 "\& is already frozen",
21824 -- Now declare the operators. We do this during analysis rather
21825 -- than expansion, since we want the operators available if we
21826 -- are operating in -gnatc or ASIS mode.
21828 Declare_Shift_Operator
(Name_Rotate_Left
);
21829 Declare_Shift_Operator
(Name_Rotate_Right
);
21830 Declare_Shift_Operator
(Name_Shift_Left
);
21831 Declare_Shift_Operator
(Name_Shift_Right
);
21832 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
21834 end Provide_Shift_Operators
;
21840 -- pragma Psect_Object (
21841 -- [Internal =>] LOCAL_NAME,
21842 -- [, [External =>] EXTERNAL_SYMBOL]
21843 -- [, [Size =>] EXTERNAL_SYMBOL]);
21845 when Pragma_Common_Object
21846 | Pragma_Psect_Object
21848 Psect_Object
: declare
21849 Args
: Args_List
(1 .. 3);
21850 Names
: constant Name_List
(1 .. 3) := (
21855 Internal
: Node_Id
renames Args
(1);
21856 External
: Node_Id
renames Args
(2);
21857 Size
: Node_Id
renames Args
(3);
21859 Def_Id
: Entity_Id
;
21861 procedure Check_Arg
(Arg
: Node_Id
);
21862 -- Checks that argument is either a string literal or an
21863 -- identifier, and posts error message if not.
21869 procedure Check_Arg
(Arg
: Node_Id
) is
21871 if not Nkind_In
(Original_Node
(Arg
),
21876 ("inappropriate argument for pragma %", Arg
);
21880 -- Start of processing for Common_Object/Psect_Object
21884 Gather_Associations
(Names
, Args
);
21885 Process_Extended_Import_Export_Internal_Arg
(Internal
);
21887 Def_Id
:= Entity
(Internal
);
21889 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
21891 ("pragma% must designate an object", Internal
);
21894 Check_Arg
(Internal
);
21896 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
21898 ("cannot use pragma% for imported/exported object",
21902 if Is_Concurrent_Type
(Etype
(Internal
)) then
21904 ("cannot specify pragma % for task/protected object",
21908 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
21910 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
21912 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
21915 if Ekind
(Def_Id
) = E_Constant
then
21917 ("cannot specify pragma % for a constant", Internal
);
21920 if Is_Record_Type
(Etype
(Internal
)) then
21926 Ent
:= First_Entity
(Etype
(Internal
));
21927 while Present
(Ent
) loop
21928 Decl
:= Declaration_Node
(Ent
);
21930 if Ekind
(Ent
) = E_Component
21931 and then Nkind
(Decl
) = N_Component_Declaration
21932 and then Present
(Expression
(Decl
))
21933 and then Warn_On_Export_Import
21936 ("?x?object for pragma % has defaults", Internal
);
21946 if Present
(Size
) then
21950 if Present
(External
) then
21951 Check_Arg_Is_External_Name
(External
);
21954 -- If all error tests pass, link pragma on to the rep item chain
21956 Record_Rep_Item
(Def_Id
, N
);
21963 -- pragma Pure [(library_unit_NAME)];
21965 when Pragma_Pure
=> Pure
: declare
21969 Check_Ada_83_Warning
;
21971 -- If the pragma comes from a subprogram instantiation, nothing to
21972 -- check, this can happen at any level of nesting.
21974 if Is_Wrapper_Package
(Current_Scope
) then
21977 Check_Valid_Library_Unit_Pragma
;
21980 if Nkind
(N
) = N_Null_Statement
then
21984 Ent
:= Find_Lib_Unit_Name
;
21986 -- A pragma that applies to a Ghost entity becomes Ghost for the
21987 -- purposes of legality checks and removal of ignored Ghost code.
21989 Mark_Ghost_Pragma
(N
, Ent
);
21991 if not Debug_Flag_U
then
21993 Set_Has_Pragma_Pure
(Ent
);
21995 if Legacy_Elaboration_Checks
then
21996 Set_Suppress_Elaboration_Warnings
(Ent
);
22001 -------------------
22002 -- Pure_Function --
22003 -------------------
22005 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
22007 when Pragma_Pure_Function
=> Pure_Function
: declare
22008 Def_Id
: Entity_Id
;
22011 Effective
: Boolean := False;
22012 Orig_Def
: Entity_Id
;
22013 Same_Decl
: Boolean := False;
22017 Check_Arg_Count
(1);
22018 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22019 Check_Arg_Is_Local_Name
(Arg1
);
22020 E_Id
:= Get_Pragma_Arg
(Arg1
);
22022 if Etype
(E_Id
) = Any_Type
then
22026 -- Loop through homonyms (overloadings) of referenced entity
22028 E
:= Entity
(E_Id
);
22030 -- A pragma that applies to a Ghost entity becomes Ghost for the
22031 -- purposes of legality checks and removal of ignored Ghost code.
22033 Mark_Ghost_Pragma
(N
, E
);
22035 if Present
(E
) then
22037 Def_Id
:= Get_Base_Subprogram
(E
);
22039 if not Ekind_In
(Def_Id
, E_Function
,
22040 E_Generic_Function
,
22044 ("pragma% requires a function name", Arg1
);
22047 -- When we have a generic function we must jump up a level
22048 -- to the declaration of the wrapper package itself.
22050 Orig_Def
:= Def_Id
;
22052 if Is_Generic_Instance
(Def_Id
) then
22053 while Nkind
(Orig_Def
) /= N_Package_Declaration
loop
22054 Orig_Def
:= Parent
(Orig_Def
);
22058 if In_Same_Declarative_Part
(Parent
(N
), Orig_Def
) then
22060 Set_Is_Pure
(Def_Id
);
22062 if not Has_Pragma_Pure_Function
(Def_Id
) then
22063 Set_Has_Pragma_Pure_Function
(Def_Id
);
22068 exit when From_Aspect_Specification
(N
);
22070 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
22074 and then Warn_On_Redundant_Constructs
22077 ("pragma Pure_Function on& is redundant?r?",
22080 elsif not Same_Decl
then
22082 ("pragma% argument must be in same declarative part",
22088 --------------------
22089 -- Queuing_Policy --
22090 --------------------
22092 -- pragma Queuing_Policy (policy_IDENTIFIER);
22094 when Pragma_Queuing_Policy
=> declare
22098 Check_Ada_83_Warning
;
22099 Check_Arg_Count
(1);
22100 Check_No_Identifiers
;
22101 Check_Arg_Is_Queuing_Policy
(Arg1
);
22102 Check_Valid_Configuration_Pragma
;
22103 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22104 QP
:= Fold_Upper
(Name_Buffer
(1));
22106 if Queuing_Policy
/= ' '
22107 and then Queuing_Policy
/= QP
22109 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
22110 Error_Pragma
("queuing policy incompatible with policy#");
22112 -- Set new policy, but always preserve System_Location since we
22113 -- like the error message with the run time name.
22116 Queuing_Policy
:= QP
;
22118 if Queuing_Policy_Sloc
/= System_Location
then
22119 Queuing_Policy_Sloc
:= Loc
;
22128 -- pragma Rational, for compatibility with foreign compiler
22130 when Pragma_Rational
=>
22131 Set_Rational_Profile
;
22133 ---------------------
22134 -- Refined_Depends --
22135 ---------------------
22137 -- pragma Refined_Depends (DEPENDENCY_RELATION);
22139 -- DEPENDENCY_RELATION ::=
22141 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
22143 -- DEPENDENCY_CLAUSE ::=
22144 -- OUTPUT_LIST =>[+] INPUT_LIST
22145 -- | NULL_DEPENDENCY_CLAUSE
22147 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
22149 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
22151 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
22153 -- OUTPUT ::= NAME | FUNCTION_RESULT
22156 -- where FUNCTION_RESULT is a function Result attribute_reference
22158 -- Characteristics:
22160 -- * Analysis - The annotation undergoes initial checks to verify
22161 -- the legal placement and context. Secondary checks fully analyze
22162 -- the dependency clauses/global list in:
22164 -- Analyze_Refined_Depends_In_Decl_Part
22166 -- * Expansion - None.
22168 -- * Template - The annotation utilizes the generic template of the
22169 -- related subprogram body.
22171 -- * Globals - Capture of global references must occur after full
22174 -- * Instance - The annotation is instantiated automatically when
22175 -- the related generic subprogram body is instantiated.
22177 when Pragma_Refined_Depends
=> Refined_Depends
: declare
22178 Body_Id
: Entity_Id
;
22180 Spec_Id
: Entity_Id
;
22183 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22187 -- Chain the pragma on the contract for further processing by
22188 -- Analyze_Refined_Depends_In_Decl_Part.
22190 Add_Contract_Item
(N
, Body_Id
);
22192 -- The legality checks of pragmas Refined_Depends and
22193 -- Refined_Global are affected by the SPARK mode in effect and
22194 -- the volatility of the context. In addition these two pragmas
22195 -- are subject to an inherent order:
22197 -- 1) Refined_Global
22198 -- 2) Refined_Depends
22200 -- Analyze all these pragmas in the order outlined above
22202 Analyze_If_Present
(Pragma_SPARK_Mode
);
22203 Analyze_If_Present
(Pragma_Volatile_Function
);
22204 Analyze_If_Present
(Pragma_Refined_Global
);
22205 Analyze_Refined_Depends_In_Decl_Part
(N
);
22207 end Refined_Depends
;
22209 --------------------
22210 -- Refined_Global --
22211 --------------------
22213 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
22215 -- GLOBAL_SPECIFICATION ::=
22218 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
22220 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
22222 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
22223 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
22224 -- GLOBAL_ITEM ::= NAME
22226 -- Characteristics:
22228 -- * Analysis - The annotation undergoes initial checks to verify
22229 -- the legal placement and context. Secondary checks fully analyze
22230 -- the dependency clauses/global list in:
22232 -- Analyze_Refined_Global_In_Decl_Part
22234 -- * Expansion - None.
22236 -- * Template - The annotation utilizes the generic template of the
22237 -- related subprogram body.
22239 -- * Globals - Capture of global references must occur after full
22242 -- * Instance - The annotation is instantiated automatically when
22243 -- the related generic subprogram body is instantiated.
22245 when Pragma_Refined_Global
=> Refined_Global
: declare
22246 Body_Id
: Entity_Id
;
22248 Spec_Id
: Entity_Id
;
22251 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22255 -- Chain the pragma on the contract for further processing by
22256 -- Analyze_Refined_Global_In_Decl_Part.
22258 Add_Contract_Item
(N
, Body_Id
);
22260 -- The legality checks of pragmas Refined_Depends and
22261 -- Refined_Global are affected by the SPARK mode in effect and
22262 -- the volatility of the context. In addition these two pragmas
22263 -- are subject to an inherent order:
22265 -- 1) Refined_Global
22266 -- 2) Refined_Depends
22268 -- Analyze all these pragmas in the order outlined above
22270 Analyze_If_Present
(Pragma_SPARK_Mode
);
22271 Analyze_If_Present
(Pragma_Volatile_Function
);
22272 Analyze_Refined_Global_In_Decl_Part
(N
);
22273 Analyze_If_Present
(Pragma_Refined_Depends
);
22275 end Refined_Global
;
22281 -- pragma Refined_Post (boolean_EXPRESSION);
22283 -- Characteristics:
22285 -- * Analysis - The annotation is fully analyzed immediately upon
22286 -- elaboration as it cannot forward reference entities.
22288 -- * Expansion - The annotation is expanded during the expansion of
22289 -- the related subprogram body contract as performed in:
22291 -- Expand_Subprogram_Contract
22293 -- * Template - The annotation utilizes the generic template of the
22294 -- related subprogram body.
22296 -- * Globals - Capture of global references must occur after full
22299 -- * Instance - The annotation is instantiated automatically when
22300 -- the related generic subprogram body is instantiated.
22302 when Pragma_Refined_Post
=> Refined_Post
: declare
22303 Body_Id
: Entity_Id
;
22305 Spec_Id
: Entity_Id
;
22308 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
22310 -- Fully analyze the pragma when it appears inside a subprogram
22311 -- body because it cannot benefit from forward references.
22315 -- Chain the pragma on the contract for completeness
22317 Add_Contract_Item
(N
, Body_Id
);
22319 -- The legality checks of pragma Refined_Post are affected by
22320 -- the SPARK mode in effect and the volatility of the context.
22321 -- Analyze all pragmas in a specific order.
22323 Analyze_If_Present
(Pragma_SPARK_Mode
);
22324 Analyze_If_Present
(Pragma_Volatile_Function
);
22325 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
22327 -- Currently it is not possible to inline pre/postconditions on
22328 -- a subprogram subject to pragma Inline_Always.
22330 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
22334 -------------------
22335 -- Refined_State --
22336 -------------------
22338 -- pragma Refined_State (REFINEMENT_LIST);
22340 -- REFINEMENT_LIST ::=
22341 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
22343 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
22345 -- CONSTITUENT_LIST ::=
22348 -- | (CONSTITUENT {, CONSTITUENT})
22350 -- CONSTITUENT ::= object_NAME | state_NAME
22352 -- Characteristics:
22354 -- * Analysis - The annotation undergoes initial checks to verify
22355 -- the legal placement and context. Secondary checks preanalyze the
22356 -- refinement clauses in:
22358 -- Analyze_Refined_State_In_Decl_Part
22360 -- * Expansion - None.
22362 -- * Template - The annotation utilizes the template of the related
22365 -- * Globals - Capture of global references must occur after full
22368 -- * Instance - The annotation is instantiated automatically when
22369 -- the related generic package body is instantiated.
22371 when Pragma_Refined_State
=> Refined_State
: declare
22372 Pack_Decl
: Node_Id
;
22373 Spec_Id
: Entity_Id
;
22377 Check_No_Identifiers
;
22378 Check_Arg_Count
(1);
22380 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
22382 if Nkind
(Pack_Decl
) /= N_Package_Body
then
22387 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
22389 -- A pragma that applies to a Ghost entity becomes Ghost for the
22390 -- purposes of legality checks and removal of ignored Ghost code.
22392 Mark_Ghost_Pragma
(N
, Spec_Id
);
22394 -- Chain the pragma on the contract for further processing by
22395 -- Analyze_Refined_State_In_Decl_Part.
22397 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
22399 -- The legality checks of pragma Refined_State are affected by the
22400 -- SPARK mode in effect. Analyze all pragmas in a specific order.
22402 Analyze_If_Present
(Pragma_SPARK_Mode
);
22404 -- State refinement is allowed only when the corresponding package
22405 -- declaration has non-null pragma Abstract_State. Refinement not
22406 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
22408 if SPARK_Mode
/= Off
22410 (No
(Abstract_States
(Spec_Id
))
22411 or else Has_Null_Abstract_State
(Spec_Id
))
22414 ("useless refinement, package & does not define abstract "
22415 & "states", N
, Spec_Id
);
22420 -----------------------
22421 -- Relative_Deadline --
22422 -----------------------
22424 -- pragma Relative_Deadline (time_span_EXPRESSION);
22426 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
22427 P
: constant Node_Id
:= Parent
(N
);
22432 Check_No_Identifiers
;
22433 Check_Arg_Count
(1);
22435 Arg
:= Get_Pragma_Arg
(Arg1
);
22437 -- The expression must be analyzed in the special manner described
22438 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
22440 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
22444 if Nkind
(P
) = N_Subprogram_Body
then
22445 Check_In_Main_Program
;
22447 -- Only Task and subprogram cases allowed
22449 elsif Nkind
(P
) /= N_Task_Definition
then
22453 -- Check duplicate pragma before we set the corresponding flag
22455 if Has_Relative_Deadline_Pragma
(P
) then
22456 Error_Pragma
("duplicate pragma% not allowed");
22459 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
22460 -- Relative_Deadline pragma node cannot be inserted in the Rep
22461 -- Item chain of Ent since it is rewritten by the expander as a
22462 -- procedure call statement that will break the chain.
22464 Set_Has_Relative_Deadline_Pragma
(P
);
22465 end Relative_Deadline
;
22467 ------------------------
22468 -- Remote_Access_Type --
22469 ------------------------
22471 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
22473 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
22478 Check_Arg_Count
(1);
22479 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22480 Check_Arg_Is_Local_Name
(Arg1
);
22482 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
22484 -- A pragma that applies to a Ghost entity becomes Ghost for the
22485 -- purposes of legality checks and removal of ignored Ghost code.
22487 Mark_Ghost_Pragma
(N
, E
);
22489 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
22490 and then Ekind
(E
) = E_General_Access_Type
22491 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
22492 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
22494 and then Is_Valid_Remote_Object_Type
22495 (Root_Type
(Directly_Designated_Type
(E
)))
22497 Set_Is_Remote_Types
(E
);
22501 ("pragma% applies only to formal access-to-class-wide types",
22504 end Remote_Access_Type
;
22506 ---------------------------
22507 -- Remote_Call_Interface --
22508 ---------------------------
22510 -- pragma Remote_Call_Interface [(library_unit_NAME)];
22512 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
22513 Cunit_Node
: Node_Id
;
22514 Cunit_Ent
: Entity_Id
;
22518 Check_Ada_83_Warning
;
22519 Check_Valid_Library_Unit_Pragma
;
22521 if Nkind
(N
) = N_Null_Statement
then
22525 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22526 K
:= Nkind
(Unit
(Cunit_Node
));
22527 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22529 -- A pragma that applies to a Ghost entity becomes Ghost for the
22530 -- purposes of legality checks and removal of ignored Ghost code.
22532 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22534 if K
= N_Package_Declaration
22535 or else K
= N_Generic_Package_Declaration
22536 or else K
= N_Subprogram_Declaration
22537 or else K
= N_Generic_Subprogram_Declaration
22538 or else (K
= N_Subprogram_Body
22539 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
22544 "pragma% must apply to package or subprogram declaration");
22547 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
22548 end Remote_Call_Interface
;
22554 -- pragma Remote_Types [(library_unit_NAME)];
22556 when Pragma_Remote_Types
=> Remote_Types
: declare
22557 Cunit_Node
: Node_Id
;
22558 Cunit_Ent
: Entity_Id
;
22561 Check_Ada_83_Warning
;
22562 Check_Valid_Library_Unit_Pragma
;
22564 if Nkind
(N
) = N_Null_Statement
then
22568 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22569 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22571 -- A pragma that applies to a Ghost entity becomes Ghost for the
22572 -- purposes of legality checks and removal of ignored Ghost code.
22574 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22576 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22577 N_Generic_Package_Declaration
)
22580 ("pragma% can only apply to a package declaration");
22583 Set_Is_Remote_Types
(Cunit_Ent
);
22590 -- pragma Ravenscar;
22592 when Pragma_Ravenscar
=>
22594 Check_Arg_Count
(0);
22595 Check_Valid_Configuration_Pragma
;
22596 Set_Ravenscar_Profile
(Ravenscar
, N
);
22598 if Warn_On_Obsolescent_Feature
then
22600 ("pragma Ravenscar is an obsolescent feature?j?", N
);
22602 ("|use pragma Profile (Ravenscar) instead?j?", N
);
22605 -------------------------
22606 -- Restricted_Run_Time --
22607 -------------------------
22609 -- pragma Restricted_Run_Time;
22611 when Pragma_Restricted_Run_Time
=>
22613 Check_Arg_Count
(0);
22614 Check_Valid_Configuration_Pragma
;
22615 Set_Profile_Restrictions
22616 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
22618 if Warn_On_Obsolescent_Feature
then
22620 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
22623 ("|use pragma Profile (Restricted) instead?j?", N
);
22630 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
22633 -- restriction_IDENTIFIER
22634 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22636 when Pragma_Restrictions
=>
22637 Process_Restrictions_Or_Restriction_Warnings
22638 (Warn
=> Treat_Restrictions_As_Warnings
);
22640 --------------------------
22641 -- Restriction_Warnings --
22642 --------------------------
22644 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
22647 -- restriction_IDENTIFIER
22648 -- | restriction_parameter_IDENTIFIER => EXPRESSION
22650 when Pragma_Restriction_Warnings
=>
22652 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
22658 -- pragma Reviewable;
22660 when Pragma_Reviewable
=>
22661 Check_Ada_83_Warning
;
22662 Check_Arg_Count
(0);
22664 -- Call dummy debugging function rv. This is done to assist front
22665 -- end debugging. By placing a Reviewable pragma in the source
22666 -- program, a breakpoint on rv catches this place in the source,
22667 -- allowing convenient stepping to the point of interest.
22671 --------------------------
22672 -- Secondary_Stack_Size --
22673 --------------------------
22675 -- pragma Secondary_Stack_Size (EXPRESSION);
22677 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
22678 P
: constant Node_Id
:= Parent
(N
);
22684 Check_No_Identifiers
;
22685 Check_Arg_Count
(1);
22687 if Nkind
(P
) = N_Task_Definition
then
22688 Arg
:= Get_Pragma_Arg
(Arg1
);
22689 Ent
:= Defining_Identifier
(Parent
(P
));
22691 -- The expression must be analyzed in the special manner
22692 -- described in "Handling of Default Expressions" in sem.ads.
22694 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22696 -- The pragma cannot appear if the No_Secondary_Stack
22697 -- restriction is in effect.
22699 Check_Restriction
(No_Secondary_Stack
, Arg
);
22701 -- Anything else is incorrect
22707 -- Check duplicate pragma before we chain the pragma in the Rep
22708 -- Item chain of Ent.
22710 Check_Duplicate_Pragma
(Ent
);
22711 Record_Rep_Item
(Ent
, N
);
22712 end Secondary_Stack_Size
;
22714 --------------------------
22715 -- Short_Circuit_And_Or --
22716 --------------------------
22718 -- pragma Short_Circuit_And_Or;
22720 when Pragma_Short_Circuit_And_Or
=>
22722 Check_Arg_Count
(0);
22723 Check_Valid_Configuration_Pragma
;
22724 Short_Circuit_And_Or
:= True;
22726 -------------------
22727 -- Share_Generic --
22728 -------------------
22730 -- pragma Share_Generic (GNAME {, GNAME});
22732 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
22734 when Pragma_Share_Generic
=>
22736 Process_Generic_List
;
22742 -- pragma Shared (LOCAL_NAME);
22744 when Pragma_Shared
=>
22746 Process_Atomic_Independent_Shared_Volatile
;
22748 --------------------
22749 -- Shared_Passive --
22750 --------------------
22752 -- pragma Shared_Passive [(library_unit_NAME)];
22754 -- Set the flag Is_Shared_Passive of program unit name entity
22756 when Pragma_Shared_Passive
=> Shared_Passive
: declare
22757 Cunit_Node
: Node_Id
;
22758 Cunit_Ent
: Entity_Id
;
22761 Check_Ada_83_Warning
;
22762 Check_Valid_Library_Unit_Pragma
;
22764 if Nkind
(N
) = N_Null_Statement
then
22768 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
22769 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
22771 -- A pragma that applies to a Ghost entity becomes Ghost for the
22772 -- purposes of legality checks and removal of ignored Ghost code.
22774 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
22776 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
22777 N_Generic_Package_Declaration
)
22780 ("pragma% can only apply to a package declaration");
22783 Set_Is_Shared_Passive
(Cunit_Ent
);
22784 end Shared_Passive
;
22786 -----------------------
22787 -- Short_Descriptors --
22788 -----------------------
22790 -- pragma Short_Descriptors;
22792 -- Recognize and validate, but otherwise ignore
22794 when Pragma_Short_Descriptors
=>
22796 Check_Arg_Count
(0);
22797 Check_Valid_Configuration_Pragma
;
22799 ------------------------------
22800 -- Simple_Storage_Pool_Type --
22801 ------------------------------
22803 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
22805 when Pragma_Simple_Storage_Pool_Type
=>
22806 Simple_Storage_Pool_Type
: declare
22812 Check_Arg_Count
(1);
22813 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22815 Type_Id
:= Get_Pragma_Arg
(Arg1
);
22816 Find_Type
(Type_Id
);
22817 Typ
:= Entity
(Type_Id
);
22819 if Typ
= Any_Type
then
22823 -- A pragma that applies to a Ghost entity becomes Ghost for the
22824 -- purposes of legality checks and removal of ignored Ghost code.
22826 Mark_Ghost_Pragma
(N
, Typ
);
22828 -- We require the pragma to apply to a type declared in a package
22829 -- declaration, but not (immediately) within a package body.
22831 if Ekind
(Current_Scope
) /= E_Package
22832 or else In_Package_Body
(Current_Scope
)
22835 ("pragma% can only apply to type declared immediately "
22836 & "within a package declaration");
22839 -- A simple storage pool type must be an immutably limited record
22840 -- or private type. If the pragma is given for a private type,
22841 -- the full type is similarly restricted (which is checked later
22842 -- in Freeze_Entity).
22844 if Is_Record_Type
(Typ
)
22845 and then not Is_Limited_View
(Typ
)
22848 ("pragma% can only apply to explicitly limited record type");
22850 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
22852 ("pragma% can only apply to a private type that is limited");
22854 elsif not Is_Record_Type
(Typ
)
22855 and then not Is_Private_Type
(Typ
)
22858 ("pragma% can only apply to limited record or private type");
22861 Record_Rep_Item
(Typ
, N
);
22862 end Simple_Storage_Pool_Type
;
22864 ----------------------
22865 -- Source_File_Name --
22866 ----------------------
22868 -- There are five forms for this pragma:
22870 -- pragma Source_File_Name (
22871 -- [UNIT_NAME =>] unit_NAME,
22872 -- BODY_FILE_NAME => STRING_LITERAL
22873 -- [, [INDEX =>] INTEGER_LITERAL]);
22875 -- pragma Source_File_Name (
22876 -- [UNIT_NAME =>] unit_NAME,
22877 -- SPEC_FILE_NAME => STRING_LITERAL
22878 -- [, [INDEX =>] INTEGER_LITERAL]);
22880 -- pragma Source_File_Name (
22881 -- BODY_FILE_NAME => STRING_LITERAL
22882 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22883 -- [, CASING => CASING_SPEC]);
22885 -- pragma Source_File_Name (
22886 -- SPEC_FILE_NAME => STRING_LITERAL
22887 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22888 -- [, CASING => CASING_SPEC]);
22890 -- pragma Source_File_Name (
22891 -- SUBUNIT_FILE_NAME => STRING_LITERAL
22892 -- [, DOT_REPLACEMENT => STRING_LITERAL]
22893 -- [, CASING => CASING_SPEC]);
22895 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
22897 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
22898 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
22899 -- only be used when no project file is used, while SFNP can only be
22900 -- used when a project file is used.
22902 -- No processing here. Processing was completed during parsing, since
22903 -- we need to have file names set as early as possible. Units are
22904 -- loaded well before semantic processing starts.
22906 -- The only processing we defer to this point is the check for
22907 -- correct placement.
22909 when Pragma_Source_File_Name
=>
22911 Check_Valid_Configuration_Pragma
;
22913 ------------------------------
22914 -- Source_File_Name_Project --
22915 ------------------------------
22917 -- See Source_File_Name for syntax
22919 -- No processing here. Processing was completed during parsing, since
22920 -- we need to have file names set as early as possible. Units are
22921 -- loaded well before semantic processing starts.
22923 -- The only processing we defer to this point is the check for
22924 -- correct placement.
22926 when Pragma_Source_File_Name_Project
=>
22928 Check_Valid_Configuration_Pragma
;
22930 -- Check that a pragma Source_File_Name_Project is used only in a
22931 -- configuration pragmas file.
22933 -- Pragmas Source_File_Name_Project should only be generated by
22934 -- the Project Manager in configuration pragmas files.
22936 -- This is really an ugly test. It seems to depend on some
22937 -- accidental and undocumented property. At the very least it
22938 -- needs to be documented, but it would be better to have a
22939 -- clean way of testing if we are in a configuration file???
22941 if Present
(Parent
(N
)) then
22943 ("pragma% can only appear in a configuration pragmas file");
22946 ----------------------
22947 -- Source_Reference --
22948 ----------------------
22950 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
22952 -- Nothing to do, all processing completed in Par.Prag, since we need
22953 -- the information for possible parser messages that are output.
22955 when Pragma_Source_Reference
=>
22962 -- pragma SPARK_Mode [(On | Off)];
22964 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
22965 Mode_Id
: SPARK_Mode_Type
;
22967 procedure Check_Pragma_Conformance
22968 (Context_Pragma
: Node_Id
;
22969 Entity
: Entity_Id
;
22970 Entity_Pragma
: Node_Id
);
22971 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
22972 -- conformance of pragma N depending the following scenarios:
22974 -- If pragma Context_Pragma is not Empty, verify that pragma N is
22975 -- compatible with the pragma Context_Pragma that was inherited
22976 -- from the context:
22977 -- * If the mode of Context_Pragma is ON, then the new mode can
22979 -- * If the mode of Context_Pragma is OFF, then the only allowed
22980 -- new mode is also OFF. Emit error if this is not the case.
22982 -- If Entity is not Empty, verify that pragma N is compatible with
22983 -- pragma Entity_Pragma that belongs to Entity.
22984 -- * If Entity_Pragma is Empty, always issue an error as this
22985 -- corresponds to the case where a previous section of Entity
22986 -- has no SPARK_Mode set.
22987 -- * If the mode of Entity_Pragma is ON, then the new mode can
22989 -- * If the mode of Entity_Pragma is OFF, then the only allowed
22990 -- new mode is also OFF. Emit error if this is not the case.
22992 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
22993 -- Subsidiary to routines Process_xxx. Verify that the related
22994 -- entity E subject to pragma SPARK_Mode is library-level.
22996 procedure Process_Body
(Decl
: Node_Id
);
22997 -- Verify the legality of pragma SPARK_Mode when it appears as the
22998 -- top of the body declarations of entry, package, protected unit,
22999 -- subprogram or task unit body denoted by Decl.
23001 procedure Process_Overloadable
(Decl
: Node_Id
);
23002 -- Verify the legality of pragma SPARK_Mode when it applies to an
23003 -- entry or [generic] subprogram declaration denoted by Decl.
23005 procedure Process_Private_Part
(Decl
: Node_Id
);
23006 -- Verify the legality of pragma SPARK_Mode when it appears at the
23007 -- top of the private declarations of a package spec, protected or
23008 -- task unit declaration denoted by Decl.
23010 procedure Process_Statement_Part
(Decl
: Node_Id
);
23011 -- Verify the legality of pragma SPARK_Mode when it appears at the
23012 -- top of the statement sequence of a package body denoted by node
23015 procedure Process_Visible_Part
(Decl
: Node_Id
);
23016 -- Verify the legality of pragma SPARK_Mode when it appears at the
23017 -- top of the visible declarations of a package spec, protected or
23018 -- task unit declaration denoted by Decl. The routine is also used
23019 -- on protected or task units declared without a definition.
23021 procedure Set_SPARK_Context
;
23022 -- Subsidiary to routines Process_xxx. Set the global variables
23023 -- which represent the mode of the context from pragma N. Ensure
23024 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
23026 ------------------------------
23027 -- Check_Pragma_Conformance --
23028 ------------------------------
23030 procedure Check_Pragma_Conformance
23031 (Context_Pragma
: Node_Id
;
23032 Entity
: Entity_Id
;
23033 Entity_Pragma
: Node_Id
)
23035 Err_Id
: Entity_Id
;
23039 -- The current pragma may appear without an argument. If this
23040 -- is the case, associate all error messages with the pragma
23043 if Present
(Arg1
) then
23049 -- The mode of the current pragma is compared against that of
23050 -- an enclosing context.
23052 if Present
(Context_Pragma
) then
23053 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
23055 -- Issue an error if the new mode is less restrictive than
23056 -- that of the context.
23058 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
23059 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23062 ("cannot change SPARK_Mode from Off to On", Err_N
);
23063 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
23064 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
23069 -- The mode of the current pragma is compared against that of
23070 -- an initial package, protected type, subprogram or task type
23073 if Present
(Entity
) then
23075 -- A simple protected or task type is transformed into an
23076 -- anonymous type whose name cannot be used to issue error
23077 -- messages. Recover the original entity of the type.
23079 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
23082 (Original_Node
(Unit_Declaration_Node
(Entity
)));
23087 -- Both the initial declaration and the completion carry
23088 -- SPARK_Mode pragmas.
23090 if Present
(Entity_Pragma
) then
23091 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
23093 -- Issue an error if the new mode is less restrictive
23094 -- than that of the initial declaration.
23096 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
23097 and then Get_SPARK_Mode_From_Annotation
(N
) = On
23099 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23100 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
23102 ("\value Off was set for SPARK_Mode on&#",
23107 -- Otherwise the initial declaration lacks a SPARK_Mode
23108 -- pragma in which case the current pragma is illegal as
23109 -- it cannot "complete".
23112 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
23113 Error_Msg_Sloc
:= Sloc
(Err_Id
);
23115 ("\no value was set for SPARK_Mode on&#",
23120 end Check_Pragma_Conformance
;
23122 --------------------------------
23123 -- Check_Library_Level_Entity --
23124 --------------------------------
23126 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
23127 procedure Add_Entity_To_Name_Buffer
;
23128 -- Add the E_Kind of entity E to the name buffer
23130 -------------------------------
23131 -- Add_Entity_To_Name_Buffer --
23132 -------------------------------
23134 procedure Add_Entity_To_Name_Buffer
is
23136 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
23137 Add_Str_To_Name_Buffer
("entry");
23139 elsif Ekind_In
(E
, E_Generic_Package
,
23143 Add_Str_To_Name_Buffer
("package");
23145 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
23146 Add_Str_To_Name_Buffer
("protected type");
23148 elsif Ekind_In
(E
, E_Function
,
23149 E_Generic_Function
,
23150 E_Generic_Procedure
,
23154 Add_Str_To_Name_Buffer
("subprogram");
23157 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
23158 Add_Str_To_Name_Buffer
("task type");
23160 end Add_Entity_To_Name_Buffer
;
23164 Msg_1
: constant String := "incorrect placement of pragma%";
23167 -- Start of processing for Check_Library_Level_Entity
23170 if not Is_Library_Level_Entity
(E
) then
23171 Error_Msg_Name_1
:= Pname
;
23172 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
23175 Add_Str_To_Name_Buffer
("\& is not a library-level ");
23176 Add_Entity_To_Name_Buffer
;
23178 Msg_2
:= Name_Find
;
23179 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
23183 end Check_Library_Level_Entity
;
23189 procedure Process_Body
(Decl
: Node_Id
) is
23190 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23191 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
23194 -- Ignore pragma when applied to the special body created for
23195 -- inlining, recognized by its internal name _Parent.
23197 if Chars
(Body_Id
) = Name_uParent
then
23201 Check_Library_Level_Entity
(Body_Id
);
23203 -- For entry bodies, verify the legality against:
23204 -- * The mode of the context
23205 -- * The mode of the spec (if any)
23207 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
23209 -- A stand-alone subprogram body
23211 if Body_Id
= Spec_Id
then
23212 Check_Pragma_Conformance
23213 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23215 Entity_Pragma
=> Empty
);
23217 -- An entry or subprogram body that completes a previous
23221 Check_Pragma_Conformance
23222 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23224 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23228 Set_SPARK_Pragma
(Body_Id
, N
);
23229 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23231 -- For package bodies, verify the legality against:
23232 -- * The mode of the context
23233 -- * The mode of the private part
23235 -- This case is separated from protected and task bodies
23236 -- because the statement part of the package body inherits
23237 -- the mode of the body declarations.
23239 elsif Nkind
(Decl
) = N_Package_Body
then
23240 Check_Pragma_Conformance
23241 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23243 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23246 Set_SPARK_Pragma
(Body_Id
, N
);
23247 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23248 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23249 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
23251 -- For protected and task bodies, verify the legality against:
23252 -- * The mode of the context
23253 -- * The mode of the private part
23257 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
23259 Check_Pragma_Conformance
23260 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
23262 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
23265 Set_SPARK_Pragma
(Body_Id
, N
);
23266 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
23270 --------------------------
23271 -- Process_Overloadable --
23272 --------------------------
23274 procedure Process_Overloadable
(Decl
: Node_Id
) is
23275 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23276 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
23279 Check_Library_Level_Entity
(Spec_Id
);
23281 -- Verify the legality against:
23282 -- * The mode of the context
23284 Check_Pragma_Conformance
23285 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23287 Entity_Pragma
=> Empty
);
23289 Set_SPARK_Pragma
(Spec_Id
, N
);
23290 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23292 -- When the pragma applies to the anonymous object created for
23293 -- a single task type, decorate the type as well. This scenario
23294 -- arises when the single task type lacks a task definition,
23295 -- therefore there is no issue with respect to a potential
23296 -- pragma SPARK_Mode in the private part.
23298 -- task type Anon_Task_Typ;
23299 -- Obj : Anon_Task_Typ;
23300 -- pragma SPARK_Mode ...;
23302 if Is_Single_Task_Object
(Spec_Id
) then
23303 Set_SPARK_Pragma
(Spec_Typ
, N
);
23304 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
23305 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
23306 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
23308 end Process_Overloadable
;
23310 --------------------------
23311 -- Process_Private_Part --
23312 --------------------------
23314 procedure Process_Private_Part
(Decl
: Node_Id
) is
23315 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23318 Check_Library_Level_Entity
(Spec_Id
);
23320 -- Verify the legality against:
23321 -- * The mode of the visible declarations
23323 Check_Pragma_Conformance
23324 (Context_Pragma
=> Empty
,
23326 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
23329 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23330 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
23331 end Process_Private_Part
;
23333 ----------------------------
23334 -- Process_Statement_Part --
23335 ----------------------------
23337 procedure Process_Statement_Part
(Decl
: Node_Id
) is
23338 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23341 Check_Library_Level_Entity
(Body_Id
);
23343 -- Verify the legality against:
23344 -- * The mode of the body declarations
23346 Check_Pragma_Conformance
23347 (Context_Pragma
=> Empty
,
23349 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
23352 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
23353 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
23354 end Process_Statement_Part
;
23356 --------------------------
23357 -- Process_Visible_Part --
23358 --------------------------
23360 procedure Process_Visible_Part
(Decl
: Node_Id
) is
23361 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
23362 Obj_Id
: Entity_Id
;
23365 Check_Library_Level_Entity
(Spec_Id
);
23367 -- Verify the legality against:
23368 -- * The mode of the context
23370 Check_Pragma_Conformance
23371 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
23373 Entity_Pragma
=> Empty
);
23375 -- A task unit declared without a definition does not set the
23376 -- SPARK_Mode of the context because the task does not have any
23377 -- entries that could inherit the mode.
23379 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
23380 N_Task_Type_Declaration
)
23385 Set_SPARK_Pragma
(Spec_Id
, N
);
23386 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
23387 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
23388 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
23390 -- When the pragma applies to a single protected or task type,
23391 -- decorate the corresponding anonymous object as well.
23393 -- protected Anon_Prot_Typ is
23394 -- pragma SPARK_Mode ...;
23396 -- end Anon_Prot_Typ;
23398 -- Obj : Anon_Prot_Typ;
23400 if Is_Single_Concurrent_Type
(Spec_Id
) then
23401 Obj_Id
:= Anonymous_Object
(Spec_Id
);
23403 Set_SPARK_Pragma
(Obj_Id
, N
);
23404 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
23406 end Process_Visible_Part
;
23408 -----------------------
23409 -- Set_SPARK_Context --
23410 -----------------------
23412 procedure Set_SPARK_Context
is
23414 SPARK_Mode
:= Mode_Id
;
23415 SPARK_Mode_Pragma
:= N
;
23416 end Set_SPARK_Context
;
23424 -- Start of processing for Do_SPARK_Mode
23427 -- When a SPARK_Mode pragma appears inside an instantiation whose
23428 -- enclosing context has SPARK_Mode set to "off", the pragma has
23429 -- no semantic effect.
23431 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
23432 Rewrite
(N
, Make_Null_Statement
(Loc
));
23438 Check_No_Identifiers
;
23439 Check_At_Most_N_Arguments
(1);
23441 -- Check the legality of the mode (no argument = ON)
23443 if Arg_Count
= 1 then
23444 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23445 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
23450 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
23451 Context
:= Parent
(N
);
23453 -- The pragma appears in a configuration file
23455 if No
(Context
) then
23456 Check_Valid_Configuration_Pragma
;
23458 if Present
(SPARK_Mode_Pragma
) then
23461 Prev
=> SPARK_Mode_Pragma
);
23467 -- The pragma acts as a configuration pragma in a compilation unit
23469 -- pragma SPARK_Mode ...;
23470 -- package Pack is ...;
23472 elsif Nkind
(Context
) = N_Compilation_Unit
23473 and then List_Containing
(N
) = Context_Items
(Context
)
23475 Check_Valid_Configuration_Pragma
;
23478 -- Otherwise the placement of the pragma within the tree dictates
23479 -- its associated construct. Inspect the declarative list where
23480 -- the pragma resides to find a potential construct.
23484 while Present
(Stmt
) loop
23486 -- Skip prior pragmas, but check for duplicates. Note that
23487 -- this also takes care of pragmas generated for aspects.
23489 if Nkind
(Stmt
) = N_Pragma
then
23490 if Pragma_Name
(Stmt
) = Pname
then
23497 -- The pragma applies to an expression function that has
23498 -- already been rewritten into a subprogram declaration.
23500 -- function Expr_Func return ... is (...);
23501 -- pragma SPARK_Mode ...;
23503 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
23504 and then Nkind
(Original_Node
(Stmt
)) =
23505 N_Expression_Function
23507 Process_Overloadable
(Stmt
);
23510 -- The pragma applies to the anonymous object created for a
23511 -- single concurrent type.
23513 -- protected type Anon_Prot_Typ ...;
23514 -- Obj : Anon_Prot_Typ;
23515 -- pragma SPARK_Mode ...;
23517 elsif Nkind
(Stmt
) = N_Object_Declaration
23518 and then Is_Single_Concurrent_Object
23519 (Defining_Entity
(Stmt
))
23521 Process_Overloadable
(Stmt
);
23524 -- Skip internally generated code
23526 elsif not Comes_From_Source
(Stmt
) then
23529 -- The pragma applies to an entry or [generic] subprogram
23533 -- pragma SPARK_Mode ...;
23536 -- procedure Proc ...;
23537 -- pragma SPARK_Mode ...;
23539 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
23540 N_Subprogram_Declaration
)
23541 or else (Nkind
(Stmt
) = N_Entry_Declaration
23542 and then Is_Protected_Type
23543 (Scope
(Defining_Entity
(Stmt
))))
23545 Process_Overloadable
(Stmt
);
23548 -- Otherwise the pragma does not apply to a legal construct
23549 -- or it does not appear at the top of a declarative or a
23550 -- statement list. Issue an error and stop the analysis.
23560 -- The pragma applies to a package or a subprogram that acts as
23561 -- a compilation unit.
23563 -- procedure Proc ...;
23564 -- pragma SPARK_Mode ...;
23566 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
23567 Context
:= Unit
(Parent
(Context
));
23570 -- The pragma appears at the top of entry, package, protected
23571 -- unit, subprogram or task unit body declarations.
23573 -- entry Ent when ... is
23574 -- pragma SPARK_Mode ...;
23576 -- package body Pack is
23577 -- pragma SPARK_Mode ...;
23579 -- procedure Proc ... is
23580 -- pragma SPARK_Mode;
23582 -- protected body Prot is
23583 -- pragma SPARK_Mode ...;
23585 if Nkind_In
(Context
, N_Entry_Body
,
23591 Process_Body
(Context
);
23593 -- The pragma appears at the top of the visible or private
23594 -- declaration of a package spec, protected or task unit.
23597 -- pragma SPARK_Mode ...;
23599 -- pragma SPARK_Mode ...;
23601 -- protected [type] Prot is
23602 -- pragma SPARK_Mode ...;
23604 -- pragma SPARK_Mode ...;
23606 elsif Nkind_In
(Context
, N_Package_Specification
,
23607 N_Protected_Definition
,
23610 if List_Containing
(N
) = Visible_Declarations
(Context
) then
23611 Process_Visible_Part
(Parent
(Context
));
23613 Process_Private_Part
(Parent
(Context
));
23616 -- The pragma appears at the top of package body statements
23618 -- package body Pack is
23620 -- pragma SPARK_Mode;
23622 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
23623 and then Nkind
(Parent
(Context
)) = N_Package_Body
23625 Process_Statement_Part
(Parent
(Context
));
23627 -- The pragma appeared as an aspect of a [generic] subprogram
23628 -- declaration that acts as a compilation unit.
23631 -- procedure Proc ...;
23632 -- pragma SPARK_Mode ...;
23634 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
23635 N_Subprogram_Declaration
)
23637 Process_Overloadable
(Context
);
23639 -- The pragma does not apply to a legal construct, issue error
23647 --------------------------------
23648 -- Static_Elaboration_Desired --
23649 --------------------------------
23651 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
23653 when Pragma_Static_Elaboration_Desired
=>
23655 Check_At_Most_N_Arguments
(1);
23657 if Is_Compilation_Unit
(Current_Scope
)
23658 and then Ekind
(Current_Scope
) = E_Package
23660 Set_Static_Elaboration_Desired
(Current_Scope
, True);
23662 Error_Pragma
("pragma% must apply to a library-level package");
23669 -- pragma Storage_Size (EXPRESSION);
23671 when Pragma_Storage_Size
=> Storage_Size
: declare
23672 P
: constant Node_Id
:= Parent
(N
);
23676 Check_No_Identifiers
;
23677 Check_Arg_Count
(1);
23679 -- The expression must be analyzed in the special manner described
23680 -- in "Handling of Default Expressions" in sem.ads.
23682 Arg
:= Get_Pragma_Arg
(Arg1
);
23683 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
23685 if not Is_OK_Static_Expression
(Arg
) then
23686 Check_Restriction
(Static_Storage_Size
, Arg
);
23689 if Nkind
(P
) /= N_Task_Definition
then
23694 if Has_Storage_Size_Pragma
(P
) then
23695 Error_Pragma
("duplicate pragma% not allowed");
23697 Set_Has_Storage_Size_Pragma
(P
, True);
23700 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
23708 -- pragma Storage_Unit (NUMERIC_LITERAL);
23710 -- Only permitted argument is System'Storage_Unit value
23712 when Pragma_Storage_Unit
=>
23713 Check_No_Identifiers
;
23714 Check_Arg_Count
(1);
23715 Check_Arg_Is_Integer_Literal
(Arg1
);
23717 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
23718 UI_From_Int
(Ttypes
.System_Storage_Unit
)
23720 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
23722 ("the only allowed argument for pragma% is ^", Arg1
);
23725 --------------------
23726 -- Stream_Convert --
23727 --------------------
23729 -- pragma Stream_Convert (
23730 -- [Entity =>] type_LOCAL_NAME,
23731 -- [Read =>] function_NAME,
23732 -- [Write =>] function NAME);
23734 when Pragma_Stream_Convert
=> Stream_Convert
: declare
23735 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
23736 -- Check that the given argument is the name of a local function
23737 -- of one argument that is not overloaded earlier in the current
23738 -- local scope. A check is also made that the argument is a
23739 -- function with one parameter.
23741 --------------------------------------
23742 -- Check_OK_Stream_Convert_Function --
23743 --------------------------------------
23745 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
23749 Check_Arg_Is_Local_Name
(Arg
);
23750 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
23752 if Has_Homonym
(Ent
) then
23754 ("argument for pragma% may not be overloaded", Arg
);
23757 if Ekind
(Ent
) /= E_Function
23758 or else No
(First_Formal
(Ent
))
23759 or else Present
(Next_Formal
(First_Formal
(Ent
)))
23762 ("argument for pragma% must be function of one argument",
23765 end Check_OK_Stream_Convert_Function
;
23767 -- Start of processing for Stream_Convert
23771 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
23772 Check_Arg_Count
(3);
23773 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23774 Check_Optional_Identifier
(Arg2
, Name_Read
);
23775 Check_Optional_Identifier
(Arg3
, Name_Write
);
23776 Check_Arg_Is_Local_Name
(Arg1
);
23777 Check_OK_Stream_Convert_Function
(Arg2
);
23778 Check_OK_Stream_Convert_Function
(Arg3
);
23781 Typ
: constant Entity_Id
:=
23782 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
23783 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
23784 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
23787 Check_First_Subtype
(Arg1
);
23789 -- Check for too early or too late. Note that we don't enforce
23790 -- the rule about primitive operations in this case, since, as
23791 -- is the case for explicit stream attributes themselves, these
23792 -- restrictions are not appropriate. Note that the chaining of
23793 -- the pragma by Rep_Item_Too_Late is actually the critical
23794 -- processing done for this pragma.
23796 if Rep_Item_Too_Early
(Typ
, N
)
23798 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
23803 -- Return if previous error
23805 if Etype
(Typ
) = Any_Type
23807 Etype
(Read
) = Any_Type
23809 Etype
(Write
) = Any_Type
23816 if Underlying_Type
(Etype
(Read
)) /= Typ
then
23818 ("incorrect return type for function&", Arg2
);
23821 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
23823 ("incorrect parameter type for function&", Arg3
);
23826 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
23827 Underlying_Type
(Etype
(Write
))
23830 ("result type of & does not match Read parameter type",
23834 end Stream_Convert
;
23840 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23842 -- This is processed by the parser since some of the style checks
23843 -- take place during source scanning and parsing. This means that
23844 -- we don't need to issue error messages here.
23846 when Pragma_Style_Checks
=> Style_Checks
: declare
23847 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23853 Check_No_Identifiers
;
23855 -- Two argument form
23857 if Arg_Count
= 2 then
23858 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
23865 E_Id
:= Get_Pragma_Arg
(Arg2
);
23868 if not Is_Entity_Name
(E_Id
) then
23870 ("second argument of pragma% must be entity name",
23874 E
:= Entity
(E_Id
);
23876 if not Ignore_Style_Checks_Pragmas
then
23881 Set_Suppress_Style_Checks
23882 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
23883 exit when No
(Homonym
(E
));
23890 -- One argument form
23893 Check_Arg_Count
(1);
23895 if Nkind
(A
) = N_String_Literal
then
23899 Slen
: constant Natural := Natural (String_Length
(S
));
23900 Options
: String (1 .. Slen
);
23906 C
:= Get_String_Char
(S
, Pos
(J
));
23907 exit when not In_Character_Range
(C
);
23908 Options
(J
) := Get_Character
(C
);
23910 -- If at end of string, set options. As per discussion
23911 -- above, no need to check for errors, since we issued
23912 -- them in the parser.
23915 if not Ignore_Style_Checks_Pragmas
then
23916 Set_Style_Check_Options
(Options
);
23926 elsif Nkind
(A
) = N_Identifier
then
23927 if Chars
(A
) = Name_All_Checks
then
23928 if not Ignore_Style_Checks_Pragmas
then
23930 Set_GNAT_Style_Check_Options
;
23932 Set_Default_Style_Check_Options
;
23936 elsif Chars
(A
) = Name_On
then
23937 if not Ignore_Style_Checks_Pragmas
then
23938 Style_Check
:= True;
23941 elsif Chars
(A
) = Name_Off
then
23942 if not Ignore_Style_Checks_Pragmas
then
23943 Style_Check
:= False;
23954 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
23956 when Pragma_Subtitle
=>
23958 Check_Arg_Count
(1);
23959 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
23960 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23967 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
23969 when Pragma_Suppress
=>
23970 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
23976 -- pragma Suppress_All;
23978 -- The only check made here is that the pragma has no arguments.
23979 -- There are no placement rules, and the processing required (setting
23980 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
23981 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
23982 -- then creates and inserts a pragma Suppress (All_Checks).
23984 when Pragma_Suppress_All
=>
23986 Check_Arg_Count
(0);
23988 -------------------------
23989 -- Suppress_Debug_Info --
23990 -------------------------
23992 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
23994 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
23995 Nam_Id
: Entity_Id
;
23999 Check_Arg_Count
(1);
24000 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24001 Check_Arg_Is_Local_Name
(Arg1
);
24003 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
24005 -- A pragma that applies to a Ghost entity becomes Ghost for the
24006 -- purposes of legality checks and removal of ignored Ghost code.
24008 Mark_Ghost_Pragma
(N
, Nam_Id
);
24009 Set_Debug_Info_Off
(Nam_Id
);
24010 end Suppress_Debug_Info
;
24012 ----------------------------------
24013 -- Suppress_Exception_Locations --
24014 ----------------------------------
24016 -- pragma Suppress_Exception_Locations;
24018 when Pragma_Suppress_Exception_Locations
=>
24020 Check_Arg_Count
(0);
24021 Check_Valid_Configuration_Pragma
;
24022 Exception_Locations_Suppressed
:= True;
24024 -----------------------------
24025 -- Suppress_Initialization --
24026 -----------------------------
24028 -- pragma Suppress_Initialization ([Entity =>] type_Name);
24030 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
24036 Check_Arg_Count
(1);
24037 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24038 Check_Arg_Is_Local_Name
(Arg1
);
24040 E_Id
:= Get_Pragma_Arg
(Arg1
);
24042 if Etype
(E_Id
) = Any_Type
then
24046 E
:= Entity
(E_Id
);
24048 -- A pragma that applies to a Ghost entity becomes Ghost for the
24049 -- purposes of legality checks and removal of ignored Ghost code.
24051 Mark_Ghost_Pragma
(N
, E
);
24053 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
24055 ("pragma% requires variable, type or subtype", Arg1
);
24058 if Rep_Item_Too_Early
(E
, N
)
24060 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
24065 -- For incomplete/private type, set flag on full view
24067 if Is_Incomplete_Or_Private_Type
(E
) then
24068 if No
(Full_View
(Base_Type
(E
))) then
24070 ("argument of pragma% cannot be an incomplete type", Arg1
);
24072 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
24075 -- For first subtype, set flag on base type
24077 elsif Is_First_Subtype
(E
) then
24078 Set_Suppress_Initialization
(Base_Type
(E
));
24080 -- For other than first subtype, set flag on subtype or variable
24083 Set_Suppress_Initialization
(E
);
24091 -- pragma System_Name (DIRECT_NAME);
24093 -- Syntax check: one argument, which must be the identifier GNAT or
24094 -- the identifier GCC, no other identifiers are acceptable.
24096 when Pragma_System_Name
=>
24098 Check_No_Identifiers
;
24099 Check_Arg_Count
(1);
24100 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
24102 -----------------------------
24103 -- Task_Dispatching_Policy --
24104 -----------------------------
24106 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
24108 when Pragma_Task_Dispatching_Policy
=> declare
24112 Check_Ada_83_Warning
;
24113 Check_Arg_Count
(1);
24114 Check_No_Identifiers
;
24115 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
24116 Check_Valid_Configuration_Pragma
;
24117 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24118 DP
:= Fold_Upper
(Name_Buffer
(1));
24120 if Task_Dispatching_Policy
/= ' '
24121 and then Task_Dispatching_Policy
/= DP
24123 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
24125 ("task dispatching policy incompatible with policy#");
24127 -- Set new policy, but always preserve System_Location since we
24128 -- like the error message with the run time name.
24131 Task_Dispatching_Policy
:= DP
;
24133 if Task_Dispatching_Policy_Sloc
/= System_Location
then
24134 Task_Dispatching_Policy_Sloc
:= Loc
;
24143 -- pragma Task_Info (EXPRESSION);
24145 when Pragma_Task_Info
=> Task_Info
: declare
24146 P
: constant Node_Id
:= Parent
(N
);
24152 if Warn_On_Obsolescent_Feature
then
24154 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
24155 & "instead?j?", N
);
24158 if Nkind
(P
) /= N_Task_Definition
then
24159 Error_Pragma
("pragma% must appear in task definition");
24162 Check_No_Identifiers
;
24163 Check_Arg_Count
(1);
24165 Analyze_And_Resolve
24166 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
24168 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
24172 Ent
:= Defining_Identifier
(Parent
(P
));
24174 -- Check duplicate pragma before we chain the pragma in the Rep
24175 -- Item chain of Ent.
24178 (Ent
, Name_Task_Info
, Check_Parents
=> False)
24180 Error_Pragma
("duplicate pragma% not allowed");
24183 Record_Rep_Item
(Ent
, N
);
24190 -- pragma Task_Name (string_EXPRESSION);
24192 when Pragma_Task_Name
=> Task_Name
: declare
24193 P
: constant Node_Id
:= Parent
(N
);
24198 Check_No_Identifiers
;
24199 Check_Arg_Count
(1);
24201 Arg
:= Get_Pragma_Arg
(Arg1
);
24203 -- The expression is used in the call to Create_Task, and must be
24204 -- expanded there, not in the context of the current spec. It must
24205 -- however be analyzed to capture global references, in case it
24206 -- appears in a generic context.
24208 Preanalyze_And_Resolve
(Arg
, Standard_String
);
24210 if Nkind
(P
) /= N_Task_Definition
then
24214 Ent
:= Defining_Identifier
(Parent
(P
));
24216 -- Check duplicate pragma before we chain the pragma in the Rep
24217 -- Item chain of Ent.
24220 (Ent
, Name_Task_Name
, Check_Parents
=> False)
24222 Error_Pragma
("duplicate pragma% not allowed");
24225 Record_Rep_Item
(Ent
, N
);
24232 -- pragma Task_Storage (
24233 -- [Task_Type =>] LOCAL_NAME,
24234 -- [Top_Guard =>] static_integer_EXPRESSION);
24236 when Pragma_Task_Storage
=> Task_Storage
: declare
24237 Args
: Args_List
(1 .. 2);
24238 Names
: constant Name_List
(1 .. 2) := (
24242 Task_Type
: Node_Id
renames Args
(1);
24243 Top_Guard
: Node_Id
renames Args
(2);
24249 Gather_Associations
(Names
, Args
);
24251 if No
(Task_Type
) then
24253 ("missing task_type argument for pragma%");
24256 Check_Arg_Is_Local_Name
(Task_Type
);
24258 Ent
:= Entity
(Task_Type
);
24260 if not Is_Task_Type
(Ent
) then
24262 ("argument for pragma% must be task type", Task_Type
);
24265 if No
(Top_Guard
) then
24267 ("pragma% takes two arguments", Task_Type
);
24269 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
24272 Check_First_Subtype
(Task_Type
);
24274 if Rep_Item_Too_Late
(Ent
, N
) then
24283 -- pragma Test_Case
24284 -- ([Name =>] Static_String_EXPRESSION
24285 -- ,[Mode =>] MODE_TYPE
24286 -- [, Requires => Boolean_EXPRESSION]
24287 -- [, Ensures => Boolean_EXPRESSION]);
24289 -- MODE_TYPE ::= Nominal | Robustness
24291 -- Characteristics:
24293 -- * Analysis - The annotation undergoes initial checks to verify
24294 -- the legal placement and context. Secondary checks preanalyze the
24297 -- Analyze_Test_Case_In_Decl_Part
24299 -- * Expansion - None.
24301 -- * Template - The annotation utilizes the generic template of the
24302 -- related subprogram when it is:
24304 -- aspect on subprogram declaration
24306 -- The annotation must prepare its own template when it is:
24308 -- pragma on subprogram declaration
24310 -- * Globals - Capture of global references must occur after full
24313 -- * Instance - The annotation is instantiated automatically when
24314 -- the related generic subprogram is instantiated except for the
24315 -- "pragma on subprogram declaration" case. In that scenario the
24316 -- annotation must instantiate itself.
24318 when Pragma_Test_Case
=> Test_Case
: declare
24319 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
24320 -- Ensure that the contract of subprogram Subp_Id does not contain
24321 -- another Test_Case pragma with the same Name as the current one.
24323 -------------------------
24324 -- Check_Distinct_Name --
24325 -------------------------
24327 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
24328 Items
: constant Node_Id
:= Contract
(Subp_Id
);
24329 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
24333 -- Inspect all Test_Case pragma of the related subprogram
24334 -- looking for one with a duplicate "Name" argument.
24336 if Present
(Items
) then
24337 Prag
:= Contract_Test_Cases
(Items
);
24338 while Present
(Prag
) loop
24339 if Pragma_Name
(Prag
) = Name_Test_Case
24341 and then String_Equal
24342 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
24344 Error_Msg_Sloc
:= Sloc
(Prag
);
24345 Error_Pragma
("name for pragma % is already used #");
24348 Prag
:= Next_Pragma
(Prag
);
24351 end Check_Distinct_Name
;
24355 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
24358 Subp_Decl
: Node_Id
;
24359 Subp_Id
: Entity_Id
;
24361 -- Start of processing for Test_Case
24365 Check_At_Least_N_Arguments
(2);
24366 Check_At_Most_N_Arguments
(4);
24368 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
24372 Check_Optional_Identifier
(Arg1
, Name_Name
);
24373 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
24377 Check_Optional_Identifier
(Arg2
, Name_Mode
);
24378 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
24380 -- Arguments "Requires" and "Ensures"
24382 if Present
(Arg3
) then
24383 if Present
(Arg4
) then
24384 Check_Identifier
(Arg3
, Name_Requires
);
24385 Check_Identifier
(Arg4
, Name_Ensures
);
24387 Check_Identifier_Is_One_Of
24388 (Arg3
, Name_Requires
, Name_Ensures
);
24392 -- Pragma Test_Case must be associated with a subprogram declared
24393 -- in a library-level package. First determine whether the current
24394 -- compilation unit is a legal context.
24396 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
24397 N_Generic_Package_Declaration
)
24401 -- Otherwise the placement is illegal
24405 ("pragma % must be specified within a package declaration");
24409 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
24411 -- Find the enclosing context
24413 Context
:= Parent
(Subp_Decl
);
24415 if Present
(Context
) then
24416 Context
:= Parent
(Context
);
24419 -- Verify the placement of the pragma
24421 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
24423 ("pragma % cannot be applied to abstract subprogram");
24426 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
24427 Error_Pragma
("pragma % cannot be applied to entry");
24430 -- The context is a [generic] subprogram declared at the top level
24431 -- of the [generic] package unit.
24433 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
24434 N_Subprogram_Declaration
)
24435 and then Present
(Context
)
24436 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
24437 N_Package_Declaration
)
24441 -- Otherwise the placement is illegal
24445 ("pragma % must be applied to a library-level subprogram "
24450 Subp_Id
:= Defining_Entity
(Subp_Decl
);
24452 -- A pragma that applies to a Ghost entity becomes Ghost for the
24453 -- purposes of legality checks and removal of ignored Ghost code.
24455 Mark_Ghost_Pragma
(N
, Subp_Id
);
24457 -- Chain the pragma on the contract for further processing by
24458 -- Analyze_Test_Case_In_Decl_Part.
24460 Add_Contract_Item
(N
, Subp_Id
);
24462 -- Preanalyze the original aspect argument "Name" for ASIS or for
24463 -- a generic subprogram to properly capture global references.
24465 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
24466 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
24468 if Present
(Asp_Arg
) then
24470 -- The argument appears with an identifier in association
24473 if Nkind
(Asp_Arg
) = N_Component_Association
then
24474 Asp_Arg
:= Expression
(Asp_Arg
);
24477 Check_Expr_Is_OK_Static_Expression
24478 (Asp_Arg
, Standard_String
);
24482 -- Ensure that the all Test_Case pragmas of the related subprogram
24483 -- have distinct names.
24485 Check_Distinct_Name
(Subp_Id
);
24487 -- Fully analyze the pragma when it appears inside an entry
24488 -- or subprogram body because it cannot benefit from forward
24491 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
24493 N_Subprogram_Body_Stub
)
24495 -- The legality checks of pragma Test_Case are affected by the
24496 -- SPARK mode in effect and the volatility of the context.
24497 -- Analyze all pragmas in a specific order.
24499 Analyze_If_Present
(Pragma_SPARK_Mode
);
24500 Analyze_If_Present
(Pragma_Volatile_Function
);
24501 Analyze_Test_Case_In_Decl_Part
(N
);
24505 --------------------------
24506 -- Thread_Local_Storage --
24507 --------------------------
24509 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
24511 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
24517 Check_Arg_Count
(1);
24518 Check_Optional_Identifier
(Arg1
, Name_Entity
);
24519 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
24521 Id
:= Get_Pragma_Arg
(Arg1
);
24524 if not Is_Entity_Name
(Id
)
24525 or else Ekind
(Entity
(Id
)) /= E_Variable
24527 Error_Pragma_Arg
("local variable name required", Arg1
);
24532 -- A pragma that applies to a Ghost entity becomes Ghost for the
24533 -- purposes of legality checks and removal of ignored Ghost code.
24535 Mark_Ghost_Pragma
(N
, E
);
24537 if Rep_Item_Too_Early
(E
, N
)
24539 Rep_Item_Too_Late
(E
, N
)
24544 Set_Has_Pragma_Thread_Local_Storage
(E
);
24545 Set_Has_Gigi_Rep_Item
(E
);
24546 end Thread_Local_Storage
;
24552 -- pragma Time_Slice (static_duration_EXPRESSION);
24554 when Pragma_Time_Slice
=> Time_Slice
: declare
24560 Check_Arg_Count
(1);
24561 Check_No_Identifiers
;
24562 Check_In_Main_Program
;
24563 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
24565 if not Error_Posted
(Arg1
) then
24567 while Present
(Nod
) loop
24568 if Nkind
(Nod
) = N_Pragma
24569 and then Pragma_Name
(Nod
) = Name_Time_Slice
24571 Error_Msg_Name_1
:= Pname
;
24572 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
24579 -- Process only if in main unit
24581 if Get_Source_Unit
(Loc
) = Main_Unit
then
24582 Opt
.Time_Slice_Set
:= True;
24583 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
24585 if Val
<= Ureal_0
then
24586 Opt
.Time_Slice_Value
:= 0;
24588 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
24589 Opt
.Time_Slice_Value
:= 1_000_000_000
;
24592 Opt
.Time_Slice_Value
:=
24593 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
24602 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
24604 -- TITLING_OPTION ::=
24605 -- [Title =>] STRING_LITERAL
24606 -- | [Subtitle =>] STRING_LITERAL
24608 when Pragma_Title
=> Title
: declare
24609 Args
: Args_List
(1 .. 2);
24610 Names
: constant Name_List
(1 .. 2) := (
24616 Gather_Associations
(Names
, Args
);
24619 for J
in 1 .. 2 loop
24620 if Present
(Args
(J
)) then
24621 Check_Arg_Is_OK_Static_Expression
24622 (Args
(J
), Standard_String
);
24627 ----------------------------
24628 -- Type_Invariant[_Class] --
24629 ----------------------------
24631 -- pragma Type_Invariant[_Class]
24632 -- ([Entity =>] type_LOCAL_NAME,
24633 -- [Check =>] EXPRESSION);
24635 when Pragma_Type_Invariant
24636 | Pragma_Type_Invariant_Class
24638 Type_Invariant
: declare
24639 I_Pragma
: Node_Id
;
24642 Check_Arg_Count
(2);
24644 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
24645 -- setting Class_Present for the Type_Invariant_Class case.
24647 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
24648 I_Pragma
:= New_Copy
(N
);
24649 Set_Pragma_Identifier
24650 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
24651 Rewrite
(N
, I_Pragma
);
24652 Set_Analyzed
(N
, False);
24654 end Type_Invariant
;
24656 ---------------------
24657 -- Unchecked_Union --
24658 ---------------------
24660 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
24662 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
24663 Assoc
: constant Node_Id
:= Arg1
;
24664 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
24674 Check_No_Identifiers
;
24675 Check_Arg_Count
(1);
24676 Check_Arg_Is_Local_Name
(Arg1
);
24678 Find_Type
(Type_Id
);
24680 Typ
:= Entity
(Type_Id
);
24682 -- A pragma that applies to a Ghost entity becomes Ghost for the
24683 -- purposes of legality checks and removal of ignored Ghost code.
24685 Mark_Ghost_Pragma
(N
, Typ
);
24688 or else Rep_Item_Too_Early
(Typ
, N
)
24692 Typ
:= Underlying_Type
(Typ
);
24695 if Rep_Item_Too_Late
(Typ
, N
) then
24699 Check_First_Subtype
(Arg1
);
24701 -- Note remaining cases are references to a type in the current
24702 -- declarative part. If we find an error, we post the error on
24703 -- the relevant type declaration at an appropriate point.
24705 if not Is_Record_Type
(Typ
) then
24706 Error_Msg_N
("unchecked union must be record type", Typ
);
24709 elsif Is_Tagged_Type
(Typ
) then
24710 Error_Msg_N
("unchecked union must not be tagged", Typ
);
24713 elsif not Has_Discriminants
(Typ
) then
24715 ("unchecked union must have one discriminant", Typ
);
24718 -- Note: in previous versions of GNAT we used to check for limited
24719 -- types and give an error, but in fact the standard does allow
24720 -- Unchecked_Union on limited types, so this check was removed.
24722 -- Similarly, GNAT used to require that all discriminants have
24723 -- default values, but this is not mandated by the RM.
24725 -- Proceed with basic error checks completed
24728 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
24729 Clist
:= Component_List
(Tdef
);
24731 -- Check presence of component list and variant part
24733 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
24735 ("unchecked union must have variant part", Tdef
);
24739 -- Check components
24741 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
24742 while Present
(Comp
) loop
24743 Check_Component
(Comp
, Typ
);
24744 Next_Non_Pragma
(Comp
);
24747 -- Check variant part
24749 Vpart
:= Variant_Part
(Clist
);
24751 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
24752 while Present
(Variant
) loop
24753 Check_Variant
(Variant
, Typ
);
24754 Next_Non_Pragma
(Variant
);
24758 Set_Is_Unchecked_Union
(Typ
);
24759 Set_Convention
(Typ
, Convention_C
);
24760 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
24761 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
24762 end Unchecked_Union
;
24764 ----------------------------
24765 -- Unevaluated_Use_Of_Old --
24766 ----------------------------
24768 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
24770 when Pragma_Unevaluated_Use_Of_Old
=>
24772 Check_Arg_Count
(1);
24773 Check_No_Identifiers
;
24774 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
24776 -- Suppress/Unsuppress can appear as a configuration pragma, or in
24777 -- a declarative part or a package spec.
24779 if not Is_Configuration_Pragma
then
24780 Check_Is_In_Decl_Part_Or_Package_Spec
;
24783 -- Store proper setting of Uneval_Old
24785 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
24786 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
24788 ------------------------
24789 -- Unimplemented_Unit --
24790 ------------------------
24792 -- pragma Unimplemented_Unit;
24794 -- Note: this only gives an error if we are generating code, or if
24795 -- we are in a generic library unit (where the pragma appears in the
24796 -- body, not in the spec).
24798 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
24799 Cunitent
: constant Entity_Id
:=
24800 Cunit_Entity
(Get_Source_Unit
(Loc
));
24801 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
24805 Check_Arg_Count
(0);
24807 if Operating_Mode
= Generate_Code
24808 or else Ent_Kind
= E_Generic_Function
24809 or else Ent_Kind
= E_Generic_Procedure
24810 or else Ent_Kind
= E_Generic_Package
24812 Get_Name_String
(Chars
(Cunitent
));
24813 Set_Casing
(Mixed_Case
);
24814 Write_Str
(Name_Buffer
(1 .. Name_Len
));
24815 Write_Str
(" is not supported in this configuration");
24817 raise Unrecoverable_Error
;
24819 end Unimplemented_Unit
;
24821 ------------------------
24822 -- Universal_Aliasing --
24823 ------------------------
24825 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
24827 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
24833 Check_Arg_Count
(1);
24834 Check_Optional_Identifier
(Arg2
, Name_Entity
);
24835 Check_Arg_Is_Local_Name
(Arg1
);
24836 E_Id
:= Get_Pragma_Arg
(Arg1
);
24838 if Etype
(E_Id
) = Any_Type
then
24842 E
:= Entity
(E_Id
);
24844 if not Is_Type
(E
) then
24845 Error_Pragma_Arg
("pragma% requires type", Arg1
);
24848 -- A pragma that applies to a Ghost entity becomes Ghost for the
24849 -- purposes of legality checks and removal of ignored Ghost code.
24851 Mark_Ghost_Pragma
(N
, E
);
24852 Set_Universal_Aliasing
(Base_Type
(E
));
24853 Record_Rep_Item
(E
, N
);
24854 end Universal_Alias
;
24856 --------------------
24857 -- Universal_Data --
24858 --------------------
24860 -- pragma Universal_Data [(library_unit_NAME)];
24862 when Pragma_Universal_Data
=>
24864 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
24870 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
24872 when Pragma_Unmodified
=>
24873 Analyze_Unmodified_Or_Unused
;
24879 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
24881 -- or when used in a context clause:
24883 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
24885 when Pragma_Unreferenced
=>
24886 Analyze_Unreferenced_Or_Unused
;
24888 --------------------------
24889 -- Unreferenced_Objects --
24890 --------------------------
24892 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
24894 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
24896 Arg_Expr
: Node_Id
;
24897 Arg_Id
: Entity_Id
;
24899 Ghost_Error_Posted
: Boolean := False;
24900 -- Flag set when an error concerning the illegal mix of Ghost and
24901 -- non-Ghost types is emitted.
24903 Ghost_Id
: Entity_Id
:= Empty
;
24904 -- The entity of the first Ghost type encountered while processing
24905 -- the arguments of the pragma.
24909 Check_At_Least_N_Arguments
(1);
24912 while Present
(Arg
) loop
24913 Check_No_Identifier
(Arg
);
24914 Check_Arg_Is_Local_Name
(Arg
);
24915 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
24917 if Is_Entity_Name
(Arg_Expr
) then
24918 Arg_Id
:= Entity
(Arg_Expr
);
24920 if Is_Type
(Arg_Id
) then
24921 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
24923 -- A pragma that applies to a Ghost entity becomes Ghost
24924 -- for the purposes of legality checks and removal of
24925 -- ignored Ghost code.
24927 Mark_Ghost_Pragma
(N
, Arg_Id
);
24929 -- Capture the entity of the first Ghost type being
24930 -- processed for error detection purposes.
24932 if Is_Ghost_Entity
(Arg_Id
) then
24933 if No
(Ghost_Id
) then
24934 Ghost_Id
:= Arg_Id
;
24937 -- Otherwise the type is non-Ghost. It is illegal to mix
24938 -- references to Ghost and non-Ghost entities
24941 elsif Present
(Ghost_Id
)
24942 and then not Ghost_Error_Posted
24944 Ghost_Error_Posted
:= True;
24946 Error_Msg_Name_1
:= Pname
;
24948 ("pragma % cannot mention ghost and non-ghost types",
24951 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
24952 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
24954 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
24955 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
24959 ("argument for pragma% must be type or subtype", Arg
);
24963 ("argument for pragma% must be type or subtype", Arg
);
24968 end Unreferenced_Objects
;
24970 ------------------------------
24971 -- Unreserve_All_Interrupts --
24972 ------------------------------
24974 -- pragma Unreserve_All_Interrupts;
24976 when Pragma_Unreserve_All_Interrupts
=>
24978 Check_Arg_Count
(0);
24980 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
24981 Unreserve_All_Interrupts
:= True;
24988 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
24990 when Pragma_Unsuppress
=>
24992 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
24998 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
25000 when Pragma_Unused
=>
25001 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
25002 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
25004 -------------------
25005 -- Use_VADS_Size --
25006 -------------------
25008 -- pragma Use_VADS_Size;
25010 when Pragma_Use_VADS_Size
=>
25012 Check_Arg_Count
(0);
25013 Check_Valid_Configuration_Pragma
;
25014 Use_VADS_Size
:= True;
25016 ---------------------
25017 -- Validity_Checks --
25018 ---------------------
25020 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
25022 when Pragma_Validity_Checks
=> Validity_Checks
: declare
25023 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
25029 Check_Arg_Count
(1);
25030 Check_No_Identifiers
;
25032 -- Pragma always active unless in CodePeer or GNATprove modes,
25033 -- which use a fixed configuration of validity checks.
25035 if not (CodePeer_Mode
or GNATprove_Mode
) then
25036 if Nkind
(A
) = N_String_Literal
then
25040 Slen
: constant Natural := Natural (String_Length
(S
));
25041 Options
: String (1 .. Slen
);
25045 -- Couldn't we use a for loop here over Options'Range???
25049 C
:= Get_String_Char
(S
, Pos
(J
));
25051 -- This is a weird test, it skips setting validity
25052 -- checks entirely if any element of S is out of
25053 -- range of Character, what is that about ???
25055 exit when not In_Character_Range
(C
);
25056 Options
(J
) := Get_Character
(C
);
25059 Set_Validity_Check_Options
(Options
);
25067 elsif Nkind
(A
) = N_Identifier
then
25068 if Chars
(A
) = Name_All_Checks
then
25069 Set_Validity_Check_Options
("a");
25070 elsif Chars
(A
) = Name_On
then
25071 Validity_Checks_On
:= True;
25072 elsif Chars
(A
) = Name_Off
then
25073 Validity_Checks_On
:= False;
25077 end Validity_Checks
;
25083 -- pragma Volatile (LOCAL_NAME);
25085 when Pragma_Volatile
=>
25086 Process_Atomic_Independent_Shared_Volatile
;
25088 -------------------------
25089 -- Volatile_Components --
25090 -------------------------
25092 -- pragma Volatile_Components (array_LOCAL_NAME);
25094 -- Volatile is handled by the same circuit as Atomic_Components
25096 --------------------------
25097 -- Volatile_Full_Access --
25098 --------------------------
25100 -- pragma Volatile_Full_Access (LOCAL_NAME);
25102 when Pragma_Volatile_Full_Access
=>
25104 Process_Atomic_Independent_Shared_Volatile
;
25106 -----------------------
25107 -- Volatile_Function --
25108 -----------------------
25110 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
25112 when Pragma_Volatile_Function
=> Volatile_Function
: declare
25113 Over_Id
: Entity_Id
;
25114 Spec_Id
: Entity_Id
;
25115 Subp_Decl
: Node_Id
;
25119 Check_No_Identifiers
;
25120 Check_At_Most_N_Arguments
(1);
25123 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
25125 -- Generic subprogram
25127 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
25130 -- Body acts as spec
25132 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
25133 and then No
(Corresponding_Spec
(Subp_Decl
))
25137 -- Body stub acts as spec
25139 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
25140 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
25146 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
25154 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
25156 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
25161 -- A pragma that applies to a Ghost entity becomes Ghost for the
25162 -- purposes of legality checks and removal of ignored Ghost code.
25164 Mark_Ghost_Pragma
(N
, Spec_Id
);
25166 -- Chain the pragma on the contract for completeness
25168 Add_Contract_Item
(N
, Spec_Id
);
25170 -- The legality checks of pragma Volatile_Function are affected by
25171 -- the SPARK mode in effect. Analyze all pragmas in a specific
25174 Analyze_If_Present
(Pragma_SPARK_Mode
);
25176 -- A volatile function cannot override a non-volatile function
25177 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
25178 -- in New_Overloaded_Entity, however at that point the pragma has
25179 -- not been processed yet.
25181 Over_Id
:= Overridden_Operation
(Spec_Id
);
25183 if Present
(Over_Id
)
25184 and then not Is_Volatile_Function
(Over_Id
)
25187 ("incompatible volatile function values in effect", Spec_Id
);
25189 Error_Msg_Sloc
:= Sloc
(Over_Id
);
25191 ("\& declared # with Volatile_Function value False",
25194 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
25196 ("\overridden # with Volatile_Function value True",
25200 -- Analyze the Boolean expression (if any)
25202 if Present
(Arg1
) then
25203 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
25205 end Volatile_Function
;
25207 ----------------------
25208 -- Warning_As_Error --
25209 ----------------------
25211 -- pragma Warning_As_Error (static_string_EXPRESSION);
25213 when Pragma_Warning_As_Error
=>
25215 Check_Arg_Count
(1);
25216 Check_No_Identifiers
;
25217 Check_Valid_Configuration_Pragma
;
25219 if not Is_Static_String_Expression
(Arg1
) then
25221 ("argument of pragma% must be static string expression",
25224 -- OK static string expression
25227 Acquire_Warning_Match_String
(Arg1
);
25228 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
25229 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
25230 new String'(Name_Buffer (1 .. Name_Len));
25237 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
25239 -- DETAILS ::= On | Off
25240 -- DETAILS ::= On | Off, local_NAME
25241 -- DETAILS ::= static_string_EXPRESSION
25242 -- DETAILS ::= On | Off, static_string_EXPRESSION
25244 -- TOOL_NAME ::= GNAT | GNATProve
25246 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
25248 -- Note: If the first argument matches an allowed tool name, it is
25249 -- always considered to be a tool name, even if there is a string
25250 -- variable of that name.
25252 -- Note if the second argument of DETAILS is a local_NAME then the
25253 -- second form is always understood. If the intention is to use
25254 -- the fourth form, then you can write NAME & "" to force the
25255 -- intepretation as a static_string_EXPRESSION.
25257 when Pragma_Warnings => Warnings : declare
25258 Reason : String_Id;
25262 Check_At_Least_N_Arguments (1);
25264 -- See if last argument is labeled Reason. If so, make sure we
25265 -- have a string literal or a concatenation of string literals,
25266 -- and acquire the REASON string. Then remove the REASON argument
25267 -- by decreasing Num_Args by one; Remaining processing looks only
25268 -- at first Num_Args arguments).
25271 Last_Arg : constant Node_Id :=
25272 Last (Pragma_Argument_Associations (N));
25275 if Nkind (Last_Arg) = N_Pragma_Argument_Association
25276 and then Chars (Last_Arg) = Name_Reason
25279 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
25280 Reason := End_String;
25281 Arg_Count := Arg_Count - 1;
25283 -- Not allowed in compiler units (bootstrap issues)
25285 Check_Compiler_Unit ("Reason for pragma Warnings", N);
25287 -- No REASON string, set null string as reason
25290 Reason := Null_String_Id;
25294 -- Now proceed with REASON taken care of and eliminated
25296 Check_No_Identifiers;
25298 -- If debug flag -gnatd.i is set, pragma is ignored
25300 if Debug_Flag_Dot_I then
25304 -- Process various forms of the pragma
25307 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
25308 Shifted_Args : List_Id;
25311 -- See if first argument is a tool name, currently either
25312 -- GNAT or GNATprove. If so, either ignore the pragma if the
25313 -- tool used does not match, or continue as if no tool name
25314 -- was given otherwise, by shifting the arguments.
25316 if Nkind (Argx) = N_Identifier
25317 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
25319 if Chars (Argx) = Name_Gnat then
25320 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
25321 Rewrite (N, Make_Null_Statement (Loc));
25326 elsif Chars (Argx) = Name_Gnatprove then
25327 if not GNATprove_Mode then
25328 Rewrite (N, Make_Null_Statement (Loc));
25334 raise Program_Error;
25337 -- At this point, the pragma Warnings applies to the tool,
25338 -- so continue with shifted arguments.
25340 Arg_Count := Arg_Count - 1;
25342 if Arg_Count = 1 then
25343 Shifted_Args := New_List (New_Copy (Arg2));
25344 elsif Arg_Count = 2 then
25345 Shifted_Args := New_List (New_Copy (Arg2),
25347 elsif Arg_Count = 3 then
25348 Shifted_Args := New_List (New_Copy (Arg2),
25352 raise Program_Error;
25357 Chars => Name_Warnings,
25358 Pragma_Argument_Associations => Shifted_Args));
25363 -- One argument case
25365 if Arg_Count = 1 then
25367 -- On/Off one argument case was processed by parser
25369 if Nkind (Argx) = N_Identifier
25370 and then Nam_In (Chars (Argx), Name_On, Name_Off)
25374 -- One argument case must be ON/OFF or static string expr
25376 elsif not Is_Static_String_Expression (Arg1) then
25378 ("argument of pragma% must be On/Off or static string "
25379 & "expression", Arg1);
25381 -- One argument string expression case
25385 Lit : constant Node_Id := Expr_Value_S (Argx);
25386 Str : constant String_Id := Strval (Lit);
25387 Len : constant Nat := String_Length (Str);
25395 while J <= Len loop
25396 C := Get_String_Char (Str, J);
25397 OK := In_Character_Range (C);
25400 Chr := Get_Character (C);
25402 -- Dash case: only -Wxxx is accepted
25409 C := Get_String_Char (Str, J);
25410 Chr := Get_Character (C);
25411 exit when Chr = 'W
';
25416 elsif J < Len and then Chr = '.' then
25418 C := Get_String_Char (Str, J);
25419 Chr := Get_Character (C);
25421 if not Set_Dot_Warning_Switch (Chr) then
25423 ("invalid warning switch character "
25424 & '.' & Chr, Arg1);
25430 OK := Set_Warning_Switch (Chr);
25435 ("invalid warning switch character " & Chr,
25441 ("invalid wide character in warning switch ",
25450 -- Two or more arguments (must be two)
25453 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
25454 Check_Arg_Count (2);
25462 E_Id := Get_Pragma_Arg (Arg2);
25465 -- In the expansion of an inlined body, a reference to
25466 -- the formal may be wrapped in a conversion if the
25467 -- actual is a conversion. Retrieve the real entity name.
25469 if (In_Instance_Body or In_Inlined_Body)
25470 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
25472 E_Id := Expression (E_Id);
25475 -- Entity name case
25477 if Is_Entity_Name (E_Id) then
25478 E := Entity (E_Id);
25485 (E, (Chars (Get_Pragma_Arg (Arg1)) =
25488 -- Suppress elaboration warnings if the entity
25489 -- denotes an elaboration target.
25491 if Is_Elaboration_Target (E) then
25492 Set_Is_Elaboration_Warnings_OK_Id (E, False);
25495 -- For OFF case, make entry in warnings off
25496 -- pragma table for later processing. But we do
25497 -- not do that within an instance, since these
25498 -- warnings are about what is needed in the
25499 -- template, not an instance of it.
25501 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
25502 and then Warn_On_Warnings_Off
25503 and then not In_Instance
25505 Warnings_Off_Pragmas.Append ((N, E, Reason));
25508 if Is_Enumeration_Type (E) then
25512 Lit := First_Literal (E);
25513 while Present (Lit) loop
25514 Set_Warnings_Off (Lit);
25515 Next_Literal (Lit);
25520 exit when No (Homonym (E));
25525 -- Error if not entity or static string expression case
25527 elsif not Is_Static_String_Expression (Arg2) then
25529 ("second argument of pragma% must be entity name "
25530 & "or static string expression", Arg2);
25532 -- Static string expression case
25535 Acquire_Warning_Match_String (Arg2);
25537 -- Note on configuration pragma case: If this is a
25538 -- configuration pragma, then for an OFF pragma, we
25539 -- just set Config True in the call, which is all
25540 -- that needs to be done. For the case of ON, this
25541 -- is normally an error, unless it is canceling the
25542 -- effect of a previous OFF pragma in the same file.
25543 -- In any other case, an error will be signalled (ON
25544 -- with no matching OFF).
25546 -- Note: We set Used if we are inside a generic to
25547 -- disable the test that the non-config case actually
25548 -- cancels a warning. That's because we can't be sure
25549 -- there isn't an instantiation in some other unit
25550 -- where a warning is suppressed.
25552 -- We could do a little better here by checking if the
25553 -- generic unit we are inside is public, but for now
25554 -- we don't bother with that refinement.
25556 if Chars (Argx) = Name_Off then
25557 Set_Specific_Warning_Off
25558 (Loc, Name_Buffer (1 .. Name_Len), Reason,
25559 Config => Is_Configuration_Pragma,
25560 Used => Inside_A_Generic or else In_Instance);
25562 elsif Chars (Argx) = Name_On then
25563 Set_Specific_Warning_On
25564 (Loc, Name_Buffer (1 .. Name_Len), Err);
25568 ("??pragma Warnings On with no matching "
25569 & "Warnings Off", Loc);
25578 -------------------
25579 -- Weak_External --
25580 -------------------
25582 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
25584 when Pragma_Weak_External => Weak_External : declare
25589 Check_Arg_Count (1);
25590 Check_Optional_Identifier (Arg1, Name_Entity);
25591 Check_Arg_Is_Library_Level_Local_Name (Arg1);
25592 Ent := Entity (Get_Pragma_Arg (Arg1));
25594 if Rep_Item_Too_Early (Ent, N) then
25597 Ent := Underlying_Type (Ent);
25600 -- The only processing required is to link this item on to the
25601 -- list of rep items for the given entity. This is accomplished
25602 -- by the call to Rep_Item_Too_Late (when no error is detected
25603 -- and False is returned).
25605 if Rep_Item_Too_Late (Ent, N) then
25608 Set_Has_Gigi_Rep_Item (Ent);
25612 -----------------------------
25613 -- Wide_Character_Encoding --
25614 -----------------------------
25616 -- pragma Wide_Character_Encoding (IDENTIFIER);
25618 when Pragma_Wide_Character_Encoding =>
25621 -- Nothing to do, handled in parser. Note that we do not enforce
25622 -- configuration pragma placement, this pragma can appear at any
25623 -- place in the source, allowing mixed encodings within a single
25628 --------------------
25629 -- Unknown_Pragma --
25630 --------------------
25632 -- Should be impossible, since the case of an unknown pragma is
25633 -- separately processed before the case statement is entered.
25635 when Unknown_Pragma =>
25636 raise Program_Error;
25639 -- AI05-0144: detect dangerous order dependence. Disabled for now,
25640 -- until AI is formally approved.
25642 -- Check_Order_Dependence;
25645 when Pragma_Exit => null;
25646 end Analyze_Pragma;
25648 ---------------------------------------------
25649 -- Analyze_Pre_Post_Condition_In_Decl_Part --
25650 ---------------------------------------------
25652 -- WARNING: This routine manages Ghost regions. Return statements must be
25653 -- replaced by gotos which jump to the end of the routine and restore the
25656 procedure Analyze_Pre_Post_Condition_In_Decl_Part
25658 Freeze_Id : Entity_Id := Empty)
25660 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
25661 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
25663 Disp_Typ : Entity_Id;
25664 -- The dispatching type of the subprogram subject to the pre- or
25667 function Check_References (Nod : Node_Id) return Traverse_Result;
25668 -- Check that expression Nod does not mention non-primitives of the
25669 -- type, global objects of the type, or other illegalities described
25670 -- and implied by AI12-0113.
25672 ----------------------
25673 -- Check_References --
25674 ----------------------
25676 function Check_References (Nod : Node_Id) return Traverse_Result is
25678 if Nkind (Nod) = N_Function_Call
25679 and then Is_Entity_Name (Name (Nod))
25682 Func : constant Entity_Id := Entity (Name (Nod));
25686 -- An operation of the type must be a primitive
25688 if No (Find_Dispatching_Type (Func)) then
25689 Form := First_Formal (Func);
25690 while Present (Form) loop
25691 if Etype (Form) = Disp_Typ then
25693 ("operation in class-wide condition must be "
25694 & "primitive of &", Nod, Disp_Typ);
25697 Next_Formal (Form);
25700 -- A return object of the type is illegal as well
25702 if Etype (Func) = Disp_Typ
25703 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
25706 ("operation in class-wide condition must be primitive "
25707 & "of &", Nod, Disp_Typ);
25710 -- Otherwise we have a call to an overridden primitive, and we
25711 -- will create a common class-wide clone for the body of
25712 -- original operation and its eventual inherited versions. If
25713 -- the original operation dispatches on result it is never
25714 -- inherited and there is no need for a clone. There is not
25715 -- need for a clone either in GNATprove mode, as cases that
25716 -- would require it are rejected (when an inherited primitive
25717 -- calls an overridden operation in a class-wide contract), and
25718 -- the clone would make proof impossible in some cases.
25720 elsif not Is_Abstract_Subprogram (Spec_Id)
25721 and then No (Class_Wide_Clone (Spec_Id))
25722 and then not Has_Controlling_Result (Spec_Id)
25723 and then not GNATprove_Mode
25725 Build_Class_Wide_Clone_Decl (Spec_Id);
25729 elsif Is_Entity_Name (Nod)
25731 (Etype (Nod) = Disp_Typ
25732 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25733 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
25736 ("object in class-wide condition must be formal of type &",
25739 elsif Nkind (Nod) = N_Explicit_Dereference
25740 and then (Etype (Nod) = Disp_Typ
25741 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
25742 and then (not Is_Entity_Name (Prefix (Nod))
25743 or else not Is_Formal (Entity (Prefix (Nod))))
25746 ("operation in class-wide condition must be primitive of &",
25751 end Check_References;
25753 procedure Check_Class_Wide_Condition is
25754 new Traverse_Proc (Check_References);
25758 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
25760 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
25761 Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
25762 -- Save the Ghost-related attributes to restore on exit
25765 Restore_Scope : Boolean := False;
25767 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
25770 -- Do not analyze the pragma multiple times
25772 if Is_Analyzed_Pragma (N) then
25776 -- Set the Ghost mode in effect from the pragma. Due to the delayed
25777 -- analysis of the pragma, the Ghost mode at point of declaration and
25778 -- point of analysis may not necessarily be the same. Use the mode in
25779 -- effect at the point of declaration.
25781 Set_Ghost_Mode (N);
25783 -- Ensure that the subprogram and its formals are visible when analyzing
25784 -- the expression of the pragma.
25786 if not In_Open_Scopes (Spec_Id) then
25787 Restore_Scope := True;
25788 Push_Scope (Spec_Id);
25790 if Is_Generic_Subprogram (Spec_Id) then
25791 Install_Generic_Formals (Spec_Id);
25793 Install_Formals (Spec_Id);
25797 Errors := Serious_Errors_Detected;
25798 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
25800 -- Emit a clarification message when the expression contains at least
25801 -- one undefined reference, possibly due to contract freezing.
25803 if Errors /= Serious_Errors_Detected
25804 and then Present (Freeze_Id)
25805 and then Has_Undefined_Reference (Expr)
25807 Contract_Freeze_Error (Spec_Id, Freeze_Id);
25810 if Class_Present (N) then
25812 -- Verify that a class-wide condition is legal, i.e. the operation is
25813 -- a primitive of a tagged type. Note that a generic subprogram is
25814 -- not a primitive operation.
25816 Disp_Typ := Find_Dispatching_Type (Spec_Id);
25818 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
25819 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
25821 if From_Aspect_Specification (N) then
25823 ("aspect % can only be specified for a primitive operation "
25824 & "of a tagged type", Corresponding_Aspect (N));
25826 -- The pragma is a source construct
25830 ("pragma % can only be specified for a primitive operation "
25831 & "of a tagged type", N);
25834 -- Remaining semantic checks require a full tree traversal
25837 Check_Class_Wide_Condition (Expr);
25842 if Restore_Scope then
25846 -- If analysis of the condition indicates that a class-wide clone
25847 -- has been created, build and analyze its declaration.
25849 if Is_Subprogram (Spec_Id)
25850 and then Present (Class_Wide_Clone (Spec_Id))
25852 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
25855 -- Currently it is not possible to inline pre/postconditions on a
25856 -- subprogram subject to pragma Inline_Always.
25858 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
25859 Set_Is_Analyzed_Pragma (N);
25861 Restore_Ghost_Region (Saved_GM, Saved_IGR);
25862 end Analyze_Pre_Post_Condition_In_Decl_Part;
25864 ------------------------------------------
25865 -- Analyze_Refined_Depends_In_Decl_Part --
25866 ------------------------------------------
25868 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
25869 procedure Check_Dependency_Clause
25870 (Spec_Id : Entity_Id;
25871 Dep_Clause : Node_Id;
25872 Dep_States : Elist_Id;
25873 Refinements : List_Id;
25874 Matched_Items : in out Elist_Id);
25875 -- Try to match a single dependency clause Dep_Clause against one or
25876 -- more refinement clauses found in list Refinements. Each successful
25877 -- match eliminates at least one refinement clause from Refinements.
25878 -- Spec_Id denotes the entity of the related subprogram. Dep_States
25879 -- denotes the entities of all abstract states which appear in pragma
25880 -- Depends. Matched_Items contains the entities of all successfully
25881 -- matched items found in pragma Depends.
25883 procedure Check_Output_States
25884 (Spec_Id : Entity_Id;
25885 Spec_Inputs : Elist_Id;
25886 Spec_Outputs : Elist_Id;
25887 Body_Inputs : Elist_Id;
25888 Body_Outputs : Elist_Id);
25889 -- Determine whether pragma Depends contains an output state with a
25890 -- visible refinement and if so, ensure that pragma Refined_Depends
25891 -- mentions all its constituents as outputs. Spec_Id is the entity of
25892 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
25893 -- inputs and outputs of the subprogram spec synthesized from pragma
25894 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
25895 -- of the subprogram body synthesized from pragma Refined_Depends.
25897 function Collect_States (Clauses : List_Id) return Elist_Id;
25898 -- Given a normalized list of dependencies obtained from calling
25899 -- Normalize_Clauses, return a list containing the entities of all
25900 -- states appearing in dependencies. It helps in checking refinements
25901 -- involving a state and a corresponding constituent which is not a
25902 -- direct constituent of the state.
25904 procedure Normalize_Clauses (Clauses : List_Id);
25905 -- Given a list of dependence or refinement clauses Clauses, normalize
25906 -- each clause by creating multiple dependencies with exactly one input
25909 procedure Remove_Extra_Clauses
25910 (Clauses : List_Id;
25911 Matched_Items : Elist_Id);
25912 -- Given a list of refinement clauses Clauses, remove all clauses whose
25913 -- inputs and/or outputs have been previously matched. See the body for
25914 -- all special cases. Matched_Items contains the entities of all matched
25915 -- items found in pragma Depends.
25917 procedure Report_Extra_Clauses
25918 (Spec_Id : Entity_Id;
25919 Clauses : List_Id);
25920 -- Emit an error for each extra clause found in list Clauses. Spec_Id
25921 -- denotes the entity of the related subprogram.
25923 -----------------------------
25924 -- Check_Dependency_Clause --
25925 -----------------------------
25927 procedure Check_Dependency_Clause
25928 (Spec_Id : Entity_Id;
25929 Dep_Clause : Node_Id;
25930 Dep_States : Elist_Id;
25931 Refinements : List_Id;
25932 Matched_Items : in out Elist_Id)
25934 Dep_Input : constant Node_Id := Expression (Dep_Clause);
25935 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
25937 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
25938 -- Determine whether dependency item Dep_Item has been matched in a
25939 -- previous clause.
25941 function Is_In_Out_State_Clause return Boolean;
25942 -- Determine whether dependence clause Dep_Clause denotes an abstract
25943 -- state that depends on itself (State => State).
25945 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
25946 -- Determine whether item Item denotes an abstract state with visible
25947 -- null refinement.
25949 procedure Match_Items
25950 (Dep_Item : Node_Id;
25951 Ref_Item : Node_Id;
25952 Matched : out Boolean);
25953 -- Try to match dependence item Dep_Item against refinement item
25954 -- Ref_Item. To match against a possible null refinement (see 2, 9),
25955 -- set Ref_Item to Empty. Flag Matched is set to True when one of
25956 -- the following conformance scenarios is in effect:
25957 -- 1) Both items denote null
25958 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
25959 -- 3) Both items denote attribute 'Result
25960 -- 4) Both items denote the same object
25961 -- 5) Both items denote the same formal parameter
25962 -- 6) Both items denote the same current instance of a type
25963 -- 7) Both items denote the same discriminant
25964 -- 8) Dep_Item is an abstract state with visible null refinement
25965 -- and Ref_Item denotes null.
25966 -- 9) Dep_Item is an abstract state with visible null refinement
25967 -- and Ref_Item is Empty (special case).
25968 -- 10) Dep_Item is an abstract state with full or partial visible
25969 -- non-null refinement and Ref_Item denotes one of its
25971 -- 11) Dep_Item is an abstract state without a full visible
25972 -- refinement and Ref_Item denotes the same state.
25973 -- When scenario 10 is in effect, the entity of the abstract state
25974 -- denoted by Dep_Item is added to list Refined_States.
25976 procedure Record_Item
(Item_Id
: Entity_Id
);
25977 -- Store the entity of an item denoted by Item_Id in Matched_Items
25979 ------------------------
25980 -- Is_Already_Matched --
25981 ------------------------
25983 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
25984 Item_Id
: Entity_Id
:= Empty
;
25987 -- When the dependency item denotes attribute 'Result, check for
25988 -- the entity of the related subprogram.
25990 if Is_Attribute_Result
(Dep_Item
) then
25991 Item_Id
:= Spec_Id
;
25993 elsif Is_Entity_Name
(Dep_Item
) then
25994 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
25998 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
25999 end Is_Already_Matched
;
26001 ----------------------------
26002 -- Is_In_Out_State_Clause --
26003 ----------------------------
26005 function Is_In_Out_State_Clause
return Boolean is
26006 Dep_Input_Id
: Entity_Id
;
26007 Dep_Output_Id
: Entity_Id
;
26010 -- Detect the following clause:
26013 if Is_Entity_Name
(Dep_Input
)
26014 and then Is_Entity_Name
(Dep_Output
)
26016 -- Handle abstract views generated for limited with clauses
26018 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
26019 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
26022 Ekind
(Dep_Input_Id
) = E_Abstract_State
26023 and then Dep_Input_Id
= Dep_Output_Id
;
26027 end Is_In_Out_State_Clause
;
26029 ---------------------------
26030 -- Is_Null_Refined_State --
26031 ---------------------------
26033 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
26034 Item_Id
: Entity_Id
;
26037 if Is_Entity_Name
(Item
) then
26039 -- Handle abstract views generated for limited with clauses
26041 Item_Id
:= Available_View
(Entity_Of
(Item
));
26044 Ekind
(Item_Id
) = E_Abstract_State
26045 and then Has_Null_Visible_Refinement
(Item_Id
);
26049 end Is_Null_Refined_State
;
26055 procedure Match_Items
26056 (Dep_Item
: Node_Id
;
26057 Ref_Item
: Node_Id
;
26058 Matched
: out Boolean)
26060 Dep_Item_Id
: Entity_Id
;
26061 Ref_Item_Id
: Entity_Id
;
26064 -- Assume that the two items do not match
26068 -- A null matches null or Empty (special case)
26070 if Nkind
(Dep_Item
) = N_Null
26071 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26075 -- Attribute 'Result matches attribute 'Result
26077 elsif Is_Attribute_Result
(Dep_Item
)
26078 and then Is_Attribute_Result
(Ref_Item
)
26080 -- Put the entity of the related function on the list of
26081 -- matched items because attribute 'Result does not carry
26082 -- an entity similar to states and constituents.
26084 Record_Item
(Spec_Id
);
26087 -- Abstract states, current instances of concurrent types,
26088 -- discriminants, formal parameters and objects.
26090 elsif Is_Entity_Name
(Dep_Item
) then
26092 -- Handle abstract views generated for limited with clauses
26094 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
26096 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
26098 -- An abstract state with visible null refinement matches
26099 -- null or Empty (special case).
26101 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
26102 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
26104 Record_Item
(Dep_Item_Id
);
26107 -- An abstract state with visible non-null refinement
26108 -- matches one of its constituents, or itself for an
26109 -- abstract state with partial visible refinement.
26111 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
26112 if Is_Entity_Name
(Ref_Item
) then
26113 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
26115 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
26118 and then Present
(Encapsulating_State
(Ref_Item_Id
))
26119 and then Find_Encapsulating_State
26120 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
26122 Record_Item
(Dep_Item_Id
);
26125 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
26126 and then Ref_Item_Id
= Dep_Item_Id
26128 Record_Item
(Dep_Item_Id
);
26133 -- An abstract state without a visible refinement matches
26136 elsif Is_Entity_Name
(Ref_Item
)
26137 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26139 Record_Item
(Dep_Item_Id
);
26143 -- A current instance of a concurrent type, discriminant,
26144 -- formal parameter or an object matches itself.
26146 elsif Is_Entity_Name
(Ref_Item
)
26147 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
26149 Record_Item
(Dep_Item_Id
);
26159 procedure Record_Item
(Item_Id
: Entity_Id
) is
26161 if No
(Matched_Items
) then
26162 Matched_Items
:= New_Elmt_List
;
26165 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
26170 Clause_Matched
: Boolean := False;
26171 Dummy
: Boolean := False;
26172 Inputs_Match
: Boolean;
26173 Next_Ref_Clause
: Node_Id
;
26174 Outputs_Match
: Boolean;
26175 Ref_Clause
: Node_Id
;
26176 Ref_Input
: Node_Id
;
26177 Ref_Output
: Node_Id
;
26179 -- Start of processing for Check_Dependency_Clause
26182 -- Do not perform this check in an instance because it was already
26183 -- performed successfully in the generic template.
26185 if Is_Generic_Instance
(Spec_Id
) then
26189 -- Examine all refinement clauses and compare them against the
26190 -- dependence clause.
26192 Ref_Clause
:= First
(Refinements
);
26193 while Present
(Ref_Clause
) loop
26194 Next_Ref_Clause
:= Next
(Ref_Clause
);
26196 -- Obtain the attributes of the current refinement clause
26198 Ref_Input
:= Expression
(Ref_Clause
);
26199 Ref_Output
:= First
(Choices
(Ref_Clause
));
26201 -- The current refinement clause matches the dependence clause
26202 -- when both outputs match and both inputs match. See routine
26203 -- Match_Items for all possible conformance scenarios.
26205 -- Depends Dep_Output => Dep_Input
26209 -- Refined_Depends Ref_Output => Ref_Input
26212 (Dep_Item
=> Dep_Input
,
26213 Ref_Item
=> Ref_Input
,
26214 Matched
=> Inputs_Match
);
26217 (Dep_Item
=> Dep_Output
,
26218 Ref_Item
=> Ref_Output
,
26219 Matched
=> Outputs_Match
);
26221 -- An In_Out state clause may be matched against a refinement with
26222 -- a null input or null output as long as the non-null side of the
26223 -- relation contains a valid constituent of the In_Out_State.
26225 if Is_In_Out_State_Clause
then
26227 -- Depends => (State => State)
26228 -- Refined_Depends => (null => Constit) -- OK
26231 and then not Outputs_Match
26232 and then Nkind
(Ref_Output
) = N_Null
26234 Outputs_Match
:= True;
26237 -- Depends => (State => State)
26238 -- Refined_Depends => (Constit => null) -- OK
26240 if not Inputs_Match
26241 and then Outputs_Match
26242 and then Nkind
(Ref_Input
) = N_Null
26244 Inputs_Match
:= True;
26248 -- The current refinement clause is legally constructed following
26249 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
26250 -- the pool of candidates. The seach continues because a single
26251 -- dependence clause may have multiple matching refinements.
26253 if Inputs_Match
and Outputs_Match
then
26254 Clause_Matched
:= True;
26255 Remove
(Ref_Clause
);
26258 Ref_Clause
:= Next_Ref_Clause
;
26261 -- Depending on the order or composition of refinement clauses, an
26262 -- In_Out state clause may not be directly refinable.
26264 -- Refined_State => (State => (Constit_1, Constit_2))
26265 -- Depends => ((Output, State) => (Input, State))
26266 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
26268 -- Matching normalized clause (State => State) fails because there is
26269 -- no direct refinement capable of satisfying this relation. Another
26270 -- similar case arises when clauses (Constit_1 => Input) and (Output
26271 -- => Constit_2) are matched first, leaving no candidates for clause
26272 -- (State => State). Both scenarios are legal as long as one of the
26273 -- previous clauses mentioned a valid constituent of State.
26275 if not Clause_Matched
26276 and then Is_In_Out_State_Clause
26277 and then Is_Already_Matched
(Dep_Input
)
26279 Clause_Matched
:= True;
26282 -- A clause where the input is an abstract state with visible null
26283 -- refinement or a 'Result attribute is implicitly matched when the
26284 -- output has already been matched in a previous clause.
26286 -- Refined_State => (State => null)
26287 -- Depends => (Output => State) -- implicitly OK
26288 -- Refined_Depends => (Output => ...)
26289 -- Depends => (...'Result => State) -- implicitly OK
26290 -- Refined_Depends => (...'Result => ...)
26292 if not Clause_Matched
26293 and then Is_Null_Refined_State
(Dep_Input
)
26294 and then Is_Already_Matched
(Dep_Output
)
26296 Clause_Matched
:= True;
26299 -- A clause where the output is an abstract state with visible null
26300 -- refinement is implicitly matched when the input has already been
26301 -- matched in a previous clause.
26303 -- Refined_State => (State => null)
26304 -- Depends => (State => Input) -- implicitly OK
26305 -- Refined_Depends => (... => Input)
26307 if not Clause_Matched
26308 and then Is_Null_Refined_State
(Dep_Output
)
26309 and then Is_Already_Matched
(Dep_Input
)
26311 Clause_Matched
:= True;
26314 -- At this point either all refinement clauses have been examined or
26315 -- pragma Refined_Depends contains a solitary null. Only an abstract
26316 -- state with null refinement can possibly match these cases.
26318 -- Refined_State => (State => null)
26319 -- Depends => (State => null)
26320 -- Refined_Depends => null -- OK
26322 if not Clause_Matched
then
26324 (Dep_Item
=> Dep_Input
,
26326 Matched
=> Inputs_Match
);
26329 (Dep_Item
=> Dep_Output
,
26331 Matched
=> Outputs_Match
);
26333 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
26336 -- If the contents of Refined_Depends are legal, then the current
26337 -- dependence clause should be satisfied either by an explicit match
26338 -- or by one of the special cases.
26340 if not Clause_Matched
then
26342 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
26343 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
26345 end Check_Dependency_Clause
;
26347 -------------------------
26348 -- Check_Output_States --
26349 -------------------------
26351 procedure Check_Output_States
26352 (Spec_Id
: Entity_Id
;
26353 Spec_Inputs
: Elist_Id
;
26354 Spec_Outputs
: Elist_Id
;
26355 Body_Inputs
: Elist_Id
;
26356 Body_Outputs
: Elist_Id
)
26358 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26359 -- Determine whether all constituents of state State_Id with full
26360 -- visible refinement are used as outputs in pragma Refined_Depends.
26361 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
26363 -----------------------------
26364 -- Check_Constituent_Usage --
26365 -----------------------------
26367 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26368 Constits
: constant Elist_Id
:=
26369 Partial_Refinement_Constituents
(State_Id
);
26370 Constit_Elmt
: Elmt_Id
;
26371 Constit_Id
: Entity_Id
;
26372 Only_Partial
: constant Boolean :=
26373 not Has_Visible_Refinement
(State_Id
);
26374 Posted
: Boolean := False;
26377 if Present
(Constits
) then
26378 Constit_Elmt
:= First_Elmt
(Constits
);
26379 while Present
(Constit_Elmt
) loop
26380 Constit_Id
:= Node
(Constit_Elmt
);
26382 -- Issue an error when a constituent of State_Id is used,
26383 -- and State_Id has only partial visible refinement
26384 -- (SPARK RM 7.2.4(3d)).
26386 if Only_Partial
then
26387 if (Present
(Body_Inputs
)
26388 and then Appears_In
(Body_Inputs
, Constit_Id
))
26390 (Present
(Body_Outputs
)
26391 and then Appears_In
(Body_Outputs
, Constit_Id
))
26393 Error_Msg_Name_1
:= Chars
(State_Id
);
26395 ("constituent & of state % cannot be used in "
26396 & "dependence refinement", N
, Constit_Id
);
26397 Error_Msg_Name_1
:= Chars
(State_Id
);
26398 SPARK_Msg_N
("\use state % instead", N
);
26401 -- The constituent acts as an input (SPARK RM 7.2.5(3))
26403 elsif Present
(Body_Inputs
)
26404 and then Appears_In
(Body_Inputs
, Constit_Id
)
26406 Error_Msg_Name_1
:= Chars
(State_Id
);
26408 ("constituent & of state % must act as output in "
26409 & "dependence refinement", N
, Constit_Id
);
26411 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26413 elsif No
(Body_Outputs
)
26414 or else not Appears_In
(Body_Outputs
, Constit_Id
)
26419 ("output state & must be replaced by all its "
26420 & "constituents in dependence refinement",
26425 ("\constituent & is missing in output list",
26429 Next_Elmt
(Constit_Elmt
);
26432 end Check_Constituent_Usage
;
26437 Item_Elmt
: Elmt_Id
;
26438 Item_Id
: Entity_Id
;
26440 -- Start of processing for Check_Output_States
26443 -- Do not perform this check in an instance because it was already
26444 -- performed successfully in the generic template.
26446 if Is_Generic_Instance
(Spec_Id
) then
26449 -- Inspect the outputs of pragma Depends looking for a state with a
26450 -- visible refinement.
26452 elsif Present
(Spec_Outputs
) then
26453 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
26454 while Present
(Item_Elmt
) loop
26455 Item
:= Node
(Item_Elmt
);
26457 -- Deal with the mixed nature of the input and output lists
26459 if Nkind
(Item
) = N_Defining_Identifier
then
26462 Item_Id
:= Available_View
(Entity_Of
(Item
));
26465 if Ekind
(Item_Id
) = E_Abstract_State
then
26467 -- The state acts as an input-output, skip it
26469 if Present
(Spec_Inputs
)
26470 and then Appears_In
(Spec_Inputs
, Item_Id
)
26474 -- Ensure that all of the constituents are utilized as
26475 -- outputs in pragma Refined_Depends.
26477 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26478 Check_Constituent_Usage
(Item_Id
);
26482 Next_Elmt
(Item_Elmt
);
26485 end Check_Output_States
;
26487 --------------------
26488 -- Collect_States --
26489 --------------------
26491 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
26492 procedure Collect_State
26494 States
: in out Elist_Id
);
26495 -- Add the entity of Item to list States when it denotes to a state
26497 -------------------
26498 -- Collect_State --
26499 -------------------
26501 procedure Collect_State
26503 States
: in out Elist_Id
)
26508 if Is_Entity_Name
(Item
) then
26509 Id
:= Entity_Of
(Item
);
26511 if Ekind
(Id
) = E_Abstract_State
then
26512 if No
(States
) then
26513 States
:= New_Elmt_List
;
26516 Append_Unique_Elmt
(Id
, States
);
26526 States
: Elist_Id
:= No_Elist
;
26528 -- Start of processing for Collect_States
26531 Clause
:= First
(Clauses
);
26532 while Present
(Clause
) loop
26533 Input
:= Expression
(Clause
);
26534 Output
:= First
(Choices
(Clause
));
26536 Collect_State
(Input
, States
);
26537 Collect_State
(Output
, States
);
26543 end Collect_States
;
26545 -----------------------
26546 -- Normalize_Clauses --
26547 -----------------------
26549 procedure Normalize_Clauses
(Clauses
: List_Id
) is
26550 procedure Normalize_Inputs
(Clause
: Node_Id
);
26551 -- Normalize clause Clause by creating multiple clauses for each
26552 -- input item of Clause. It is assumed that Clause has exactly one
26553 -- output. The transformation is as follows:
26555 -- Output => (Input_1, Input_2) -- original
26557 -- Output => Input_1 -- normalizations
26558 -- Output => Input_2
26560 procedure Normalize_Outputs
(Clause
: Node_Id
);
26561 -- Normalize clause Clause by creating multiple clause for each
26562 -- output item of Clause. The transformation is as follows:
26564 -- (Output_1, Output_2) => Input -- original
26566 -- Output_1 => Input -- normalization
26567 -- Output_2 => Input
26569 ----------------------
26570 -- Normalize_Inputs --
26571 ----------------------
26573 procedure Normalize_Inputs
(Clause
: Node_Id
) is
26574 Inputs
: constant Node_Id
:= Expression
(Clause
);
26575 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26576 Output
: constant List_Id
:= Choices
(Clause
);
26577 Last_Input
: Node_Id
;
26579 New_Clause
: Node_Id
;
26580 Next_Input
: Node_Id
;
26583 -- Normalization is performed only when the original clause has
26584 -- more than one input. Multiple inputs appear as an aggregate.
26586 if Nkind
(Inputs
) = N_Aggregate
then
26587 Last_Input
:= Last
(Expressions
(Inputs
));
26589 -- Create a new clause for each input
26591 Input
:= First
(Expressions
(Inputs
));
26592 while Present
(Input
) loop
26593 Next_Input
:= Next
(Input
);
26595 -- Unhook the current input from the original input list
26596 -- because it will be relocated to a new clause.
26600 -- Special processing for the last input. At this point the
26601 -- original aggregate has been stripped down to one element.
26602 -- Replace the aggregate by the element itself.
26604 if Input
= Last_Input
then
26605 Rewrite
(Inputs
, Input
);
26607 -- Generate a clause of the form:
26612 Make_Component_Association
(Loc
,
26613 Choices
=> New_Copy_List_Tree
(Output
),
26614 Expression
=> Input
);
26616 -- The new clause contains replicated content that has
26617 -- already been analyzed, mark the clause as analyzed.
26619 Set_Analyzed
(New_Clause
);
26620 Insert_After
(Clause
, New_Clause
);
26623 Input
:= Next_Input
;
26626 end Normalize_Inputs
;
26628 -----------------------
26629 -- Normalize_Outputs --
26630 -----------------------
26632 procedure Normalize_Outputs
(Clause
: Node_Id
) is
26633 Inputs
: constant Node_Id
:= Expression
(Clause
);
26634 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
26635 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
26636 Last_Output
: Node_Id
;
26637 New_Clause
: Node_Id
;
26638 Next_Output
: Node_Id
;
26642 -- Multiple outputs appear as an aggregate. Nothing to do when
26643 -- the clause has exactly one output.
26645 if Nkind
(Outputs
) = N_Aggregate
then
26646 Last_Output
:= Last
(Expressions
(Outputs
));
26648 -- Create a clause for each output. Note that each time a new
26649 -- clause is created, the original output list slowly shrinks
26650 -- until there is one item left.
26652 Output
:= First
(Expressions
(Outputs
));
26653 while Present
(Output
) loop
26654 Next_Output
:= Next
(Output
);
26656 -- Unhook the output from the original output list as it
26657 -- will be relocated to a new clause.
26661 -- Special processing for the last output. At this point
26662 -- the original aggregate has been stripped down to one
26663 -- element. Replace the aggregate by the element itself.
26665 if Output
= Last_Output
then
26666 Rewrite
(Outputs
, Output
);
26669 -- Generate a clause of the form:
26670 -- (Output => Inputs)
26673 Make_Component_Association
(Loc
,
26674 Choices
=> New_List
(Output
),
26675 Expression
=> New_Copy_Tree
(Inputs
));
26677 -- The new clause contains replicated content that has
26678 -- already been analyzed. There is not need to reanalyze
26681 Set_Analyzed
(New_Clause
);
26682 Insert_After
(Clause
, New_Clause
);
26685 Output
:= Next_Output
;
26688 end Normalize_Outputs
;
26694 -- Start of processing for Normalize_Clauses
26697 Clause
:= First
(Clauses
);
26698 while Present
(Clause
) loop
26699 Normalize_Outputs
(Clause
);
26703 Clause
:= First
(Clauses
);
26704 while Present
(Clause
) loop
26705 Normalize_Inputs
(Clause
);
26708 end Normalize_Clauses
;
26710 --------------------------
26711 -- Remove_Extra_Clauses --
26712 --------------------------
26714 procedure Remove_Extra_Clauses
26715 (Clauses
: List_Id
;
26716 Matched_Items
: Elist_Id
)
26720 Input_Id
: Entity_Id
;
26721 Next_Clause
: Node_Id
;
26723 State_Id
: Entity_Id
;
26726 Clause
:= First
(Clauses
);
26727 while Present
(Clause
) loop
26728 Next_Clause
:= Next
(Clause
);
26730 Input
:= Expression
(Clause
);
26731 Output
:= First
(Choices
(Clause
));
26733 -- Recognize a clause of the form
26737 -- where Input is a constituent of a state which was already
26738 -- successfully matched. This clause must be removed because it
26739 -- simply indicates that some of the constituents of the state
26742 -- Refined_State => (State => (Constit_1, Constit_2))
26743 -- Depends => (Output => State)
26744 -- Refined_Depends => ((Output => Constit_1), -- State matched
26745 -- (null => Constit_2)) -- OK
26747 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
26749 -- Handle abstract views generated for limited with clauses
26751 Input_Id
:= Available_View
(Entity_Of
(Input
));
26753 -- The input must be a constituent of a state
26755 if Ekind_In
(Input_Id
, E_Abstract_State
,
26758 and then Present
(Encapsulating_State
(Input_Id
))
26760 State_Id
:= Encapsulating_State
(Input_Id
);
26762 -- The state must have a non-null visible refinement and be
26763 -- matched in a previous clause.
26765 if Has_Non_Null_Visible_Refinement
(State_Id
)
26766 and then Contains
(Matched_Items
, State_Id
)
26772 -- Recognize a clause of the form
26776 -- where Output is an arbitrary item. This clause must be removed
26777 -- because a null input legitimately matches anything.
26779 elsif Nkind
(Input
) = N_Null
then
26783 Clause
:= Next_Clause
;
26785 end Remove_Extra_Clauses
;
26787 --------------------------
26788 -- Report_Extra_Clauses --
26789 --------------------------
26791 procedure Report_Extra_Clauses
26792 (Spec_Id
: Entity_Id
;
26798 -- Do not perform this check in an instance because it was already
26799 -- performed successfully in the generic template.
26801 if Is_Generic_Instance
(Spec_Id
) then
26804 elsif Present
(Clauses
) then
26805 Clause
:= First
(Clauses
);
26806 while Present
(Clause
) loop
26808 ("unmatched or extra clause in dependence refinement",
26814 end Report_Extra_Clauses
;
26818 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26819 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26820 Errors
: constant Nat
:= Serious_Errors_Detected
;
26827 Body_Inputs
: Elist_Id
:= No_Elist
;
26828 Body_Outputs
: Elist_Id
:= No_Elist
;
26829 -- The inputs and outputs of the subprogram body synthesized from pragma
26830 -- Refined_Depends.
26832 Dependencies
: List_Id
:= No_List
;
26834 -- The corresponding Depends pragma along with its clauses
26836 Matched_Items
: Elist_Id
:= No_Elist
;
26837 -- A list containing the entities of all successfully matched items
26838 -- found in pragma Depends.
26840 Refinements
: List_Id
:= No_List
;
26841 -- The clauses of pragma Refined_Depends
26843 Spec_Id
: Entity_Id
;
26844 -- The entity of the subprogram subject to pragma Refined_Depends
26846 Spec_Inputs
: Elist_Id
:= No_Elist
;
26847 Spec_Outputs
: Elist_Id
:= No_Elist
;
26848 -- The inputs and outputs of the subprogram spec synthesized from pragma
26851 States
: Elist_Id
:= No_Elist
;
26852 -- A list containing the entities of all states whose constituents
26853 -- appear in pragma Depends.
26855 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
26858 -- Do not analyze the pragma multiple times
26860 if Is_Analyzed_Pragma
(N
) then
26864 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26866 -- Use the anonymous object as the proper spec when Refined_Depends
26867 -- applies to the body of a single task type. The object carries the
26868 -- proper Chars as well as all non-refined versions of pragmas.
26870 if Is_Single_Concurrent_Type
(Spec_Id
) then
26871 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26874 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
26876 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
26877 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
26879 if No
(Depends
) then
26881 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26882 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
26886 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
26888 -- A null dependency relation renders the refinement useless because it
26889 -- cannot possibly mention abstract states with visible refinement. Note
26890 -- that the inverse is not true as states may be refined to null
26891 -- (SPARK RM 7.2.5(2)).
26893 if Nkind
(Deps
) = N_Null
then
26895 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26896 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
26900 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
26901 -- This ensures that the categorization of all refined dependency items
26902 -- is consistent with their role.
26904 Analyze_Depends_In_Decl_Part
(N
);
26906 -- Do not match dependencies against refinements if Refined_Depends is
26907 -- illegal to avoid emitting misleading error.
26909 if Serious_Errors_Detected
= Errors
then
26911 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
26912 -- the inputs and outputs of the subprogram spec and body to verify
26913 -- the use of states with visible refinement and their constituents.
26915 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
26916 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
26918 Collect_Subprogram_Inputs_Outputs
26919 (Subp_Id
=> Spec_Id
,
26920 Synthesize
=> True,
26921 Subp_Inputs
=> Spec_Inputs
,
26922 Subp_Outputs
=> Spec_Outputs
,
26923 Global_Seen
=> Dummy
);
26925 Collect_Subprogram_Inputs_Outputs
26926 (Subp_Id
=> Body_Id
,
26927 Synthesize
=> True,
26928 Subp_Inputs
=> Body_Inputs
,
26929 Subp_Outputs
=> Body_Outputs
,
26930 Global_Seen
=> Dummy
);
26932 -- For an output state with a visible refinement, ensure that all
26933 -- constituents appear as outputs in the dependency refinement.
26935 Check_Output_States
26936 (Spec_Id
=> Spec_Id
,
26937 Spec_Inputs
=> Spec_Inputs
,
26938 Spec_Outputs
=> Spec_Outputs
,
26939 Body_Inputs
=> Body_Inputs
,
26940 Body_Outputs
=> Body_Outputs
);
26943 -- Matching is disabled in ASIS because clauses are not normalized as
26944 -- this is a tree altering activity similar to expansion.
26950 -- Multiple dependency clauses appear as component associations of an
26951 -- aggregate. Note that the clauses are copied because the algorithm
26952 -- modifies them and this should not be visible in Depends.
26954 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
26955 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
26956 Normalize_Clauses
(Dependencies
);
26958 -- Gather all states which appear in Depends
26960 States
:= Collect_States
(Dependencies
);
26962 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
26964 if Nkind
(Refs
) = N_Null
then
26965 Refinements
:= No_List
;
26967 -- Multiple dependency clauses appear as component associations of an
26968 -- aggregate. Note that the clauses are copied because the algorithm
26969 -- modifies them and this should not be visible in Refined_Depends.
26971 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
26972 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
26973 Normalize_Clauses
(Refinements
);
26976 -- At this point the clauses of pragmas Depends and Refined_Depends
26977 -- have been normalized into simple dependencies between one output
26978 -- and one input. Examine all clauses of pragma Depends looking for
26979 -- matching clauses in pragma Refined_Depends.
26981 Clause
:= First
(Dependencies
);
26982 while Present
(Clause
) loop
26983 Check_Dependency_Clause
26984 (Spec_Id
=> Spec_Id
,
26985 Dep_Clause
=> Clause
,
26986 Dep_States
=> States
,
26987 Refinements
=> Refinements
,
26988 Matched_Items
=> Matched_Items
);
26993 -- Pragma Refined_Depends may contain multiple clarification clauses
26994 -- which indicate that certain constituents do not influence the data
26995 -- flow in any way. Such clauses must be removed as long as the state
26996 -- has been matched, otherwise they will be incorrectly flagged as
26999 -- Refined_State => (State => (Constit_1, Constit_2))
27000 -- Depends => (Output => State)
27001 -- Refined_Depends => ((Output => Constit_1), -- State matched
27002 -- (null => Constit_2)) -- must be removed
27004 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
27006 if Serious_Errors_Detected
= Errors
then
27007 Report_Extra_Clauses
(Spec_Id
, Refinements
);
27012 Set_Is_Analyzed_Pragma
(N
);
27013 end Analyze_Refined_Depends_In_Decl_Part
;
27015 -----------------------------------------
27016 -- Analyze_Refined_Global_In_Decl_Part --
27017 -----------------------------------------
27019 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
27021 -- The corresponding Global pragma
27023 Has_In_State
: Boolean := False;
27024 Has_In_Out_State
: Boolean := False;
27025 Has_Out_State
: Boolean := False;
27026 Has_Proof_In_State
: Boolean := False;
27027 -- These flags are set when the corresponding Global pragma has a state
27028 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
27031 Has_Null_State
: Boolean := False;
27032 -- This flag is set when the corresponding Global pragma has at least
27033 -- one state with a null refinement.
27035 In_Constits
: Elist_Id
:= No_Elist
;
27036 In_Out_Constits
: Elist_Id
:= No_Elist
;
27037 Out_Constits
: Elist_Id
:= No_Elist
;
27038 Proof_In_Constits
: Elist_Id
:= No_Elist
;
27039 -- These lists contain the entities of all Input, In_Out, Output and
27040 -- Proof_In constituents that appear in Refined_Global and participate
27041 -- in state refinement.
27043 In_Items
: Elist_Id
:= No_Elist
;
27044 In_Out_Items
: Elist_Id
:= No_Elist
;
27045 Out_Items
: Elist_Id
:= No_Elist
;
27046 Proof_In_Items
: Elist_Id
:= No_Elist
;
27047 -- These lists contain the entities of all Input, In_Out, Output and
27048 -- Proof_In items defined in the corresponding Global pragma.
27050 Repeat_Items
: Elist_Id
:= No_Elist
;
27051 -- A list of all global items without full visible refinement found
27052 -- in pragma Global. These states should be repeated in the global
27053 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
27054 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
27056 Spec_Id
: Entity_Id
;
27057 -- The entity of the subprogram subject to pragma Refined_Global
27059 States
: Elist_Id
:= No_Elist
;
27060 -- A list of all states with full or partial visible refinement found in
27063 procedure Check_In_Out_States
;
27064 -- Determine whether the corresponding Global pragma mentions In_Out
27065 -- states with visible refinement and if so, ensure that one of the
27066 -- following completions apply to the constituents of the state:
27067 -- 1) there is at least one constituent of mode In_Out
27068 -- 2) there is at least one Input and one Output constituent
27069 -- 3) not all constituents are present and one of them is of mode
27071 -- This routine may remove elements from In_Constits, In_Out_Constits,
27072 -- Out_Constits and Proof_In_Constits.
27074 procedure Check_Input_States
;
27075 -- Determine whether the corresponding Global pragma mentions Input
27076 -- states with visible refinement and if so, ensure that at least one of
27077 -- its constituents appears as an Input item in Refined_Global.
27078 -- This routine may remove elements from In_Constits, In_Out_Constits,
27079 -- Out_Constits and Proof_In_Constits.
27081 procedure Check_Output_States
;
27082 -- Determine whether the corresponding Global pragma mentions Output
27083 -- states with visible refinement and if so, ensure that all of its
27084 -- constituents appear as Output items in Refined_Global.
27085 -- This routine may remove elements from In_Constits, In_Out_Constits,
27086 -- Out_Constits and Proof_In_Constits.
27088 procedure Check_Proof_In_States
;
27089 -- Determine whether the corresponding Global pragma mentions Proof_In
27090 -- states with visible refinement and if so, ensure that at least one of
27091 -- its constituents appears as a Proof_In item in Refined_Global.
27092 -- This routine may remove elements from In_Constits, In_Out_Constits,
27093 -- Out_Constits and Proof_In_Constits.
27095 procedure Check_Refined_Global_List
27097 Global_Mode
: Name_Id
:= Name_Input
);
27098 -- Verify the legality of a single global list declaration. Global_Mode
27099 -- denotes the current mode in effect.
27101 procedure Collect_Global_Items
27103 Mode
: Name_Id
:= Name_Input
);
27104 -- Gather all Input, In_Out, Output and Proof_In items from node List
27105 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
27106 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
27107 -- and Has_Proof_In_State are set when there is at least one abstract
27108 -- state with full or partial visible refinement available in the
27109 -- corresponding mode. Flag Has_Null_State is set when at least state
27110 -- has a null refinement. Mode denotes the current global mode in
27113 function Present_Then_Remove
27115 Item
: Entity_Id
) return Boolean;
27116 -- Search List for a particular entity Item. If Item has been found,
27117 -- remove it from List. This routine is used to strip lists In_Constits,
27118 -- In_Out_Constits and Out_Constits of valid constituents.
27120 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
27121 -- Same as function Present_Then_Remove, but do not report the presence
27122 -- of Item in List.
27124 procedure Report_Extra_Constituents
;
27125 -- Emit an error for each constituent found in lists In_Constits,
27126 -- In_Out_Constits and Out_Constits.
27128 procedure Report_Missing_Items
;
27129 -- Emit an error for each global item not repeated found in list
27132 -------------------------
27133 -- Check_In_Out_States --
27134 -------------------------
27136 procedure Check_In_Out_States
is
27137 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27138 -- Determine whether one of the following coverage scenarios is in
27140 -- 1) there is at least one constituent of mode In_Out or Output
27141 -- 2) there is at least one pair of constituents with modes Input
27142 -- and Output, or Proof_In and Output.
27143 -- 3) there is at least one constituent of mode Output and not all
27144 -- constituents are present.
27145 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
27147 -----------------------------
27148 -- Check_Constituent_Usage --
27149 -----------------------------
27151 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27152 Constits
: constant Elist_Id
:=
27153 Partial_Refinement_Constituents
(State_Id
);
27154 Constit_Elmt
: Elmt_Id
;
27155 Constit_Id
: Entity_Id
;
27156 Has_Missing
: Boolean := False;
27157 In_Out_Seen
: Boolean := False;
27158 Input_Seen
: Boolean := False;
27159 Output_Seen
: Boolean := False;
27160 Proof_In_Seen
: Boolean := False;
27163 -- Process all the constituents of the state and note their modes
27164 -- within the global refinement.
27166 if Present
(Constits
) then
27167 Constit_Elmt
:= First_Elmt
(Constits
);
27168 while Present
(Constit_Elmt
) loop
27169 Constit_Id
:= Node
(Constit_Elmt
);
27171 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27172 Input_Seen
:= True;
27174 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
27175 In_Out_Seen
:= True;
27177 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27178 Output_Seen
:= True;
27180 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27182 Proof_In_Seen
:= True;
27185 Has_Missing
:= True;
27188 Next_Elmt
(Constit_Elmt
);
27192 -- An In_Out constituent is a valid completion
27194 if In_Out_Seen
then
27197 -- A pair of one Input/Proof_In and one Output constituent is a
27198 -- valid completion.
27200 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
27203 elsif Output_Seen
then
27205 -- A single Output constituent is a valid completion only when
27206 -- some of the other constituents are missing.
27208 if Has_Missing
then
27211 -- Otherwise all constituents are of mode Output
27215 ("global refinement of state & must include at least one "
27216 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
27220 -- The state lacks a completion. When full refinement is visible,
27221 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
27222 -- refinement is visible, emit an error if the abstract state
27223 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
27224 -- both are utilized, Check_State_And_Constituent_Use. will issue
27227 elsif not Input_Seen
27228 and then not In_Out_Seen
27229 and then not Output_Seen
27230 and then not Proof_In_Seen
27232 if Has_Visible_Refinement
(State_Id
)
27233 or else Contains
(Repeat_Items
, State_Id
)
27236 ("missing global refinement of state &", N
, State_Id
);
27239 -- Otherwise the state has a malformed completion where at least
27240 -- one of the constituents has a different mode.
27244 ("global refinement of state & redefines the mode of its "
27245 & "constituents", N
, State_Id
);
27247 end Check_Constituent_Usage
;
27251 Item_Elmt
: Elmt_Id
;
27252 Item_Id
: Entity_Id
;
27254 -- Start of processing for Check_In_Out_States
27257 -- Do not perform this check in an instance because it was already
27258 -- performed successfully in the generic template.
27260 if Is_Generic_Instance
(Spec_Id
) then
27263 -- Inspect the In_Out items of the corresponding Global pragma
27264 -- looking for a state with a visible refinement.
27266 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
27267 Item_Elmt
:= First_Elmt
(In_Out_Items
);
27268 while Present
(Item_Elmt
) loop
27269 Item_Id
:= Node
(Item_Elmt
);
27271 -- Ensure that one of the three coverage variants is satisfied
27273 if Ekind
(Item_Id
) = E_Abstract_State
27274 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27276 Check_Constituent_Usage
(Item_Id
);
27279 Next_Elmt
(Item_Elmt
);
27282 end Check_In_Out_States
;
27284 ------------------------
27285 -- Check_Input_States --
27286 ------------------------
27288 procedure Check_Input_States
is
27289 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27290 -- Determine whether at least one constituent of state State_Id with
27291 -- full or partial visible refinement is used and has mode Input.
27292 -- Ensure that the remaining constituents do not have In_Out or
27293 -- Output modes. Emit an error if this is not the case
27294 -- (SPARK RM 7.2.4(5)).
27296 -----------------------------
27297 -- Check_Constituent_Usage --
27298 -----------------------------
27300 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27301 Constits
: constant Elist_Id
:=
27302 Partial_Refinement_Constituents
(State_Id
);
27303 Constit_Elmt
: Elmt_Id
;
27304 Constit_Id
: Entity_Id
;
27305 In_Seen
: Boolean := False;
27308 if Present
(Constits
) then
27309 Constit_Elmt
:= First_Elmt
(Constits
);
27310 while Present
(Constit_Elmt
) loop
27311 Constit_Id
:= Node
(Constit_Elmt
);
27313 -- At least one of the constituents appears as an Input
27315 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
27318 -- A Proof_In constituent can refine an Input state as long
27319 -- as there is at least one Input constituent present.
27321 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27325 -- The constituent appears in the global refinement, but has
27326 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
27328 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27329 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27331 Error_Msg_Name_1
:= Chars
(State_Id
);
27333 ("constituent & of state % must have mode `Input` in "
27334 & "global refinement", N
, Constit_Id
);
27337 Next_Elmt
(Constit_Elmt
);
27341 -- Not one of the constituents appeared as Input. Always emit an
27342 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
27343 -- When only partial refinement is visible, emit an error if the
27344 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27345 -- the case where both are utilized, an error will be issued in
27346 -- Check_State_And_Constituent_Use.
27349 and then (Has_Visible_Refinement
(State_Id
)
27350 or else Contains
(Repeat_Items
, State_Id
))
27353 ("global refinement of state & must include at least one "
27354 & "constituent of mode `Input`", N
, State_Id
);
27356 end Check_Constituent_Usage
;
27360 Item_Elmt
: Elmt_Id
;
27361 Item_Id
: Entity_Id
;
27363 -- Start of processing for Check_Input_States
27366 -- Do not perform this check in an instance because it was already
27367 -- performed successfully in the generic template.
27369 if Is_Generic_Instance
(Spec_Id
) then
27372 -- Inspect the Input items of the corresponding Global pragma looking
27373 -- for a state with a visible refinement.
27375 elsif Has_In_State
and then Present
(In_Items
) then
27376 Item_Elmt
:= First_Elmt
(In_Items
);
27377 while Present
(Item_Elmt
) loop
27378 Item_Id
:= Node
(Item_Elmt
);
27380 -- When full refinement is visible, ensure that at least one of
27381 -- the constituents is utilized and is of mode Input. When only
27382 -- partial refinement is visible, ensure that either one of
27383 -- the constituents is utilized and is of mode Input, or the
27384 -- abstract state is repeated and no constituent is utilized.
27386 if Ekind
(Item_Id
) = E_Abstract_State
27387 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27389 Check_Constituent_Usage
(Item_Id
);
27392 Next_Elmt
(Item_Elmt
);
27395 end Check_Input_States
;
27397 -------------------------
27398 -- Check_Output_States --
27399 -------------------------
27401 procedure Check_Output_States
is
27402 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27403 -- Determine whether all constituents of state State_Id with full
27404 -- visible refinement are used and have mode Output. Emit an error
27405 -- if this is not the case (SPARK RM 7.2.4(5)).
27407 -----------------------------
27408 -- Check_Constituent_Usage --
27409 -----------------------------
27411 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27412 Constits
: constant Elist_Id
:=
27413 Partial_Refinement_Constituents
(State_Id
);
27414 Only_Partial
: constant Boolean :=
27415 not Has_Visible_Refinement
(State_Id
);
27416 Constit_Elmt
: Elmt_Id
;
27417 Constit_Id
: Entity_Id
;
27418 Posted
: Boolean := False;
27421 if Present
(Constits
) then
27422 Constit_Elmt
:= First_Elmt
(Constits
);
27423 while Present
(Constit_Elmt
) loop
27424 Constit_Id
:= Node
(Constit_Elmt
);
27426 -- Issue an error when a constituent of State_Id is utilized
27427 -- and State_Id has only partial visible refinement
27428 -- (SPARK RM 7.2.4(3d)).
27430 if Only_Partial
then
27431 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
27432 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
27434 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27436 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27438 Error_Msg_Name_1
:= Chars
(State_Id
);
27440 ("constituent & of state % cannot be used in global "
27441 & "refinement", N
, Constit_Id
);
27442 Error_Msg_Name_1
:= Chars
(State_Id
);
27443 SPARK_Msg_N
("\use state % instead", N
);
27446 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
27449 -- The constituent appears in the global refinement, but has
27450 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
27452 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27453 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27454 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
27456 Error_Msg_Name_1
:= Chars
(State_Id
);
27458 ("constituent & of state % must have mode `Output` in "
27459 & "global refinement", N
, Constit_Id
);
27461 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
27467 ("`Output` state & must be replaced by all its "
27468 & "constituents in global refinement", N
, State_Id
);
27472 ("\constituent & is missing in output list",
27476 Next_Elmt
(Constit_Elmt
);
27479 end Check_Constituent_Usage
;
27483 Item_Elmt
: Elmt_Id
;
27484 Item_Id
: Entity_Id
;
27486 -- Start of processing for Check_Output_States
27489 -- Do not perform this check in an instance because it was already
27490 -- performed successfully in the generic template.
27492 if Is_Generic_Instance
(Spec_Id
) then
27495 -- Inspect the Output items of the corresponding Global pragma
27496 -- looking for a state with a visible refinement.
27498 elsif Has_Out_State
and then Present
(Out_Items
) then
27499 Item_Elmt
:= First_Elmt
(Out_Items
);
27500 while Present
(Item_Elmt
) loop
27501 Item_Id
:= Node
(Item_Elmt
);
27503 -- When full refinement is visible, ensure that all of the
27504 -- constituents are utilized and they have mode Output. When
27505 -- only partial refinement is visible, ensure that no
27506 -- constituent is utilized.
27508 if Ekind
(Item_Id
) = E_Abstract_State
27509 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27511 Check_Constituent_Usage
(Item_Id
);
27514 Next_Elmt
(Item_Elmt
);
27517 end Check_Output_States
;
27519 ---------------------------
27520 -- Check_Proof_In_States --
27521 ---------------------------
27523 procedure Check_Proof_In_States
is
27524 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
27525 -- Determine whether at least one constituent of state State_Id with
27526 -- full or partial visible refinement is used and has mode Proof_In.
27527 -- Ensure that the remaining constituents do not have Input, In_Out,
27528 -- or Output modes. Emit an error if this is not the case
27529 -- (SPARK RM 7.2.4(5)).
27531 -----------------------------
27532 -- Check_Constituent_Usage --
27533 -----------------------------
27535 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
27536 Constits
: constant Elist_Id
:=
27537 Partial_Refinement_Constituents
(State_Id
);
27538 Constit_Elmt
: Elmt_Id
;
27539 Constit_Id
: Entity_Id
;
27540 Proof_In_Seen
: Boolean := False;
27543 if Present
(Constits
) then
27544 Constit_Elmt
:= First_Elmt
(Constits
);
27545 while Present
(Constit_Elmt
) loop
27546 Constit_Id
:= Node
(Constit_Elmt
);
27548 -- At least one of the constituents appears as Proof_In
27550 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
27551 Proof_In_Seen
:= True;
27553 -- The constituent appears in the global refinement, but has
27554 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
27556 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
27557 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
27558 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
27560 Error_Msg_Name_1
:= Chars
(State_Id
);
27562 ("constituent & of state % must have mode `Proof_In` "
27563 & "in global refinement", N
, Constit_Id
);
27566 Next_Elmt
(Constit_Elmt
);
27570 -- Not one of the constituents appeared as Proof_In. Always emit
27571 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
27572 -- When only partial refinement is visible, emit an error if the
27573 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
27574 -- the case where both are utilized, an error will be issued by
27575 -- Check_State_And_Constituent_Use.
27577 if not Proof_In_Seen
27578 and then (Has_Visible_Refinement
(State_Id
)
27579 or else Contains
(Repeat_Items
, State_Id
))
27582 ("global refinement of state & must include at least one "
27583 & "constituent of mode `Proof_In`", N
, State_Id
);
27585 end Check_Constituent_Usage
;
27589 Item_Elmt
: Elmt_Id
;
27590 Item_Id
: Entity_Id
;
27592 -- Start of processing for Check_Proof_In_States
27595 -- Do not perform this check in an instance because it was already
27596 -- performed successfully in the generic template.
27598 if Is_Generic_Instance
(Spec_Id
) then
27601 -- Inspect the Proof_In items of the corresponding Global pragma
27602 -- looking for a state with a visible refinement.
27604 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
27605 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
27606 while Present
(Item_Elmt
) loop
27607 Item_Id
:= Node
(Item_Elmt
);
27609 -- Ensure that at least one of the constituents is utilized
27610 -- and is of mode Proof_In. When only partial refinement is
27611 -- visible, ensure that either one of the constituents is
27612 -- utilized and is of mode Proof_In, or the abstract state
27613 -- is repeated and no constituent is utilized.
27615 if Ekind
(Item_Id
) = E_Abstract_State
27616 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
27618 Check_Constituent_Usage
(Item_Id
);
27621 Next_Elmt
(Item_Elmt
);
27624 end Check_Proof_In_States
;
27626 -------------------------------
27627 -- Check_Refined_Global_List --
27628 -------------------------------
27630 procedure Check_Refined_Global_List
27632 Global_Mode
: Name_Id
:= Name_Input
)
27634 procedure Check_Refined_Global_Item
27636 Global_Mode
: Name_Id
);
27637 -- Verify the legality of a single global item declaration. Parameter
27638 -- Global_Mode denotes the current mode in effect.
27640 -------------------------------
27641 -- Check_Refined_Global_Item --
27642 -------------------------------
27644 procedure Check_Refined_Global_Item
27646 Global_Mode
: Name_Id
)
27648 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
27650 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
27651 -- Issue a common error message for all mode mismatches. Expect
27652 -- denotes the expected mode.
27654 -----------------------------
27655 -- Inconsistent_Mode_Error --
27656 -----------------------------
27658 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
27661 ("global item & has inconsistent modes", Item
, Item_Id
);
27663 Error_Msg_Name_1
:= Global_Mode
;
27664 Error_Msg_Name_2
:= Expect
;
27665 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
27666 end Inconsistent_Mode_Error
;
27670 Enc_State
: Entity_Id
:= Empty
;
27671 -- Encapsulating state for constituent, Empty otherwise
27673 -- Start of processing for Check_Refined_Global_Item
27676 if Ekind_In
(Item_Id
, E_Abstract_State
,
27680 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
27683 -- When the state or object acts as a constituent of another
27684 -- state with a visible refinement, collect it for the state
27685 -- completeness checks performed later on. Note that the item
27686 -- acts as a constituent only when the encapsulating state is
27687 -- present in pragma Global.
27689 if Present
(Enc_State
)
27690 and then (Has_Visible_Refinement
(Enc_State
)
27691 or else Has_Partial_Visible_Refinement
(Enc_State
))
27692 and then Contains
(States
, Enc_State
)
27694 -- If the state has only partial visible refinement, remove it
27695 -- from the list of items that should be repeated from pragma
27698 if not Has_Visible_Refinement
(Enc_State
) then
27699 Present_Then_Remove
(Repeat_Items
, Enc_State
);
27702 if Global_Mode
= Name_Input
then
27703 Append_New_Elmt
(Item_Id
, In_Constits
);
27705 elsif Global_Mode
= Name_In_Out
then
27706 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
27708 elsif Global_Mode
= Name_Output
then
27709 Append_New_Elmt
(Item_Id
, Out_Constits
);
27711 elsif Global_Mode
= Name_Proof_In
then
27712 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
27715 -- When not a constituent, ensure that both occurrences of the
27716 -- item in pragmas Global and Refined_Global match. Also remove
27717 -- it when present from the list of items that should be repeated
27718 -- from pragma Global.
27721 Present_Then_Remove
(Repeat_Items
, Item_Id
);
27723 if Contains
(In_Items
, Item_Id
) then
27724 if Global_Mode
/= Name_Input
then
27725 Inconsistent_Mode_Error
(Name_Input
);
27728 elsif Contains
(In_Out_Items
, Item_Id
) then
27729 if Global_Mode
/= Name_In_Out
then
27730 Inconsistent_Mode_Error
(Name_In_Out
);
27733 elsif Contains
(Out_Items
, Item_Id
) then
27734 if Global_Mode
/= Name_Output
then
27735 Inconsistent_Mode_Error
(Name_Output
);
27738 elsif Contains
(Proof_In_Items
, Item_Id
) then
27741 -- The item does not appear in the corresponding Global pragma,
27742 -- it must be an extra (SPARK RM 7.2.4(3)).
27745 pragma Assert
(Present
(Global
));
27746 Error_Msg_Sloc
:= Sloc
(Global
);
27748 ("extra global item & does not refine or repeat any "
27749 & "global item #", Item
, Item_Id
);
27752 end Check_Refined_Global_Item
;
27758 -- Start of processing for Check_Refined_Global_List
27761 -- Do not perform this check in an instance because it was already
27762 -- performed successfully in the generic template.
27764 if Is_Generic_Instance
(Spec_Id
) then
27767 elsif Nkind
(List
) = N_Null
then
27770 -- Single global item declaration
27772 elsif Nkind_In
(List
, N_Expanded_Name
,
27774 N_Selected_Component
)
27776 Check_Refined_Global_Item
(List
, Global_Mode
);
27778 -- Simple global list or moded global list declaration
27780 elsif Nkind
(List
) = N_Aggregate
then
27782 -- The declaration of a simple global list appear as a collection
27785 if Present
(Expressions
(List
)) then
27786 Item
:= First
(Expressions
(List
));
27787 while Present
(Item
) loop
27788 Check_Refined_Global_Item
(Item
, Global_Mode
);
27792 -- The declaration of a moded global list appears as a collection
27793 -- of component associations where individual choices denote
27796 elsif Present
(Component_Associations
(List
)) then
27797 Item
:= First
(Component_Associations
(List
));
27798 while Present
(Item
) loop
27799 Check_Refined_Global_List
27800 (List
=> Expression
(Item
),
27801 Global_Mode
=> Chars
(First
(Choices
(Item
))));
27809 raise Program_Error
;
27815 raise Program_Error
;
27817 end Check_Refined_Global_List
;
27819 --------------------------
27820 -- Collect_Global_Items --
27821 --------------------------
27823 procedure Collect_Global_Items
27825 Mode
: Name_Id
:= Name_Input
)
27827 procedure Collect_Global_Item
27829 Item_Mode
: Name_Id
);
27830 -- Add a single item to the appropriate list. Item_Mode denotes the
27831 -- current mode in effect.
27833 -------------------------
27834 -- Collect_Global_Item --
27835 -------------------------
27837 procedure Collect_Global_Item
27839 Item_Mode
: Name_Id
)
27841 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
27842 -- The above handles abstract views of variables and states built
27843 -- for limited with clauses.
27846 -- Signal that the global list contains at least one abstract
27847 -- state with a visible refinement. Note that the refinement may
27848 -- be null in which case there are no constituents.
27850 if Ekind
(Item_Id
) = E_Abstract_State
then
27851 if Has_Null_Visible_Refinement
(Item_Id
) then
27852 Has_Null_State
:= True;
27854 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
27855 Append_New_Elmt
(Item_Id
, States
);
27857 if Item_Mode
= Name_Input
then
27858 Has_In_State
:= True;
27859 elsif Item_Mode
= Name_In_Out
then
27860 Has_In_Out_State
:= True;
27861 elsif Item_Mode
= Name_Output
then
27862 Has_Out_State
:= True;
27863 elsif Item_Mode
= Name_Proof_In
then
27864 Has_Proof_In_State
:= True;
27869 -- Record global items without full visible refinement found in
27870 -- pragma Global which should be repeated in the global refinement
27871 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
27873 if Ekind
(Item_Id
) /= E_Abstract_State
27874 or else not Has_Visible_Refinement
(Item_Id
)
27876 Append_New_Elmt
(Item_Id
, Repeat_Items
);
27879 -- Add the item to the proper list
27881 if Item_Mode
= Name_Input
then
27882 Append_New_Elmt
(Item_Id
, In_Items
);
27883 elsif Item_Mode
= Name_In_Out
then
27884 Append_New_Elmt
(Item_Id
, In_Out_Items
);
27885 elsif Item_Mode
= Name_Output
then
27886 Append_New_Elmt
(Item_Id
, Out_Items
);
27887 elsif Item_Mode
= Name_Proof_In
then
27888 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
27890 end Collect_Global_Item
;
27896 -- Start of processing for Collect_Global_Items
27899 if Nkind
(List
) = N_Null
then
27902 -- Single global item declaration
27904 elsif Nkind_In
(List
, N_Expanded_Name
,
27906 N_Selected_Component
)
27908 Collect_Global_Item
(List
, Mode
);
27910 -- Single global list or moded global list declaration
27912 elsif Nkind
(List
) = N_Aggregate
then
27914 -- The declaration of a simple global list appear as a collection
27917 if Present
(Expressions
(List
)) then
27918 Item
:= First
(Expressions
(List
));
27919 while Present
(Item
) loop
27920 Collect_Global_Item
(Item
, Mode
);
27924 -- The declaration of a moded global list appears as a collection
27925 -- of component associations where individual choices denote mode.
27927 elsif Present
(Component_Associations
(List
)) then
27928 Item
:= First
(Component_Associations
(List
));
27929 while Present
(Item
) loop
27930 Collect_Global_Items
27931 (List
=> Expression
(Item
),
27932 Mode
=> Chars
(First
(Choices
(Item
))));
27940 raise Program_Error
;
27943 -- To accommodate partial decoration of disabled SPARK features, this
27944 -- routine may be called with illegal input. If this is the case, do
27945 -- not raise Program_Error.
27950 end Collect_Global_Items
;
27952 -------------------------
27953 -- Present_Then_Remove --
27954 -------------------------
27956 function Present_Then_Remove
27958 Item
: Entity_Id
) return Boolean
27963 if Present
(List
) then
27964 Elmt
:= First_Elmt
(List
);
27965 while Present
(Elmt
) loop
27966 if Node
(Elmt
) = Item
then
27967 Remove_Elmt
(List
, Elmt
);
27976 end Present_Then_Remove
;
27978 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
27981 Ignore
:= Present_Then_Remove
(List
, Item
);
27982 end Present_Then_Remove
;
27984 -------------------------------
27985 -- Report_Extra_Constituents --
27986 -------------------------------
27988 procedure Report_Extra_Constituents
is
27989 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
27990 -- Emit an error for every element of List
27992 ---------------------------------------
27993 -- Report_Extra_Constituents_In_List --
27994 ---------------------------------------
27996 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
27997 Constit_Elmt
: Elmt_Id
;
28000 if Present
(List
) then
28001 Constit_Elmt
:= First_Elmt
(List
);
28002 while Present
(Constit_Elmt
) loop
28003 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
28004 Next_Elmt
(Constit_Elmt
);
28007 end Report_Extra_Constituents_In_List
;
28009 -- Start of processing for Report_Extra_Constituents
28012 -- Do not perform this check in an instance because it was already
28013 -- performed successfully in the generic template.
28015 if Is_Generic_Instance
(Spec_Id
) then
28019 Report_Extra_Constituents_In_List
(In_Constits
);
28020 Report_Extra_Constituents_In_List
(In_Out_Constits
);
28021 Report_Extra_Constituents_In_List
(Out_Constits
);
28022 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
28024 end Report_Extra_Constituents
;
28026 --------------------------
28027 -- Report_Missing_Items --
28028 --------------------------
28030 procedure Report_Missing_Items
is
28031 Item_Elmt
: Elmt_Id
;
28032 Item_Id
: Entity_Id
;
28035 -- Do not perform this check in an instance because it was already
28036 -- performed successfully in the generic template.
28038 if Is_Generic_Instance
(Spec_Id
) then
28042 if Present
(Repeat_Items
) then
28043 Item_Elmt
:= First_Elmt
(Repeat_Items
);
28044 while Present
(Item_Elmt
) loop
28045 Item_Id
:= Node
(Item_Elmt
);
28046 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
28047 Next_Elmt
(Item_Elmt
);
28051 end Report_Missing_Items
;
28055 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28056 Errors
: constant Nat
:= Serious_Errors_Detected
;
28058 No_Constit
: Boolean;
28060 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
28063 -- Do not analyze the pragma multiple times
28065 if Is_Analyzed_Pragma
(N
) then
28069 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
28071 -- Use the anonymous object as the proper spec when Refined_Global
28072 -- applies to the body of a single task type. The object carries the
28073 -- proper Chars as well as all non-refined versions of pragmas.
28075 if Is_Single_Concurrent_Type
(Spec_Id
) then
28076 Spec_Id
:= Anonymous_Object
(Spec_Id
);
28079 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28080 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
28082 -- The subprogram declaration lacks pragma Global. This renders
28083 -- Refined_Global useless as there is nothing to refine.
28085 if No
(Global
) then
28087 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
28088 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
28092 -- Extract all relevant items from the corresponding Global pragma
28094 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28096 -- Package and subprogram bodies are instantiated individually in
28097 -- a separate compiler pass. Due to this mode of instantiation, the
28098 -- refinement of a state may no longer be visible when a subprogram
28099 -- body contract is instantiated. Since the generic template is legal,
28100 -- do not perform this check in the instance to circumvent this oddity.
28102 if Is_Generic_Instance
(Spec_Id
) then
28105 -- Non-instance case
28108 -- The corresponding Global pragma must mention at least one
28109 -- state with a visible refinement at the point Refined_Global
28110 -- is processed. States with null refinements need Refined_Global
28111 -- pragma (SPARK RM 7.2.4(2)).
28113 if not Has_In_State
28114 and then not Has_In_Out_State
28115 and then not Has_Out_State
28116 and then not Has_Proof_In_State
28117 and then not Has_Null_State
28120 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
28121 & "depend on abstract state with visible refinement"),
28125 -- The global refinement of inputs and outputs cannot be null when
28126 -- the corresponding Global pragma contains at least one item except
28127 -- in the case where we have states with null refinements.
28129 elsif Nkind
(Items
) = N_Null
28131 (Present
(In_Items
)
28132 or else Present
(In_Out_Items
)
28133 or else Present
(Out_Items
)
28134 or else Present
(Proof_In_Items
))
28135 and then not Has_Null_State
28138 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
28139 & "global items"), N
, Spec_Id
);
28144 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
28145 -- This ensures that the categorization of all refined global items is
28146 -- consistent with their role.
28148 Analyze_Global_In_Decl_Part
(N
);
28150 -- Perform all refinement checks with respect to completeness and mode
28153 if Serious_Errors_Detected
= Errors
then
28154 Check_Refined_Global_List
(Items
);
28157 -- Store the information that no constituent is used in the global
28158 -- refinement, prior to calling checking procedures which remove items
28159 -- from the list of constituents.
28163 and then No
(In_Out_Constits
)
28164 and then No
(Out_Constits
)
28165 and then No
(Proof_In_Constits
);
28167 -- For Input states with visible refinement, at least one constituent
28168 -- must be used as an Input in the global refinement.
28170 if Serious_Errors_Detected
= Errors
then
28171 Check_Input_States
;
28174 -- Verify all possible completion variants for In_Out states with
28175 -- visible refinement.
28177 if Serious_Errors_Detected
= Errors
then
28178 Check_In_Out_States
;
28181 -- For Output states with visible refinement, all constituents must be
28182 -- used as Outputs in the global refinement.
28184 if Serious_Errors_Detected
= Errors
then
28185 Check_Output_States
;
28188 -- For Proof_In states with visible refinement, at least one constituent
28189 -- must be used as Proof_In in the global refinement.
28191 if Serious_Errors_Detected
= Errors
then
28192 Check_Proof_In_States
;
28195 -- Emit errors for all constituents that belong to other states with
28196 -- visible refinement that do not appear in Global.
28198 if Serious_Errors_Detected
= Errors
then
28199 Report_Extra_Constituents
;
28202 -- Emit errors for all items in Global that are not repeated in the
28203 -- global refinement and for which there is no full visible refinement
28204 -- and, in the case of states with partial visible refinement, no
28205 -- constituent is mentioned in the global refinement.
28207 if Serious_Errors_Detected
= Errors
then
28208 Report_Missing_Items
;
28211 -- Emit an error if no constituent is used in the global refinement
28212 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
28213 -- one may be issued by the checking procedures. Do not perform this
28214 -- check in an instance because it was already performed successfully
28215 -- in the generic template.
28217 if Serious_Errors_Detected
= Errors
28218 and then not Is_Generic_Instance
(Spec_Id
)
28219 and then not Has_Null_State
28220 and then No_Constit
28222 SPARK_Msg_N
("missing refinement", N
);
28226 Set_Is_Analyzed_Pragma
(N
);
28227 end Analyze_Refined_Global_In_Decl_Part
;
28229 ----------------------------------------
28230 -- Analyze_Refined_State_In_Decl_Part --
28231 ----------------------------------------
28233 procedure Analyze_Refined_State_In_Decl_Part
28235 Freeze_Id
: Entity_Id
:= Empty
)
28237 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
28238 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
28239 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
28241 Available_States
: Elist_Id
:= No_Elist
;
28242 -- A list of all abstract states defined in the package declaration that
28243 -- are available for refinement. The list is used to report unrefined
28246 Body_States
: Elist_Id
:= No_Elist
;
28247 -- A list of all hidden states that appear in the body of the related
28248 -- package. The list is used to report unused hidden states.
28250 Constituents_Seen
: Elist_Id
:= No_Elist
;
28251 -- A list that contains all constituents processed so far. The list is
28252 -- used to detect multiple uses of the same constituent.
28254 Freeze_Posted
: Boolean := False;
28255 -- A flag that controls the output of a freezing-related error (see use
28258 Refined_States_Seen
: Elist_Id
:= No_Elist
;
28259 -- A list that contains all refined states processed so far. The list is
28260 -- used to detect duplicate refinements.
28262 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
28263 -- Perform full analysis of a single refinement clause
28265 procedure Report_Unrefined_States
(States
: Elist_Id
);
28266 -- Emit errors for all unrefined abstract states found in list States
28268 -------------------------------
28269 -- Analyze_Refinement_Clause --
28270 -------------------------------
28272 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
28273 AR_Constit
: Entity_Id
:= Empty
;
28274 AW_Constit
: Entity_Id
:= Empty
;
28275 ER_Constit
: Entity_Id
:= Empty
;
28276 EW_Constit
: Entity_Id
:= Empty
;
28277 -- The entities of external constituents that contain one of the
28278 -- following enabled properties: Async_Readers, Async_Writers,
28279 -- Effective_Reads and Effective_Writes.
28281 External_Constit_Seen
: Boolean := False;
28282 -- Flag used to mark when at least one external constituent is part
28283 -- of the state refinement.
28285 Non_Null_Seen
: Boolean := False;
28286 Null_Seen
: Boolean := False;
28287 -- Flags used to detect multiple uses of null in a single clause or a
28288 -- mixture of null and non-null constituents.
28290 Part_Of_Constits
: Elist_Id
:= No_Elist
;
28291 -- A list of all candidate constituents subject to indicator Part_Of
28292 -- where the encapsulating state is the current state.
28295 State_Id
: Entity_Id
;
28296 -- The current state being refined
28298 procedure Analyze_Constituent
(Constit
: Node_Id
);
28299 -- Perform full analysis of a single constituent
28301 procedure Check_External_Property
28302 (Prop_Nam
: Name_Id
;
28304 Constit
: Entity_Id
);
28305 -- Determine whether a property denoted by name Prop_Nam is present
28306 -- in the refined state. Emit an error if this is not the case. Flag
28307 -- Enabled should be set when the property applies to the refined
28308 -- state. Constit denotes the constituent (if any) which introduces
28309 -- the property in the refinement.
28311 procedure Match_State
;
28312 -- Determine whether the state being refined appears in list
28313 -- Available_States. Emit an error when attempting to re-refine the
28314 -- state or when the state is not defined in the package declaration,
28315 -- otherwise remove the state from Available_States.
28317 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
28318 -- Emit errors for all unused Part_Of constituents in list Constits
28320 -------------------------
28321 -- Analyze_Constituent --
28322 -------------------------
28324 procedure Analyze_Constituent
(Constit
: Node_Id
) is
28325 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
28326 -- Determine whether constituent Constit denoted by its entity
28327 -- Constit_Id appears in Body_States. Emit an error when the
28328 -- constituent is not a valid hidden state of the related package
28329 -- or when it is used more than once. Otherwise remove the
28330 -- constituent from Body_States.
28332 -----------------------
28333 -- Match_Constituent --
28334 -----------------------
28336 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
28337 procedure Collect_Constituent
;
28338 -- Verify the legality of constituent Constit_Id and add it to
28339 -- the refinements of State_Id.
28341 -------------------------
28342 -- Collect_Constituent --
28343 -------------------------
28345 procedure Collect_Constituent
is
28346 Constits
: Elist_Id
;
28349 -- The Ghost policy in effect at the point of abstract state
28350 -- declaration and constituent must match (SPARK RM 6.9(15))
28352 Check_Ghost_Refinement
28353 (State
, State_Id
, Constit
, Constit_Id
);
28355 -- A synchronized state must be refined by a synchronized
28356 -- object or another synchronized state (SPARK RM 9.6).
28358 if Is_Synchronized_State
(State_Id
)
28359 and then not Is_Synchronized_Object
(Constit_Id
)
28360 and then not Is_Synchronized_State
(Constit_Id
)
28363 ("constituent of synchronized state & must be "
28364 & "synchronized", Constit
, State_Id
);
28367 -- Add the constituent to the list of processed items to aid
28368 -- with the detection of duplicates.
28370 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
28372 -- Collect the constituent in the list of refinement items
28373 -- and establish a relation between the refined state and
28376 Constits
:= Refinement_Constituents
(State_Id
);
28378 if No
(Constits
) then
28379 Constits
:= New_Elmt_List
;
28380 Set_Refinement_Constituents
(State_Id
, Constits
);
28383 Append_Elmt
(Constit_Id
, Constits
);
28384 Set_Encapsulating_State
(Constit_Id
, State_Id
);
28386 -- The state has at least one legal constituent, mark the
28387 -- start of the refinement region. The region ends when the
28388 -- body declarations end (see routine Analyze_Declarations).
28390 Set_Has_Visible_Refinement
(State_Id
);
28392 -- When the constituent is external, save its relevant
28393 -- property for further checks.
28395 if Async_Readers_Enabled
(Constit_Id
) then
28396 AR_Constit
:= Constit_Id
;
28397 External_Constit_Seen
:= True;
28400 if Async_Writers_Enabled
(Constit_Id
) then
28401 AW_Constit
:= Constit_Id
;
28402 External_Constit_Seen
:= True;
28405 if Effective_Reads_Enabled
(Constit_Id
) then
28406 ER_Constit
:= Constit_Id
;
28407 External_Constit_Seen
:= True;
28410 if Effective_Writes_Enabled
(Constit_Id
) then
28411 EW_Constit
:= Constit_Id
;
28412 External_Constit_Seen
:= True;
28414 end Collect_Constituent
;
28418 State_Elmt
: Elmt_Id
;
28420 -- Start of processing for Match_Constituent
28423 -- Detect a duplicate use of a constituent
28425 if Contains
(Constituents_Seen
, Constit_Id
) then
28427 ("duplicate use of constituent &", Constit
, Constit_Id
);
28431 -- The constituent is subject to a Part_Of indicator
28433 if Present
(Encapsulating_State
(Constit_Id
)) then
28434 if Encapsulating_State
(Constit_Id
) = State_Id
then
28435 Remove
(Part_Of_Constits
, Constit_Id
);
28436 Collect_Constituent
;
28438 -- The constituent is part of another state and is used
28439 -- incorrectly in the refinement of the current state.
28442 Error_Msg_Name_1
:= Chars
(State_Id
);
28444 ("& cannot act as constituent of state %",
28445 Constit
, Constit_Id
);
28447 ("\Part_Of indicator specifies encapsulator &",
28448 Constit
, Encapsulating_State
(Constit_Id
));
28451 -- The only other source of legal constituents is the body
28452 -- state space of the related package.
28455 if Present
(Body_States
) then
28456 State_Elmt
:= First_Elmt
(Body_States
);
28457 while Present
(State_Elmt
) loop
28459 -- Consume a valid constituent to signal that it has
28460 -- been encountered.
28462 if Node
(State_Elmt
) = Constit_Id
then
28463 Remove_Elmt
(Body_States
, State_Elmt
);
28464 Collect_Constituent
;
28468 Next_Elmt
(State_Elmt
);
28472 -- At this point it is known that the constituent is not
28473 -- part of the package hidden state and cannot be used in
28474 -- a refinement (SPARK RM 7.2.2(9)).
28476 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28478 ("cannot use & in refinement, constituent is not a hidden "
28479 & "state of package %", Constit
, Constit_Id
);
28481 end Match_Constituent
;
28485 Constit_Id
: Entity_Id
;
28486 Constits
: Elist_Id
;
28488 -- Start of processing for Analyze_Constituent
28491 -- Detect multiple uses of null in a single refinement clause or a
28492 -- mixture of null and non-null constituents.
28494 if Nkind
(Constit
) = N_Null
then
28497 ("multiple null constituents not allowed", Constit
);
28499 elsif Non_Null_Seen
then
28501 ("cannot mix null and non-null constituents", Constit
);
28506 -- Collect the constituent in the list of refinement items
28508 Constits
:= Refinement_Constituents
(State_Id
);
28510 if No
(Constits
) then
28511 Constits
:= New_Elmt_List
;
28512 Set_Refinement_Constituents
(State_Id
, Constits
);
28515 Append_Elmt
(Constit
, Constits
);
28517 -- The state has at least one legal constituent, mark the
28518 -- start of the refinement region. The region ends when the
28519 -- body declarations end (see Analyze_Declarations).
28521 Set_Has_Visible_Refinement
(State_Id
);
28524 -- Non-null constituents
28527 Non_Null_Seen
:= True;
28531 ("cannot mix null and non-null constituents", Constit
);
28535 Resolve_State
(Constit
);
28537 -- Ensure that the constituent denotes a valid state or a
28538 -- whole object (SPARK RM 7.2.2(5)).
28540 if Is_Entity_Name
(Constit
) then
28541 Constit_Id
:= Entity_Of
(Constit
);
28543 -- When a constituent is declared after a subprogram body
28544 -- that caused freezing of the related contract where
28545 -- pragma Refined_State resides, the constituent appears
28546 -- undefined and carries Any_Id as its entity.
28548 -- package body Pack
28549 -- with Refined_State => (State => Constit)
28552 -- with Refined_Global => (Input => Constit)
28560 if Constit_Id
= Any_Id
then
28561 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
28563 -- Emit a specialized info message when the contract of
28564 -- the related package body was "frozen" by another body.
28565 -- Note that it is not possible to precisely identify why
28566 -- the constituent is undefined because it is not visible
28567 -- when pragma Refined_State is analyzed. This message is
28568 -- a reasonable approximation.
28570 if Present
(Freeze_Id
) and then not Freeze_Posted
then
28571 Freeze_Posted
:= True;
28573 Error_Msg_Name_1
:= Chars
(Body_Id
);
28574 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28576 ("body & declared # freezes the contract of %",
28579 ("\all constituents must be declared before body #",
28582 -- A misplaced constituent is a critical error because
28583 -- pragma Refined_Depends or Refined_Global depends on
28584 -- the proper link between a state and a constituent.
28585 -- Stop the compilation, as this leads to a multitude
28586 -- of misleading cascaded errors.
28588 raise Unrecoverable_Error
;
28591 -- The constituent is a valid state or object
28593 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
28597 Match_Constituent
(Constit_Id
);
28599 -- The variable may eventually become a constituent of a
28600 -- single protected/task type. Record the reference now
28601 -- and verify its legality when analyzing the contract of
28602 -- the variable (SPARK RM 9.3).
28604 if Ekind
(Constit_Id
) = E_Variable
then
28605 Record_Possible_Part_Of_Reference
28606 (Var_Id
=> Constit_Id
,
28610 -- Otherwise the constituent is illegal
28614 ("constituent & must denote object or state",
28615 Constit
, Constit_Id
);
28618 -- The constituent is illegal
28621 SPARK_Msg_N
("malformed constituent", Constit
);
28624 end Analyze_Constituent
;
28626 -----------------------------
28627 -- Check_External_Property --
28628 -----------------------------
28630 procedure Check_External_Property
28631 (Prop_Nam
: Name_Id
;
28633 Constit
: Entity_Id
)
28636 -- The property is missing in the declaration of the state, but
28637 -- a constituent is introducing it in the state refinement
28638 -- (SPARK RM 7.2.8(2)).
28640 if not Enabled
and then Present
(Constit
) then
28641 Error_Msg_Name_1
:= Prop_Nam
;
28642 Error_Msg_Name_2
:= Chars
(State_Id
);
28644 ("constituent & introduces external property % in refinement "
28645 & "of state %", State
, Constit
);
28647 Error_Msg_Sloc
:= Sloc
(State_Id
);
28649 ("\property is missing in abstract state declaration #",
28652 end Check_External_Property
;
28658 procedure Match_State
is
28659 State_Elmt
: Elmt_Id
;
28662 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
28664 if Contains
(Refined_States_Seen
, State_Id
) then
28666 ("duplicate refinement of state &", State
, State_Id
);
28670 -- Inspect the abstract states defined in the package declaration
28671 -- looking for a match.
28673 State_Elmt
:= First_Elmt
(Available_States
);
28674 while Present
(State_Elmt
) loop
28676 -- A valid abstract state is being refined in the body. Add
28677 -- the state to the list of processed refined states to aid
28678 -- with the detection of duplicate refinements. Remove the
28679 -- state from Available_States to signal that it has already
28682 if Node
(State_Elmt
) = State_Id
then
28683 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
28684 Remove_Elmt
(Available_States
, State_Elmt
);
28688 Next_Elmt
(State_Elmt
);
28691 -- If we get here, we are refining a state that is not defined in
28692 -- the package declaration.
28694 Error_Msg_Name_1
:= Chars
(Spec_Id
);
28696 ("cannot refine state, & is not defined in package %",
28700 --------------------------------
28701 -- Report_Unused_Constituents --
28702 --------------------------------
28704 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
28705 Constit_Elmt
: Elmt_Id
;
28706 Constit_Id
: Entity_Id
;
28707 Posted
: Boolean := False;
28710 if Present
(Constits
) then
28711 Constit_Elmt
:= First_Elmt
(Constits
);
28712 while Present
(Constit_Elmt
) loop
28713 Constit_Id
:= Node
(Constit_Elmt
);
28715 -- Generate an error message of the form:
28717 -- state ... has unused Part_Of constituents
28718 -- abstract state ... defined at ...
28719 -- constant ... defined at ...
28720 -- variable ... defined at ...
28725 ("state & has unused Part_Of constituents",
28729 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
28731 if Ekind
(Constit_Id
) = E_Abstract_State
then
28733 ("\abstract state & defined #", State
, Constit_Id
);
28735 elsif Ekind
(Constit_Id
) = E_Constant
then
28737 ("\constant & defined #", State
, Constit_Id
);
28740 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
28741 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
28744 Next_Elmt
(Constit_Elmt
);
28747 end Report_Unused_Constituents
;
28749 -- Local declarations
28751 Body_Ref
: Node_Id
;
28752 Body_Ref_Elmt
: Elmt_Id
;
28754 Extra_State
: Node_Id
;
28756 -- Start of processing for Analyze_Refinement_Clause
28759 -- A refinement clause appears as a component association where the
28760 -- sole choice is the state and the expressions are the constituents.
28761 -- This is a syntax error, always report.
28763 if Nkind
(Clause
) /= N_Component_Association
then
28764 Error_Msg_N
("malformed state refinement clause", Clause
);
28768 -- Analyze the state name of a refinement clause
28770 State
:= First
(Choices
(Clause
));
28773 Resolve_State
(State
);
28775 -- Ensure that the state name denotes a valid abstract state that is
28776 -- defined in the spec of the related package.
28778 if Is_Entity_Name
(State
) then
28779 State_Id
:= Entity_Of
(State
);
28781 -- When the abstract state is undefined, it appears as Any_Id. Do
28782 -- not continue with the analysis of the clause.
28784 if State_Id
= Any_Id
then
28787 -- Catch any attempts to re-refine a state or refine a state that
28788 -- is not defined in the package declaration.
28790 elsif Ekind
(State_Id
) = E_Abstract_State
then
28794 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
28798 -- References to a state with visible refinement are illegal.
28799 -- When nested packages are involved, detecting such references is
28800 -- tricky because pragma Refined_State is analyzed later than the
28801 -- offending pragma Depends or Global. References that occur in
28802 -- such nested context are stored in a list. Emit errors for all
28803 -- references found in Body_References (SPARK RM 6.1.4(8)).
28805 if Present
(Body_References
(State_Id
)) then
28806 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
28807 while Present
(Body_Ref_Elmt
) loop
28808 Body_Ref
:= Node
(Body_Ref_Elmt
);
28810 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
28811 Error_Msg_Sloc
:= Sloc
(State
);
28812 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
28814 Next_Elmt
(Body_Ref_Elmt
);
28818 -- The state name is illegal. This is a syntax error, always report.
28821 Error_Msg_N
("malformed state name in refinement clause", State
);
28825 -- A refinement clause may only refine one state at a time
28827 Extra_State
:= Next
(State
);
28829 if Present
(Extra_State
) then
28831 ("refinement clause cannot cover multiple states", Extra_State
);
28834 -- Replicate the Part_Of constituents of the refined state because
28835 -- the algorithm will consume items.
28837 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
28839 -- Analyze all constituents of the refinement. Multiple constituents
28840 -- appear as an aggregate.
28842 Constit
:= Expression
(Clause
);
28844 if Nkind
(Constit
) = N_Aggregate
then
28845 if Present
(Component_Associations
(Constit
)) then
28847 ("constituents of refinement clause must appear in "
28848 & "positional form", Constit
);
28850 else pragma Assert
(Present
(Expressions
(Constit
)));
28851 Constit
:= First
(Expressions
(Constit
));
28852 while Present
(Constit
) loop
28853 Analyze_Constituent
(Constit
);
28858 -- Various forms of a single constituent. Note that these may include
28859 -- malformed constituents.
28862 Analyze_Constituent
(Constit
);
28865 -- Verify that external constituents do not introduce new external
28866 -- property in the state refinement (SPARK RM 7.2.8(2)).
28868 if Is_External_State
(State_Id
) then
28869 Check_External_Property
28870 (Prop_Nam
=> Name_Async_Readers
,
28871 Enabled
=> Async_Readers_Enabled
(State_Id
),
28872 Constit
=> AR_Constit
);
28874 Check_External_Property
28875 (Prop_Nam
=> Name_Async_Writers
,
28876 Enabled
=> Async_Writers_Enabled
(State_Id
),
28877 Constit
=> AW_Constit
);
28879 Check_External_Property
28880 (Prop_Nam
=> Name_Effective_Reads
,
28881 Enabled
=> Effective_Reads_Enabled
(State_Id
),
28882 Constit
=> ER_Constit
);
28884 Check_External_Property
28885 (Prop_Nam
=> Name_Effective_Writes
,
28886 Enabled
=> Effective_Writes_Enabled
(State_Id
),
28887 Constit
=> EW_Constit
);
28889 -- When a refined state is not external, it should not have external
28890 -- constituents (SPARK RM 7.2.8(1)).
28892 elsif External_Constit_Seen
then
28894 ("non-external state & cannot contain external constituents in "
28895 & "refinement", State
, State_Id
);
28898 -- Ensure that all Part_Of candidate constituents have been mentioned
28899 -- in the refinement clause.
28901 Report_Unused_Constituents
(Part_Of_Constits
);
28902 end Analyze_Refinement_Clause
;
28904 -----------------------------
28905 -- Report_Unrefined_States --
28906 -----------------------------
28908 procedure Report_Unrefined_States
(States
: Elist_Id
) is
28909 State_Elmt
: Elmt_Id
;
28912 if Present
(States
) then
28913 State_Elmt
:= First_Elmt
(States
);
28914 while Present
(State_Elmt
) loop
28916 ("abstract state & must be refined", Node
(State_Elmt
));
28918 Next_Elmt
(State_Elmt
);
28921 end Report_Unrefined_States
;
28923 -- Local declarations
28925 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
28928 -- Start of processing for Analyze_Refined_State_In_Decl_Part
28931 -- Do not analyze the pragma multiple times
28933 if Is_Analyzed_Pragma
(N
) then
28937 -- Save the scenario for examination by the ABE Processing phase
28939 Record_Elaboration_Scenario
(N
);
28941 -- Replicate the abstract states declared by the package because the
28942 -- matching algorithm will consume states.
28944 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
28946 -- Gather all abstract states and objects declared in the visible
28947 -- state space of the package body. These items must be utilized as
28948 -- constituents in a state refinement.
28950 Body_States
:= Collect_Body_States
(Body_Id
);
28952 -- Multiple non-null state refinements appear as an aggregate
28954 if Nkind
(Clauses
) = N_Aggregate
then
28955 if Present
(Expressions
(Clauses
)) then
28957 ("state refinements must appear as component associations",
28960 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
28961 Clause
:= First
(Component_Associations
(Clauses
));
28962 while Present
(Clause
) loop
28963 Analyze_Refinement_Clause
(Clause
);
28968 -- Various forms of a single state refinement. Note that these may
28969 -- include malformed refinements.
28972 Analyze_Refinement_Clause
(Clauses
);
28975 -- List all abstract states that were left unrefined
28977 Report_Unrefined_States
(Available_States
);
28979 Set_Is_Analyzed_Pragma
(N
);
28980 end Analyze_Refined_State_In_Decl_Part
;
28982 ------------------------------------
28983 -- Analyze_Test_Case_In_Decl_Part --
28984 ------------------------------------
28986 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
28987 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
28988 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28990 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
28991 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
28992 -- denoted by Arg_Nam.
28994 ------------------------------
28995 -- Preanalyze_Test_Case_Arg --
28996 ------------------------------
28998 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
29002 -- Preanalyze the original aspect argument for ASIS or for a generic
29003 -- subprogram to properly capture global references.
29005 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
29009 Arg_Nam
=> Arg_Nam
,
29010 From_Aspect
=> True);
29012 if Present
(Arg
) then
29013 Preanalyze_Assert_Expression
29014 (Expression
(Arg
), Standard_Boolean
);
29018 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
29020 if Present
(Arg
) then
29021 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
29023 end Preanalyze_Test_Case_Arg
;
29027 Restore_Scope
: Boolean := False;
29029 -- Start of processing for Analyze_Test_Case_In_Decl_Part
29032 -- Do not analyze the pragma multiple times
29034 if Is_Analyzed_Pragma
(N
) then
29038 -- Ensure that the formal parameters are visible when analyzing all
29039 -- clauses. This falls out of the general rule of aspects pertaining
29040 -- to subprogram declarations.
29042 if not In_Open_Scopes
(Spec_Id
) then
29043 Restore_Scope
:= True;
29044 Push_Scope
(Spec_Id
);
29046 if Is_Generic_Subprogram
(Spec_Id
) then
29047 Install_Generic_Formals
(Spec_Id
);
29049 Install_Formals
(Spec_Id
);
29053 Preanalyze_Test_Case_Arg
(Name_Requires
);
29054 Preanalyze_Test_Case_Arg
(Name_Ensures
);
29056 if Restore_Scope
then
29060 -- Currently it is not possible to inline pre/postconditions on a
29061 -- subprogram subject to pragma Inline_Always.
29063 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
29065 Set_Is_Analyzed_Pragma
(N
);
29066 end Analyze_Test_Case_In_Decl_Part
;
29072 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
29077 if Present
(List
) then
29078 Elmt
:= First_Elmt
(List
);
29079 while Present
(Elmt
) loop
29080 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
29083 Id
:= Entity_Of
(Node
(Elmt
));
29086 if Id
= Item_Id
then
29097 -----------------------------------
29098 -- Build_Pragma_Check_Equivalent --
29099 -----------------------------------
29101 function Build_Pragma_Check_Equivalent
29103 Subp_Id
: Entity_Id
:= Empty
;
29104 Inher_Id
: Entity_Id
:= Empty
;
29105 Keep_Pragma_Id
: Boolean := False) return Node_Id
29107 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
29108 -- Detect whether node N references a formal parameter subject to
29109 -- pragma Unreferenced. If this is the case, set Comes_From_Source
29110 -- to False to suppress the generation of a reference when analyzing
29113 ------------------------
29114 -- Suppress_Reference --
29115 ------------------------
29117 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
29118 Formal
: Entity_Id
;
29121 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29122 Formal
:= Entity
(N
);
29124 -- The formal parameter is subject to pragma Unreferenced. Prevent
29125 -- the generation of references by resetting the Comes_From_Source
29128 if Is_Formal
(Formal
)
29129 and then Has_Pragma_Unreferenced
(Formal
)
29131 Set_Comes_From_Source
(N
, False);
29136 end Suppress_Reference
;
29138 procedure Suppress_References
is
29139 new Traverse_Proc
(Suppress_Reference
);
29143 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
29144 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29145 Check_Prag
: Node_Id
;
29149 Needs_Wrapper
: Boolean;
29150 pragma Unreferenced
(Needs_Wrapper
);
29152 -- Start of processing for Build_Pragma_Check_Equivalent
29155 -- When the pre- or postcondition is inherited, map the formals of the
29156 -- inherited subprogram to those of the current subprogram. In addition,
29157 -- map primitive operations of the parent type into the corresponding
29158 -- primitive operations of the descendant.
29160 if Present
(Inher_Id
) then
29161 pragma Assert
(Present
(Subp_Id
));
29163 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
29165 -- Use generic machinery to copy inherited pragma, as if it were an
29166 -- instantiation, resetting source locations appropriately, so that
29167 -- expressions inside the inherited pragma use chained locations.
29168 -- This is used in particular in GNATprove to locate precisely
29169 -- messages on a given inherited pragma.
29171 Set_Copied_Sloc_For_Inherited_Pragma
29172 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
29173 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29175 -- Build the inherited class-wide condition
29177 Build_Class_Wide_Expression
29178 (Prag
=> Check_Prag
,
29180 Par_Subp
=> Inher_Id
,
29181 Adjust_Sloc
=> True,
29182 Needs_Wrapper
=> Needs_Wrapper
);
29184 -- If not an inherited condition simply copy the original pragma
29187 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
29190 -- Mark the pragma as being internally generated and reset the Analyzed
29193 Set_Analyzed
(Check_Prag
, False);
29194 Set_Comes_From_Source
(Check_Prag
, False);
29196 -- The tree of the original pragma may contain references to the
29197 -- formal parameters of the related subprogram. At the same time
29198 -- the corresponding body may mark the formals as unreferenced:
29200 -- procedure Proc (Formal : ...)
29201 -- with Pre => Formal ...;
29203 -- procedure Proc (Formal : ...) is
29204 -- pragma Unreferenced (Formal);
29207 -- This creates problems because all pragma Check equivalents are
29208 -- analyzed at the end of the body declarations. Since all source
29209 -- references have already been accounted for, reset any references
29210 -- to such formals in the generated pragma Check equivalent.
29212 Suppress_References
(Check_Prag
);
29214 if Present
(Corresponding_Aspect
(Prag
)) then
29215 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
29220 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
29221 -- the copied pragma in the newly created pragma, convert the copy into
29222 -- pragma Check by correcting the name and adding a check_kind argument.
29224 if not Keep_Pragma_Id
then
29225 Set_Class_Present
(Check_Prag
, False);
29227 Set_Pragma_Identifier
29228 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
29230 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
29231 Make_Pragma_Argument_Association
(Loc
,
29232 Expression
=> Make_Identifier
(Loc
, Nam
)));
29235 -- Update the error message when the pragma is inherited
29237 if Present
(Inher_Id
) then
29238 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
29240 if Chars
(Msg_Arg
) = Name_Message
then
29241 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
29243 -- Insert "inherited" to improve the error message
29245 if Name_Buffer
(1 .. 8) = "failed p" then
29246 Insert_Str_In_Name_Buffer
("inherited ", 8);
29247 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
29253 end Build_Pragma_Check_Equivalent
;
29255 -----------------------------
29256 -- Check_Applicable_Policy --
29257 -----------------------------
29259 procedure Check_Applicable_Policy
(N
: Node_Id
) is
29263 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
29266 -- No effect if not valid assertion kind name
29268 if not Is_Valid_Assertion_Kind
(Ename
) then
29272 -- Loop through entries in check policy list
29274 PP
:= Opt
.Check_Policy_List
;
29275 while Present
(PP
) loop
29277 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29278 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29282 or else Pnm
= Name_Assertion
29283 or else (Pnm
= Name_Statement_Assertions
29284 and then Nam_In
(Ename
, Name_Assert
,
29285 Name_Assert_And_Cut
,
29287 Name_Loop_Invariant
,
29288 Name_Loop_Variant
))
29290 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
29296 -- In CodePeer mode and GNATprove mode, we need to
29297 -- consider all assertions, unless they are disabled.
29298 -- Force Is_Checked on ignored assertions, in particular
29299 -- because transformations of the AST may depend on
29300 -- assertions being checked (e.g. the translation of
29301 -- attribute 'Loop_Entry).
29303 if CodePeer_Mode
or GNATprove_Mode
then
29304 Set_Is_Checked
(N
, True);
29305 Set_Is_Ignored
(N
, False);
29307 Set_Is_Checked
(N
, False);
29308 Set_Is_Ignored
(N
, True);
29314 Set_Is_Checked
(N
, True);
29315 Set_Is_Ignored
(N
, False);
29317 when Name_Disable
=>
29318 Set_Is_Ignored
(N
, True);
29319 Set_Is_Checked
(N
, False);
29320 Set_Is_Disabled
(N
, True);
29322 -- That should be exhaustive, the null here is a defence
29323 -- against a malformed tree from previous errors.
29332 PP
:= Next_Pragma
(PP
);
29336 -- If there are no specific entries that matched, then we let the
29337 -- setting of assertions govern. Note that this provides the needed
29338 -- compatibility with the RM for the cases of assertion, invariant,
29339 -- precondition, predicate, and postcondition. Note also that
29340 -- Assertions_Enabled is forced in CodePeer mode and GNATprove mode.
29342 if Assertions_Enabled
then
29343 Set_Is_Checked
(N
, True);
29344 Set_Is_Ignored
(N
, False);
29346 Set_Is_Checked
(N
, False);
29347 Set_Is_Ignored
(N
, True);
29349 end Check_Applicable_Policy
;
29351 -------------------------------
29352 -- Check_External_Properties --
29353 -------------------------------
29355 procedure Check_External_Properties
29363 -- All properties enabled
29365 if AR
and AW
and ER
and EW
then
29368 -- Async_Readers + Effective_Writes
29369 -- Async_Readers + Async_Writers + Effective_Writes
29371 elsif AR
and EW
and not ER
then
29374 -- Async_Writers + Effective_Reads
29375 -- Async_Readers + Async_Writers + Effective_Reads
29377 elsif AW
and ER
and not EW
then
29380 -- Async_Readers + Async_Writers
29382 elsif AR
and AW
and not ER
and not EW
then
29387 elsif AR
and not AW
and not ER
and not EW
then
29392 elsif AW
and not AR
and not ER
and not EW
then
29397 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
29400 end Check_External_Properties
;
29406 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
29410 -- Loop through entries in check policy list
29412 PP
:= Opt
.Check_Policy_List
;
29413 while Present
(PP
) loop
29415 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
29416 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
29420 or else (Pnm
= Name_Assertion
29421 and then Is_Valid_Assertion_Kind
(Nam
))
29422 or else (Pnm
= Name_Statement_Assertions
29423 and then Nam_In
(Nam
, Name_Assert
,
29424 Name_Assert_And_Cut
,
29426 Name_Loop_Invariant
,
29427 Name_Loop_Variant
))
29429 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
29438 return Name_Ignore
;
29440 when Name_Disable
=>
29441 return Name_Disable
;
29444 raise Program_Error
;
29448 PP
:= Next_Pragma
(PP
);
29453 -- If there are no specific entries that matched, then we let the
29454 -- setting of assertions govern. Note that this provides the needed
29455 -- compatibility with the RM for the cases of assertion, invariant,
29456 -- precondition, predicate, and postcondition.
29458 if Assertions_Enabled
then
29461 return Name_Ignore
;
29465 ---------------------------
29466 -- Check_Missing_Part_Of --
29467 ---------------------------
29469 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
29470 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
29471 -- Determine whether a package denoted by Pack_Id declares at least one
29474 -----------------------
29475 -- Has_Visible_State --
29476 -----------------------
29478 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
29479 Item_Id
: Entity_Id
;
29482 -- Traverse the entity chain of the package trying to find at least
29483 -- one visible abstract state, variable or a package [instantiation]
29484 -- that declares a visible state.
29486 Item_Id
:= First_Entity
(Pack_Id
);
29487 while Present
(Item_Id
)
29488 and then not In_Private_Part
(Item_Id
)
29490 -- Do not consider internally generated items
29492 if not Comes_From_Source
(Item_Id
) then
29495 -- Do not consider generic formals or their corresponding actuals
29496 -- because they are not part of a visible state. Note that both
29497 -- entities are marked as hidden.
29499 elsif Is_Hidden
(Item_Id
) then
29502 -- A visible state has been found. Note that constants are not
29503 -- considered here because it is not possible to determine whether
29504 -- they depend on variable input. This check is left to the SPARK
29507 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
29510 -- Recursively peek into nested packages and instantiations
29512 elsif Ekind
(Item_Id
) = E_Package
29513 and then Has_Visible_State
(Item_Id
)
29518 Next_Entity
(Item_Id
);
29522 end Has_Visible_State
;
29526 Pack_Id
: Entity_Id
;
29527 Placement
: State_Space_Kind
;
29529 -- Start of processing for Check_Missing_Part_Of
29532 -- Do not consider abstract states, variables or package instantiations
29533 -- coming from an instance as those always inherit the Part_Of indicator
29534 -- of the instance itself.
29536 if In_Instance
then
29539 -- Do not consider internally generated entities as these can never
29540 -- have a Part_Of indicator.
29542 elsif not Comes_From_Source
(Item_Id
) then
29545 -- Perform these checks only when SPARK_Mode is enabled as they will
29546 -- interfere with standard Ada rules and produce false positives.
29548 elsif SPARK_Mode
/= On
then
29551 -- Do not consider constants, because the compiler cannot accurately
29552 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
29553 -- act as a hidden state of a package.
29555 elsif Ekind
(Item_Id
) = E_Constant
then
29559 -- Find where the abstract state, variable or package instantiation
29560 -- lives with respect to the state space.
29562 Find_Placement_In_State_Space
29563 (Item_Id
=> Item_Id
,
29564 Placement
=> Placement
,
29565 Pack_Id
=> Pack_Id
);
29567 -- Items that appear in a non-package construct (subprogram, block, etc)
29568 -- do not require a Part_Of indicator because they can never act as a
29571 if Placement
= Not_In_Package
then
29574 -- An item declared in the body state space of a package always act as a
29575 -- constituent and does not need explicit Part_Of indicator.
29577 elsif Placement
= Body_State_Space
then
29580 -- In general an item declared in the visible state space of a package
29581 -- does not require a Part_Of indicator. The only exception is when the
29582 -- related package is a nongeneric private child unit, in which case
29583 -- Part_Of must denote a state in the parent unit or in one of its
29586 elsif Placement
= Visible_State_Space
then
29587 if Is_Child_Unit
(Pack_Id
)
29588 and then not Is_Generic_Unit
(Pack_Id
)
29589 and then Is_Private_Descendant
(Pack_Id
)
29591 -- A package instantiation does not need a Part_Of indicator when
29592 -- the related generic template has no visible state.
29594 if Ekind
(Item_Id
) = E_Package
29595 and then Is_Generic_Instance
(Item_Id
)
29596 and then not Has_Visible_State
(Item_Id
)
29600 -- All other cases require Part_Of
29604 ("indicator Part_Of is required in this context "
29605 & "(SPARK RM 7.2.6(3))", Item_Id
);
29606 Error_Msg_Name_1
:= Chars
(Pack_Id
);
29608 ("\& is declared in the visible part of private child "
29609 & "unit %", Item_Id
);
29613 -- When the item appears in the private state space of a package, it
29614 -- must be a part of some state declared by the said package.
29616 else pragma Assert
(Placement
= Private_State_Space
);
29618 -- The related package does not declare a state, the item cannot act
29619 -- as a Part_Of constituent.
29621 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
29624 -- A package instantiation does not need a Part_Of indicator when the
29625 -- related generic template has no visible state.
29627 elsif Ekind
(Item_Id
) = E_Package
29628 and then Is_Generic_Instance
(Item_Id
)
29629 and then not Has_Visible_State
(Item_Id
)
29633 -- All other cases require Part_Of
29637 ("indicator Part_Of is required in this context "
29638 & "(SPARK RM 7.2.6(2))", Item_Id
);
29639 Error_Msg_Name_1
:= Chars
(Pack_Id
);
29641 ("\& is declared in the private part of package %", Item_Id
);
29644 end Check_Missing_Part_Of
;
29646 ---------------------------------------------------
29647 -- Check_Postcondition_Use_In_Inlined_Subprogram --
29648 ---------------------------------------------------
29650 procedure Check_Postcondition_Use_In_Inlined_Subprogram
29652 Spec_Id
: Entity_Id
)
29655 if Warn_On_Redundant_Constructs
29656 and then Has_Pragma_Inline_Always
(Spec_Id
)
29657 and then Assertions_Enabled
29659 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
29661 if From_Aspect_Specification
(Prag
) then
29663 ("aspect % not enforced on inlined subprogram &?r?",
29664 Corresponding_Aspect
(Prag
), Spec_Id
);
29667 ("pragma % not enforced on inlined subprogram &?r?",
29671 end Check_Postcondition_Use_In_Inlined_Subprogram
;
29673 -------------------------------------
29674 -- Check_State_And_Constituent_Use --
29675 -------------------------------------
29677 procedure Check_State_And_Constituent_Use
29678 (States
: Elist_Id
;
29679 Constits
: Elist_Id
;
29682 Constit_Elmt
: Elmt_Id
;
29683 Constit_Id
: Entity_Id
;
29684 State_Id
: Entity_Id
;
29687 -- Nothing to do if there are no states or constituents
29689 if No
(States
) or else No
(Constits
) then
29693 -- Inspect the list of constituents and try to determine whether its
29694 -- encapsulating state is in list States.
29696 Constit_Elmt
:= First_Elmt
(Constits
);
29697 while Present
(Constit_Elmt
) loop
29698 Constit_Id
:= Node
(Constit_Elmt
);
29700 -- Determine whether the constituent is part of an encapsulating
29701 -- state that appears in the same context and if this is the case,
29702 -- emit an error (SPARK RM 7.2.6(7)).
29704 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
29706 if Present
(State_Id
) then
29707 Error_Msg_Name_1
:= Chars
(Constit_Id
);
29709 ("cannot mention state & and its constituent % in the same "
29710 & "context", Context
, State_Id
);
29714 Next_Elmt
(Constit_Elmt
);
29716 end Check_State_And_Constituent_Use
;
29718 ---------------------------------------------
29719 -- Collect_Inherited_Class_Wide_Conditions --
29720 ---------------------------------------------
29722 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
29723 Parent_Subp
: constant Entity_Id
:=
29724 Ultimate_Alias
(Overridden_Operation
(Subp
));
29725 -- The Overridden_Operation may itself be inherited and as such have no
29726 -- explicit contract.
29728 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
29729 In_Spec_Expr
: Boolean;
29730 Installed
: Boolean;
29732 New_Prag
: Node_Id
;
29735 Installed
:= False;
29737 -- Iterate over the contract of the overridden subprogram to find all
29738 -- inherited class-wide pre- and postconditions.
29740 if Present
(Prags
) then
29741 Prag
:= Pre_Post_Conditions
(Prags
);
29743 while Present
(Prag
) loop
29744 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
29745 Name_Precondition
, Name_Postcondition
)
29746 and then Class_Present
(Prag
)
29748 -- The generated pragma must be analyzed in the context of
29749 -- the subprogram, to make its formals visible. In addition,
29750 -- we must inhibit freezing and full analysis because the
29751 -- controlling type of the subprogram is not frozen yet, and
29752 -- may have further primitives.
29754 if not Installed
then
29757 Install_Formals
(Subp
);
29758 In_Spec_Expr
:= In_Spec_Expression
;
29759 In_Spec_Expression
:= True;
29763 Build_Pragma_Check_Equivalent
29764 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
29766 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
29767 Preanalyze
(New_Prag
);
29769 -- Prevent further analysis in subsequent processing of the
29770 -- current list of declarations
29772 Set_Analyzed
(New_Prag
);
29775 Prag
:= Next_Pragma
(Prag
);
29779 In_Spec_Expression
:= In_Spec_Expr
;
29783 end Collect_Inherited_Class_Wide_Conditions
;
29785 ---------------------------------------
29786 -- Collect_Subprogram_Inputs_Outputs --
29787 ---------------------------------------
29789 procedure Collect_Subprogram_Inputs_Outputs
29790 (Subp_Id
: Entity_Id
;
29791 Synthesize
: Boolean := False;
29792 Subp_Inputs
: in out Elist_Id
;
29793 Subp_Outputs
: in out Elist_Id
;
29794 Global_Seen
: out Boolean)
29796 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
29797 -- Collect all relevant items from a dependency clause
29799 procedure Collect_Global_List
29801 Mode
: Name_Id
:= Name_Input
);
29802 -- Collect all relevant items from a global list
29804 -------------------------------
29805 -- Collect_Dependency_Clause --
29806 -------------------------------
29808 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
29809 procedure Collect_Dependency_Item
29811 Is_Input
: Boolean);
29812 -- Add an item to the proper subprogram input or output collection
29814 -----------------------------
29815 -- Collect_Dependency_Item --
29816 -----------------------------
29818 procedure Collect_Dependency_Item
29820 Is_Input
: Boolean)
29825 -- Nothing to collect when the item is null
29827 if Nkind
(Item
) = N_Null
then
29830 -- Ditto for attribute 'Result
29832 elsif Is_Attribute_Result
(Item
) then
29835 -- Multiple items appear as an aggregate
29837 elsif Nkind
(Item
) = N_Aggregate
then
29838 Extra
:= First
(Expressions
(Item
));
29839 while Present
(Extra
) loop
29840 Collect_Dependency_Item
(Extra
, Is_Input
);
29844 -- Otherwise this is a solitary item
29848 Append_New_Elmt
(Item
, Subp_Inputs
);
29850 Append_New_Elmt
(Item
, Subp_Outputs
);
29853 end Collect_Dependency_Item
;
29855 -- Start of processing for Collect_Dependency_Clause
29858 if Nkind
(Clause
) = N_Null
then
29861 -- A dependency clause appears as component association
29863 elsif Nkind
(Clause
) = N_Component_Association
then
29864 Collect_Dependency_Item
29865 (Item
=> Expression
(Clause
),
29868 Collect_Dependency_Item
29869 (Item
=> First
(Choices
(Clause
)),
29870 Is_Input
=> False);
29872 -- To accommodate partial decoration of disabled SPARK features, this
29873 -- routine may be called with illegal input. If this is the case, do
29874 -- not raise Program_Error.
29879 end Collect_Dependency_Clause
;
29881 -------------------------
29882 -- Collect_Global_List --
29883 -------------------------
29885 procedure Collect_Global_List
29887 Mode
: Name_Id
:= Name_Input
)
29889 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
29890 -- Add an item to the proper subprogram input or output collection
29892 -------------------------
29893 -- Collect_Global_Item --
29894 -------------------------
29896 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
29898 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
29899 Append_New_Elmt
(Item
, Subp_Inputs
);
29902 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
29903 Append_New_Elmt
(Item
, Subp_Outputs
);
29905 end Collect_Global_Item
;
29912 -- Start of processing for Collect_Global_List
29915 if Nkind
(List
) = N_Null
then
29918 -- Single global item declaration
29920 elsif Nkind_In
(List
, N_Expanded_Name
,
29922 N_Selected_Component
)
29924 Collect_Global_Item
(List
, Mode
);
29926 -- Simple global list or moded global list declaration
29928 elsif Nkind
(List
) = N_Aggregate
then
29929 if Present
(Expressions
(List
)) then
29930 Item
:= First
(Expressions
(List
));
29931 while Present
(Item
) loop
29932 Collect_Global_Item
(Item
, Mode
);
29937 Assoc
:= First
(Component_Associations
(List
));
29938 while Present
(Assoc
) loop
29939 Collect_Global_List
29940 (List
=> Expression
(Assoc
),
29941 Mode
=> Chars
(First
(Choices
(Assoc
))));
29946 -- To accommodate partial decoration of disabled SPARK features, this
29947 -- routine may be called with illegal input. If this is the case, do
29948 -- not raise Program_Error.
29953 end Collect_Global_List
;
29960 Formal
: Entity_Id
;
29962 Spec_Id
: Entity_Id
:= Empty
;
29963 Subp_Decl
: Node_Id
;
29966 -- Start of processing for Collect_Subprogram_Inputs_Outputs
29969 Global_Seen
:= False;
29971 -- Process all formal parameters of entries, [generic] subprograms, and
29974 if Ekind_In
(Subp_Id
, E_Entry
,
29977 E_Generic_Function
,
29978 E_Generic_Procedure
,
29982 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
29983 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
29985 -- Process all formal parameters
29987 Formal
:= First_Entity
(Spec_Id
);
29988 while Present
(Formal
) loop
29989 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
29990 Append_New_Elmt
(Formal
, Subp_Inputs
);
29993 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
29994 Append_New_Elmt
(Formal
, Subp_Outputs
);
29996 -- Out parameters can act as inputs when the related type is
29997 -- tagged, unconstrained array, unconstrained record, or record
29998 -- with unconstrained components.
30000 if Ekind
(Formal
) = E_Out_Parameter
30001 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
30003 Append_New_Elmt
(Formal
, Subp_Inputs
);
30007 Next_Entity
(Formal
);
30010 -- Otherwise the input denotes a task type, a task body, or the
30011 -- anonymous object created for a single task type.
30013 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
30014 or else Is_Single_Task_Object
(Subp_Id
)
30016 Subp_Decl
:= Declaration_Node
(Subp_Id
);
30017 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
30020 -- When processing an entry, subprogram or task body, look for pragmas
30021 -- Refined_Depends and Refined_Global as they specify the inputs and
30024 if Is_Entry_Body
(Subp_Id
)
30025 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
30027 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
30028 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
30030 -- Subprogram declaration or stand-alone body case, look for pragmas
30031 -- Depends and Global
30034 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
30035 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
30038 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
30039 -- because it provides finer granularity of inputs and outputs.
30041 if Present
(Global
) then
30042 Global_Seen
:= True;
30043 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
30045 -- When the related subprogram lacks pragma [Refined_]Global, fall back
30046 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
30047 -- the inputs and outputs from [Refined_]Depends.
30049 elsif Synthesize
and then Present
(Depends
) then
30050 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
30052 -- Multiple dependency clauses appear as an aggregate
30054 if Nkind
(Clauses
) = N_Aggregate
then
30055 Clause
:= First
(Component_Associations
(Clauses
));
30056 while Present
(Clause
) loop
30057 Collect_Dependency_Clause
(Clause
);
30061 -- Otherwise this is a single dependency clause
30064 Collect_Dependency_Clause
(Clauses
);
30068 -- The current instance of a protected type acts as a formal parameter
30069 -- of mode IN for functions and IN OUT for entries and procedures
30070 -- (SPARK RM 6.1.4).
30072 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
30073 Typ
:= Scope
(Spec_Id
);
30075 -- Use the anonymous object when the type is single protected
30077 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30078 Typ
:= Anonymous_Object
(Typ
);
30081 Append_New_Elmt
(Typ
, Subp_Inputs
);
30083 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
30084 Append_New_Elmt
(Typ
, Subp_Outputs
);
30087 -- The current instance of a task type acts as a formal parameter of
30088 -- mode IN OUT (SPARK RM 6.1.4).
30090 elsif Ekind
(Spec_Id
) = E_Task_Type
then
30093 -- Use the anonymous object when the type is single task
30095 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
30096 Typ
:= Anonymous_Object
(Typ
);
30099 Append_New_Elmt
(Typ
, Subp_Inputs
);
30100 Append_New_Elmt
(Typ
, Subp_Outputs
);
30102 elsif Is_Single_Task_Object
(Spec_Id
) then
30103 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
30104 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
30106 end Collect_Subprogram_Inputs_Outputs
;
30108 ---------------------------
30109 -- Contract_Freeze_Error --
30110 ---------------------------
30112 procedure Contract_Freeze_Error
30113 (Contract_Id
: Entity_Id
;
30114 Freeze_Id
: Entity_Id
)
30117 Error_Msg_Name_1
:= Chars
(Contract_Id
);
30118 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
30121 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
30123 ("\all contractual items must be declared before body #", Contract_Id
);
30124 end Contract_Freeze_Error
;
30126 ---------------------------------
30127 -- Delay_Config_Pragma_Analyze --
30128 ---------------------------------
30130 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
30132 return Nam_In
(Pragma_Name_Unmapped
(N
),
30133 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
30134 end Delay_Config_Pragma_Analyze
;
30136 -----------------------
30137 -- Duplication_Error --
30138 -----------------------
30140 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
30141 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
30142 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
30145 Error_Msg_Sloc
:= Sloc
(Prev
);
30146 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
30148 -- Emit a precise message to distinguish between source pragmas and
30149 -- pragmas generated from aspects. The ordering of the two pragmas is
30153 -- Prag -- duplicate
30155 -- No error is emitted when both pragmas come from aspects because this
30156 -- is already detected by the general aspect analysis mechanism.
30158 if Prag_From_Asp
and Prev_From_Asp
then
30160 elsif Prag_From_Asp
then
30161 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
30162 elsif Prev_From_Asp
then
30163 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
30165 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
30167 end Duplication_Error
;
30169 ------------------------------
30170 -- Find_Encapsulating_State --
30171 ------------------------------
30173 function Find_Encapsulating_State
30174 (States
: Elist_Id
;
30175 Constit_Id
: Entity_Id
) return Entity_Id
30177 State_Id
: Entity_Id
;
30180 -- Since a constituent may be part of a larger constituent set, climb
30181 -- the encapsulating state chain looking for a state that appears in
30184 State_Id
:= Encapsulating_State
(Constit_Id
);
30185 while Present
(State_Id
) loop
30186 if Contains
(States
, State_Id
) then
30190 State_Id
:= Encapsulating_State
(State_Id
);
30194 end Find_Encapsulating_State
;
30196 --------------------------
30197 -- Find_Related_Context --
30198 --------------------------
30200 function Find_Related_Context
30202 Do_Checks
: Boolean := False) return Node_Id
30207 Stmt
:= Prev
(Prag
);
30208 while Present
(Stmt
) loop
30210 -- Skip prior pragmas, but check for duplicates
30212 if Nkind
(Stmt
) = N_Pragma
then
30214 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
30221 -- Skip internally generated code
30223 elsif not Comes_From_Source
(Stmt
) then
30225 -- The anonymous object created for a single concurrent type is a
30226 -- suitable context.
30228 if Nkind
(Stmt
) = N_Object_Declaration
30229 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30234 -- Return the current source construct
30244 end Find_Related_Context
;
30246 --------------------------------------
30247 -- Find_Related_Declaration_Or_Body --
30248 --------------------------------------
30250 function Find_Related_Declaration_Or_Body
30252 Do_Checks
: Boolean := False) return Node_Id
30254 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
30256 procedure Expression_Function_Error
;
30257 -- Emit an error concerning pragma Prag that illegaly applies to an
30258 -- expression function.
30260 -------------------------------
30261 -- Expression_Function_Error --
30262 -------------------------------
30264 procedure Expression_Function_Error
is
30266 Error_Msg_Name_1
:= Prag_Nam
;
30268 -- Emit a precise message to distinguish between source pragmas and
30269 -- pragmas generated from aspects.
30271 if From_Aspect_Specification
(Prag
) then
30273 ("aspect % cannot apply to a stand alone expression function",
30277 ("pragma % cannot apply to a stand alone expression function",
30280 end Expression_Function_Error
;
30284 Context
: constant Node_Id
:= Parent
(Prag
);
30287 Look_For_Body
: constant Boolean :=
30288 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
30289 Name_Refined_Global
,
30291 Name_Refined_State
);
30292 -- Refinement pragmas must be associated with a subprogram body [stub]
30294 -- Start of processing for Find_Related_Declaration_Or_Body
30297 Stmt
:= Prev
(Prag
);
30298 while Present
(Stmt
) loop
30300 -- Skip prior pragmas, but check for duplicates. Pragmas produced
30301 -- by splitting a complex pre/postcondition are not considered to
30304 if Nkind
(Stmt
) = N_Pragma
then
30306 and then not Split_PPC
(Stmt
)
30307 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
30314 -- Emit an error when a refinement pragma appears on an expression
30315 -- function without a completion.
30318 and then Look_For_Body
30319 and then Nkind
(Stmt
) = N_Subprogram_Declaration
30320 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
30321 and then not Has_Completion
(Defining_Entity
(Stmt
))
30323 Expression_Function_Error
;
30326 -- The refinement pragma applies to a subprogram body stub
30328 elsif Look_For_Body
30329 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
30333 -- Skip internally generated code
30335 elsif not Comes_From_Source
(Stmt
) then
30337 -- The anonymous object created for a single concurrent type is a
30338 -- suitable context.
30340 if Nkind
(Stmt
) = N_Object_Declaration
30341 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
30345 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
30347 -- The subprogram declaration is an internally generated spec
30348 -- for an expression function.
30350 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30353 -- The subprogram declaration is an internally generated spec
30354 -- for a stand-alone subrogram body declared inside a protected
30357 elsif Present
(Corresponding_Body
(Stmt
))
30358 and then Comes_From_Source
(Corresponding_Body
(Stmt
))
30359 and then Is_Protected_Type
(Current_Scope
)
30363 -- The subprogram is actually an instance housed within an
30364 -- anonymous wrapper package.
30366 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30371 -- Return the current construct which is either a subprogram body,
30372 -- a subprogram declaration or is illegal.
30381 -- If we fall through, then the pragma was either the first declaration
30382 -- or it was preceded by other pragmas and no source constructs.
30384 -- The pragma is associated with a library-level subprogram
30386 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
30387 return Unit
(Parent
(Context
));
30389 -- The pragma appears inside the declarations of an entry body
30391 elsif Nkind
(Context
) = N_Entry_Body
then
30394 -- The pragma appears inside the statements of a subprogram body. This
30395 -- placement is the result of subprogram contract expansion.
30397 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
30398 return Parent
(Context
);
30400 -- The pragma appears inside the declarative part of a package body
30402 elsif Nkind
(Context
) = N_Package_Body
then
30405 -- The pragma appears inside the declarative part of a subprogram body
30407 elsif Nkind
(Context
) = N_Subprogram_Body
then
30410 -- The pragma appears inside the declarative part of a task body
30412 elsif Nkind
(Context
) = N_Task_Body
then
30415 -- The pragma appears inside the visible part of a package specification
30417 elsif Nkind
(Context
) = N_Package_Specification
then
30418 return Parent
(Context
);
30420 -- The pragma is a byproduct of aspect expansion, return the related
30421 -- context of the original aspect. This case has a lower priority as
30422 -- the above circuitry pinpoints precisely the related context.
30424 elsif Present
(Corresponding_Aspect
(Prag
)) then
30425 return Parent
(Corresponding_Aspect
(Prag
));
30427 -- No candidate subprogram [body] found
30432 end Find_Related_Declaration_Or_Body
;
30434 ----------------------------------
30435 -- Find_Related_Package_Or_Body --
30436 ----------------------------------
30438 function Find_Related_Package_Or_Body
30440 Do_Checks
: Boolean := False) return Node_Id
30442 Context
: constant Node_Id
:= Parent
(Prag
);
30443 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
30447 Stmt
:= Prev
(Prag
);
30448 while Present
(Stmt
) loop
30450 -- Skip prior pragmas, but check for duplicates
30452 if Nkind
(Stmt
) = N_Pragma
then
30453 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
30459 -- Skip internally generated code
30461 elsif not Comes_From_Source
(Stmt
) then
30462 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
30464 -- The subprogram declaration is an internally generated spec
30465 -- for an expression function.
30467 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
30470 -- The subprogram is actually an instance housed within an
30471 -- anonymous wrapper package.
30473 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
30478 -- Return the current source construct which is illegal
30487 -- If we fall through, then the pragma was either the first declaration
30488 -- or it was preceded by other pragmas and no source constructs.
30490 -- The pragma is associated with a package. The immediate context in
30491 -- this case is the specification of the package.
30493 if Nkind
(Context
) = N_Package_Specification
then
30494 return Parent
(Context
);
30496 -- The pragma appears in the declarations of a package body
30498 elsif Nkind
(Context
) = N_Package_Body
then
30501 -- The pragma appears in the statements of a package body
30503 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
30504 and then Nkind
(Parent
(Context
)) = N_Package_Body
30506 return Parent
(Context
);
30508 -- The pragma is a byproduct of aspect expansion, return the related
30509 -- context of the original aspect. This case has a lower priority as
30510 -- the above circuitry pinpoints precisely the related context.
30512 elsif Present
(Corresponding_Aspect
(Prag
)) then
30513 return Parent
(Corresponding_Aspect
(Prag
));
30515 -- No candidate package [body] found
30520 end Find_Related_Package_Or_Body
;
30526 function Get_Argument
30528 Context_Id
: Entity_Id
:= Empty
) return Node_Id
30530 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
30533 -- Use the expression of the original aspect when compiling for ASIS or
30534 -- when analyzing the template of a generic unit. In both cases the
30535 -- aspect's tree must be decorated to allow for ASIS queries or to save
30536 -- the global references in the generic context.
30538 if From_Aspect_Specification
(Prag
)
30539 and then (ASIS_Mode
or else (Present
(Context_Id
)
30540 and then Is_Generic_Unit
(Context_Id
)))
30542 return Corresponding_Aspect
(Prag
);
30544 -- Otherwise use the expression of the pragma
30546 elsif Present
(Args
) then
30547 return First
(Args
);
30554 -------------------------
30555 -- Get_Base_Subprogram --
30556 -------------------------
30558 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
30560 -- Follow subprogram renaming chain
30562 if Is_Subprogram
(Def_Id
)
30563 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
30564 N_Subprogram_Renaming_Declaration
30565 and then Present
(Alias
(Def_Id
))
30567 return Alias
(Def_Id
);
30571 end Get_Base_Subprogram
;
30573 -----------------------
30574 -- Get_SPARK_Mode_Type --
30575 -----------------------
30577 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
30579 if N
= Name_On
then
30581 elsif N
= Name_Off
then
30584 -- Any other argument is illegal. Assume that no SPARK mode applies to
30585 -- avoid potential cascaded errors.
30590 end Get_SPARK_Mode_Type
;
30592 ------------------------------------
30593 -- Get_SPARK_Mode_From_Annotation --
30594 ------------------------------------
30596 function Get_SPARK_Mode_From_Annotation
30597 (N
: Node_Id
) return SPARK_Mode_Type
30602 if Nkind
(N
) = N_Aspect_Specification
then
30603 Mode
:= Expression
(N
);
30605 else pragma Assert
(Nkind
(N
) = N_Pragma
);
30606 Mode
:= First
(Pragma_Argument_Associations
(N
));
30608 if Present
(Mode
) then
30609 Mode
:= Get_Pragma_Arg
(Mode
);
30613 -- Aspect or pragma SPARK_Mode specifies an explicit mode
30615 if Present
(Mode
) then
30616 if Nkind
(Mode
) = N_Identifier
then
30617 return Get_SPARK_Mode_Type
(Chars
(Mode
));
30619 -- In case of a malformed aspect or pragma, return the default None
30625 -- Otherwise the lack of an expression defaults SPARK_Mode to On
30630 end Get_SPARK_Mode_From_Annotation
;
30632 ---------------------------
30633 -- Has_Extra_Parentheses --
30634 ---------------------------
30636 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
30640 -- The aggregate should not have an expression list because a clause
30641 -- is always interpreted as a component association. The only way an
30642 -- expression list can sneak in is by adding extra parentheses around
30643 -- the individual clauses:
30645 -- Depends (Output => Input) -- proper form
30646 -- Depends ((Output => Input)) -- extra parentheses
30648 -- Since the extra parentheses are not allowed by the syntax of the
30649 -- pragma, flag them now to avoid emitting misleading errors down the
30652 if Nkind
(Clause
) = N_Aggregate
30653 and then Present
(Expressions
(Clause
))
30655 Expr
:= First
(Expressions
(Clause
));
30656 while Present
(Expr
) loop
30658 -- A dependency clause surrounded by extra parentheses appears
30659 -- as an aggregate of component associations with an optional
30660 -- Paren_Count set.
30662 if Nkind
(Expr
) = N_Aggregate
30663 and then Present
(Component_Associations
(Expr
))
30666 ("dependency clause contains extra parentheses", Expr
);
30668 -- Otherwise the expression is a malformed construct
30671 SPARK_Msg_N
("malformed dependency clause", Expr
);
30681 end Has_Extra_Parentheses
;
30687 procedure Initialize
is
30698 Dummy
:= Dummy
+ 1;
30701 -----------------------------
30702 -- Is_Config_Static_String --
30703 -----------------------------
30705 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
30707 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
30708 -- This is an internal recursive function that is just like the outer
30709 -- function except that it adds the string to the name buffer rather
30710 -- than placing the string in the name buffer.
30712 ------------------------------
30713 -- Add_Config_Static_String --
30714 ------------------------------
30716 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
30723 if Nkind
(N
) = N_Op_Concat
then
30724 if Add_Config_Static_String
(Left_Opnd
(N
)) then
30725 N
:= Right_Opnd
(N
);
30731 if Nkind
(N
) /= N_String_Literal
then
30732 Error_Msg_N
("string literal expected for pragma argument", N
);
30736 for J
in 1 .. String_Length
(Strval
(N
)) loop
30737 C
:= Get_String_Char
(Strval
(N
), J
);
30739 if not In_Character_Range
(C
) then
30741 ("string literal contains invalid wide character",
30742 Sloc
(N
) + 1 + Source_Ptr
(J
));
30746 Add_Char_To_Name_Buffer
(Get_Character
(C
));
30751 end Add_Config_Static_String
;
30753 -- Start of processing for Is_Config_Static_String
30758 return Add_Config_Static_String
(Arg
);
30759 end Is_Config_Static_String
;
30761 -------------------------------
30762 -- Is_Elaboration_SPARK_Mode --
30763 -------------------------------
30765 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
30768 (Nkind
(N
) = N_Pragma
30769 and then Pragma_Name
(N
) = Name_SPARK_Mode
30770 and then Is_List_Member
(N
));
30772 -- Pragma SPARK_Mode affects the elaboration of a package body when it
30773 -- appears in the statement part of the body.
30776 Present
(Parent
(N
))
30777 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
30778 and then List_Containing
(N
) = Statements
(Parent
(N
))
30779 and then Present
(Parent
(Parent
(N
)))
30780 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
30781 end Is_Elaboration_SPARK_Mode
;
30783 -----------------------
30784 -- Is_Enabled_Pragma --
30785 -----------------------
30787 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
30791 if Present
(Prag
) then
30792 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30794 if Present
(Arg
) then
30795 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
30797 -- The lack of a Boolean argument automatically enables the pragma
30803 -- The pragma is missing, therefore it is not enabled
30808 end Is_Enabled_Pragma
;
30810 -----------------------------------------
30811 -- Is_Non_Significant_Pragma_Reference --
30812 -----------------------------------------
30814 -- This function makes use of the following static table which indicates
30815 -- whether appearance of some name in a given pragma is to be considered
30816 -- as a reference for the purposes of warnings about unreferenced objects.
30818 -- -1 indicates that appearence in any argument is significant
30819 -- 0 indicates that appearance in any argument is not significant
30820 -- +n indicates that appearance as argument n is significant, but all
30821 -- other arguments are not significant
30822 -- 9n arguments from n on are significant, before n insignificant
30824 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
30825 (Pragma_Abort_Defer
=> -1,
30826 Pragma_Abstract_State
=> -1,
30827 Pragma_Acc_Data
=> 0,
30828 Pragma_Acc_Kernels
=> 0,
30829 Pragma_Acc_Loop
=> 0,
30830 Pragma_Acc_Parallel
=> 0,
30831 Pragma_Ada_83
=> -1,
30832 Pragma_Ada_95
=> -1,
30833 Pragma_Ada_05
=> -1,
30834 Pragma_Ada_2005
=> -1,
30835 Pragma_Ada_12
=> -1,
30836 Pragma_Ada_2012
=> -1,
30837 Pragma_Ada_2020
=> -1,
30838 Pragma_All_Calls_Remote
=> -1,
30839 Pragma_Allow_Integer_Address
=> -1,
30840 Pragma_Annotate
=> 93,
30841 Pragma_Assert
=> -1,
30842 Pragma_Assert_And_Cut
=> -1,
30843 Pragma_Assertion_Policy
=> 0,
30844 Pragma_Assume
=> -1,
30845 Pragma_Assume_No_Invalid_Values
=> 0,
30846 Pragma_Async_Readers
=> 0,
30847 Pragma_Async_Writers
=> 0,
30848 Pragma_Asynchronous
=> 0,
30849 Pragma_Atomic
=> 0,
30850 Pragma_Atomic_Components
=> 0,
30851 Pragma_Attach_Handler
=> -1,
30852 Pragma_Attribute_Definition
=> 92,
30853 Pragma_Check
=> -1,
30854 Pragma_Check_Float_Overflow
=> 0,
30855 Pragma_Check_Name
=> 0,
30856 Pragma_Check_Policy
=> 0,
30857 Pragma_CPP_Class
=> 0,
30858 Pragma_CPP_Constructor
=> 0,
30859 Pragma_CPP_Virtual
=> 0,
30860 Pragma_CPP_Vtable
=> 0,
30862 Pragma_C_Pass_By_Copy
=> 0,
30863 Pragma_Comment
=> -1,
30864 Pragma_Common_Object
=> 0,
30865 Pragma_Compile_Time_Error
=> -1,
30866 Pragma_Compile_Time_Warning
=> -1,
30867 Pragma_Compiler_Unit
=> -1,
30868 Pragma_Compiler_Unit_Warning
=> -1,
30869 Pragma_Complete_Representation
=> 0,
30870 Pragma_Complex_Representation
=> 0,
30871 Pragma_Component_Alignment
=> 0,
30872 Pragma_Constant_After_Elaboration
=> 0,
30873 Pragma_Contract_Cases
=> -1,
30874 Pragma_Controlled
=> 0,
30875 Pragma_Convention
=> 0,
30876 Pragma_Convention_Identifier
=> 0,
30877 Pragma_Deadline_Floor
=> -1,
30878 Pragma_Debug
=> -1,
30879 Pragma_Debug_Policy
=> 0,
30880 Pragma_Detect_Blocking
=> 0,
30881 Pragma_Default_Initial_Condition
=> -1,
30882 Pragma_Default_Scalar_Storage_Order
=> 0,
30883 Pragma_Default_Storage_Pool
=> 0,
30884 Pragma_Depends
=> -1,
30885 Pragma_Disable_Atomic_Synchronization
=> 0,
30886 Pragma_Discard_Names
=> 0,
30887 Pragma_Dispatching_Domain
=> -1,
30888 Pragma_Effective_Reads
=> 0,
30889 Pragma_Effective_Writes
=> 0,
30890 Pragma_Elaborate
=> 0,
30891 Pragma_Elaborate_All
=> 0,
30892 Pragma_Elaborate_Body
=> 0,
30893 Pragma_Elaboration_Checks
=> 0,
30894 Pragma_Eliminate
=> 0,
30895 Pragma_Enable_Atomic_Synchronization
=> 0,
30896 Pragma_Export
=> -1,
30897 Pragma_Export_Function
=> -1,
30898 Pragma_Export_Object
=> -1,
30899 Pragma_Export_Procedure
=> -1,
30900 Pragma_Export_Value
=> -1,
30901 Pragma_Export_Valued_Procedure
=> -1,
30902 Pragma_Extend_System
=> -1,
30903 Pragma_Extensions_Allowed
=> 0,
30904 Pragma_Extensions_Visible
=> 0,
30905 Pragma_External
=> -1,
30906 Pragma_Favor_Top_Level
=> 0,
30907 Pragma_External_Name_Casing
=> 0,
30908 Pragma_Fast_Math
=> 0,
30909 Pragma_Finalize_Storage_Only
=> 0,
30911 Pragma_Global
=> -1,
30912 Pragma_Ident
=> -1,
30913 Pragma_Ignore_Pragma
=> 0,
30914 Pragma_Implementation_Defined
=> -1,
30915 Pragma_Implemented
=> -1,
30916 Pragma_Implicit_Packing
=> 0,
30917 Pragma_Import
=> 93,
30918 Pragma_Import_Function
=> 0,
30919 Pragma_Import_Object
=> 0,
30920 Pragma_Import_Procedure
=> 0,
30921 Pragma_Import_Valued_Procedure
=> 0,
30922 Pragma_Independent
=> 0,
30923 Pragma_Independent_Components
=> 0,
30924 Pragma_Initial_Condition
=> -1,
30925 Pragma_Initialize_Scalars
=> 0,
30926 Pragma_Initializes
=> -1,
30927 Pragma_Inline
=> 0,
30928 Pragma_Inline_Always
=> 0,
30929 Pragma_Inline_Generic
=> 0,
30930 Pragma_Inspection_Point
=> -1,
30931 Pragma_Interface
=> 92,
30932 Pragma_Interface_Name
=> 0,
30933 Pragma_Interrupt_Handler
=> -1,
30934 Pragma_Interrupt_Priority
=> -1,
30935 Pragma_Interrupt_State
=> -1,
30936 Pragma_Invariant
=> -1,
30937 Pragma_Keep_Names
=> 0,
30938 Pragma_License
=> 0,
30939 Pragma_Link_With
=> -1,
30940 Pragma_Linker_Alias
=> -1,
30941 Pragma_Linker_Constructor
=> -1,
30942 Pragma_Linker_Destructor
=> -1,
30943 Pragma_Linker_Options
=> -1,
30944 Pragma_Linker_Section
=> -1,
30946 Pragma_Lock_Free
=> 0,
30947 Pragma_Locking_Policy
=> 0,
30948 Pragma_Loop_Invariant
=> -1,
30949 Pragma_Loop_Optimize
=> 0,
30950 Pragma_Loop_Variant
=> -1,
30951 Pragma_Machine_Attribute
=> -1,
30953 Pragma_Main_Storage
=> -1,
30954 Pragma_Max_Entry_Queue_Depth
=> 0,
30955 Pragma_Max_Queue_Length
=> 0,
30956 Pragma_Memory_Size
=> 0,
30957 Pragma_No_Return
=> 0,
30958 Pragma_No_Body
=> 0,
30959 Pragma_No_Component_Reordering
=> -1,
30960 Pragma_No_Elaboration_Code_All
=> 0,
30961 Pragma_No_Heap_Finalization
=> 0,
30962 Pragma_No_Inline
=> 0,
30963 Pragma_No_Run_Time
=> -1,
30964 Pragma_No_Strict_Aliasing
=> -1,
30965 Pragma_No_Tagged_Streams
=> 0,
30966 Pragma_Normalize_Scalars
=> 0,
30967 Pragma_Obsolescent
=> 0,
30968 Pragma_Optimize
=> 0,
30969 Pragma_Optimize_Alignment
=> 0,
30970 Pragma_Overflow_Mode
=> 0,
30971 Pragma_Overriding_Renamings
=> 0,
30972 Pragma_Ordered
=> 0,
30975 Pragma_Part_Of
=> 0,
30976 Pragma_Partition_Elaboration_Policy
=> 0,
30977 Pragma_Passive
=> 0,
30978 Pragma_Persistent_BSS
=> 0,
30979 Pragma_Polling
=> 0,
30980 Pragma_Prefix_Exception_Messages
=> 0,
30982 Pragma_Postcondition
=> -1,
30983 Pragma_Post_Class
=> -1,
30985 Pragma_Precondition
=> -1,
30986 Pragma_Predicate
=> -1,
30987 Pragma_Predicate_Failure
=> -1,
30988 Pragma_Preelaborable_Initialization
=> -1,
30989 Pragma_Preelaborate
=> 0,
30990 Pragma_Pre_Class
=> -1,
30991 Pragma_Priority
=> -1,
30992 Pragma_Priority_Specific_Dispatching
=> 0,
30993 Pragma_Profile
=> 0,
30994 Pragma_Profile_Warnings
=> 0,
30995 Pragma_Propagate_Exceptions
=> 0,
30996 Pragma_Provide_Shift_Operators
=> 0,
30997 Pragma_Psect_Object
=> 0,
30999 Pragma_Pure_Function
=> 0,
31000 Pragma_Queuing_Policy
=> 0,
31001 Pragma_Rational
=> 0,
31002 Pragma_Ravenscar
=> 0,
31003 Pragma_Refined_Depends
=> -1,
31004 Pragma_Refined_Global
=> -1,
31005 Pragma_Refined_Post
=> -1,
31006 Pragma_Refined_State
=> -1,
31007 Pragma_Relative_Deadline
=> 0,
31008 Pragma_Rename_Pragma
=> 0,
31009 Pragma_Remote_Access_Type
=> -1,
31010 Pragma_Remote_Call_Interface
=> -1,
31011 Pragma_Remote_Types
=> -1,
31012 Pragma_Restricted_Run_Time
=> 0,
31013 Pragma_Restriction_Warnings
=> 0,
31014 Pragma_Restrictions
=> 0,
31015 Pragma_Reviewable
=> -1,
31016 Pragma_Secondary_Stack_Size
=> -1,
31017 Pragma_Short_Circuit_And_Or
=> 0,
31018 Pragma_Share_Generic
=> 0,
31019 Pragma_Shared
=> 0,
31020 Pragma_Shared_Passive
=> 0,
31021 Pragma_Short_Descriptors
=> 0,
31022 Pragma_Simple_Storage_Pool_Type
=> 0,
31023 Pragma_Source_File_Name
=> 0,
31024 Pragma_Source_File_Name_Project
=> 0,
31025 Pragma_Source_Reference
=> 0,
31026 Pragma_SPARK_Mode
=> 0,
31027 Pragma_Storage_Size
=> -1,
31028 Pragma_Storage_Unit
=> 0,
31029 Pragma_Static_Elaboration_Desired
=> 0,
31030 Pragma_Stream_Convert
=> 0,
31031 Pragma_Style_Checks
=> 0,
31032 Pragma_Subtitle
=> 0,
31033 Pragma_Suppress
=> 0,
31034 Pragma_Suppress_Exception_Locations
=> 0,
31035 Pragma_Suppress_All
=> 0,
31036 Pragma_Suppress_Debug_Info
=> 0,
31037 Pragma_Suppress_Initialization
=> 0,
31038 Pragma_System_Name
=> 0,
31039 Pragma_Task_Dispatching_Policy
=> 0,
31040 Pragma_Task_Info
=> -1,
31041 Pragma_Task_Name
=> -1,
31042 Pragma_Task_Storage
=> -1,
31043 Pragma_Test_Case
=> -1,
31044 Pragma_Thread_Local_Storage
=> -1,
31045 Pragma_Time_Slice
=> -1,
31047 Pragma_Type_Invariant
=> -1,
31048 Pragma_Type_Invariant_Class
=> -1,
31049 Pragma_Unchecked_Union
=> 0,
31050 Pragma_Unevaluated_Use_Of_Old
=> 0,
31051 Pragma_Unimplemented_Unit
=> 0,
31052 Pragma_Universal_Aliasing
=> 0,
31053 Pragma_Universal_Data
=> 0,
31054 Pragma_Unmodified
=> 0,
31055 Pragma_Unreferenced
=> 0,
31056 Pragma_Unreferenced_Objects
=> 0,
31057 Pragma_Unreserve_All_Interrupts
=> 0,
31058 Pragma_Unsuppress
=> 0,
31059 Pragma_Unused
=> 0,
31060 Pragma_Use_VADS_Size
=> 0,
31061 Pragma_Validity_Checks
=> 0,
31062 Pragma_Volatile
=> 0,
31063 Pragma_Volatile_Components
=> 0,
31064 Pragma_Volatile_Full_Access
=> 0,
31065 Pragma_Volatile_Function
=> 0,
31066 Pragma_Warning_As_Error
=> 0,
31067 Pragma_Warnings
=> 0,
31068 Pragma_Weak_External
=> 0,
31069 Pragma_Wide_Character_Encoding
=> 0,
31070 Unknown_Pragma
=> 0);
31072 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
31078 function Arg_No
return Nat
;
31079 -- Returns an integer showing what argument we are in. A value of
31080 -- zero means we are not in any of the arguments.
31086 function Arg_No
return Nat
is
31091 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
31105 -- Start of processing for Non_Significant_Pragma_Reference
31110 if Nkind
(P
) /= N_Pragma_Argument_Association
then
31114 Id
:= Get_Pragma_Id
(Parent
(P
));
31115 C
:= Sig_Flags
(Id
);
31130 return AN
< (C
- 90);
31136 end Is_Non_Significant_Pragma_Reference
;
31138 ------------------------------
31139 -- Is_Pragma_String_Literal --
31140 ------------------------------
31142 -- This function returns true if the corresponding pragma argument is a
31143 -- static string expression. These are the only cases in which string
31144 -- literals can appear as pragma arguments. We also allow a string literal
31145 -- as the first argument to pragma Assert (although it will of course
31146 -- always generate a type error).
31148 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
31149 Pragn
: constant Node_Id
:= Parent
(Par
);
31150 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
31151 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
31157 N
:= First
(Assoc
);
31164 if Pname
= Name_Assert
then
31167 elsif Pname
= Name_Export
then
31170 elsif Pname
= Name_Ident
then
31173 elsif Pname
= Name_Import
then
31176 elsif Pname
= Name_Interface_Name
then
31179 elsif Pname
= Name_Linker_Alias
then
31182 elsif Pname
= Name_Linker_Section
then
31185 elsif Pname
= Name_Machine_Attribute
then
31188 elsif Pname
= Name_Source_File_Name
then
31191 elsif Pname
= Name_Source_Reference
then
31194 elsif Pname
= Name_Title
then
31197 elsif Pname
= Name_Subtitle
then
31203 end Is_Pragma_String_Literal
;
31205 ---------------------------
31206 -- Is_Private_SPARK_Mode --
31207 ---------------------------
31209 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
31212 (Nkind
(N
) = N_Pragma
31213 and then Pragma_Name
(N
) = Name_SPARK_Mode
31214 and then Is_List_Member
(N
));
31216 -- For pragma SPARK_Mode to be private, it has to appear in the private
31217 -- declarations of a package.
31220 Present
(Parent
(N
))
31221 and then Nkind
(Parent
(N
)) = N_Package_Specification
31222 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
31223 end Is_Private_SPARK_Mode
;
31225 -------------------------------------
31226 -- Is_Unconstrained_Or_Tagged_Item --
31227 -------------------------------------
31229 function Is_Unconstrained_Or_Tagged_Item
31230 (Item
: Entity_Id
) return Boolean
31232 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
31233 -- Determine whether record type Typ has at least one unconstrained
31236 ---------------------------------
31237 -- Has_Unconstrained_Component --
31238 ---------------------------------
31240 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
31244 Comp
:= First_Component
(Typ
);
31245 while Present
(Comp
) loop
31246 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
31250 Next_Component
(Comp
);
31254 end Has_Unconstrained_Component
;
31258 Typ
: constant Entity_Id
:= Etype
(Item
);
31260 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
31263 if Is_Tagged_Type
(Typ
) then
31266 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
31269 elsif Is_Record_Type
(Typ
) then
31270 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
31273 return Has_Unconstrained_Component
(Typ
);
31276 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
31282 end Is_Unconstrained_Or_Tagged_Item
;
31284 -----------------------------
31285 -- Is_Valid_Assertion_Kind --
31286 -----------------------------
31288 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
31295 | Name_Assertion_Policy
31296 | Name_Static_Predicate
31297 | Name_Dynamic_Predicate
31302 | Name_Type_Invariant
31303 | Name_uType_Invariant
31307 | Name_Assert_And_Cut
31309 | Name_Contract_Cases
31311 | Name_Default_Initial_Condition
31313 | Name_Initial_Condition
31316 | Name_Loop_Invariant
31317 | Name_Loop_Variant
31318 | Name_Postcondition
31319 | Name_Precondition
31321 | Name_Refined_Post
31322 | Name_Statement_Assertions
31329 end Is_Valid_Assertion_Kind
;
31331 --------------------------------------
31332 -- Process_Compilation_Unit_Pragmas --
31333 --------------------------------------
31335 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
31337 -- A special check for pragma Suppress_All, a very strange DEC pragma,
31338 -- strange because it comes at the end of the unit. Rational has the
31339 -- same name for a pragma, but treats it as a program unit pragma, In
31340 -- GNAT we just decide to allow it anywhere at all. If it appeared then
31341 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
31342 -- node, and we insert a pragma Suppress (All_Checks) at the start of
31343 -- the context clause to ensure the correct processing.
31345 if Has_Pragma_Suppress_All
(N
) then
31346 Prepend_To
(Context_Items
(N
),
31347 Make_Pragma
(Sloc
(N
),
31348 Chars
=> Name_Suppress
,
31349 Pragma_Argument_Associations
=> New_List
(
31350 Make_Pragma_Argument_Association
(Sloc
(N
),
31351 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
31354 -- Nothing else to do at the current time
31356 end Process_Compilation_Unit_Pragmas
;
31358 -------------------------------------------
31359 -- Process_Compile_Time_Warning_Or_Error --
31360 -------------------------------------------
31362 procedure Process_Compile_Time_Warning_Or_Error
31366 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
31367 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
31368 Arg2
: constant Node_Id
:= Next
(Arg1
);
31371 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
31373 if Compile_Time_Known_Value
(Arg1x
) then
31374 if Is_True
(Expr_Value
(Arg1x
)) then
31376 -- We have already verified that the second argument is a static
31377 -- string expression. Its string value must be retrieved
31378 -- explicitly if it is a declared constant, otherwise it has
31379 -- been constant-folded previously.
31382 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
31383 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
31384 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
31385 Str
: constant String_Id
:=
31386 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg2
)));
31387 Str_Len
: constant Nat
:= String_Length
(Str
);
31389 Force
: constant Boolean :=
31390 Prag_Id
= Pragma_Compile_Time_Warning
31391 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
31392 and then (Ekind
(Cent
) /= E_Package
31393 or else not In_Private_Part
(Cent
));
31394 -- Set True if this is the warning case, and we are in the
31395 -- visible part of a package spec, or in a subprogram spec,
31396 -- in which case we want to force the client to see the
31397 -- warning, even though it is not in the main unit.
31405 -- Loop through segments of message separated by line feeds.
31406 -- We output these segments as separate messages with
31407 -- continuation marks for all but the first.
31412 Error_Msg_Strlen
:= 0;
31414 -- Loop to copy characters from argument to error message
31418 exit when Ptr
> Str_Len
;
31419 CC
:= Get_String_Char
(Str
, Ptr
);
31422 -- Ignore wide chars ??? else store character
31424 if In_Character_Range
(CC
) then
31425 C
:= Get_Character
(CC
);
31426 exit when C
= ASCII
.LF
;
31427 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
31428 Error_Msg_String
(Error_Msg_Strlen
) := C
;
31432 -- Here with one line ready to go
31434 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
31436 -- If this is a warning in a spec, then we want clients
31437 -- to see the warning, so mark the message with the
31438 -- special sequence !! to force the warning. In the case
31439 -- of a package spec, we do not force this if we are in
31440 -- the private part of the spec.
31443 if Cont
= False then
31444 Error_Msg
("<<~!!", Eloc
);
31447 Error_Msg
("\<<~!!", Eloc
);
31450 -- Error, rather than warning, or in a body, so we do not
31451 -- need to force visibility for client (error will be
31452 -- output in any case, and this is the situation in which
31453 -- we do not want a client to get a warning, since the
31454 -- warning is in the body or the spec private part).
31457 if Cont
= False then
31458 Error_Msg
("<<~", Eloc
);
31461 Error_Msg
("\<<~", Eloc
);
31465 exit when Ptr
> Str_Len
;
31470 end Process_Compile_Time_Warning_Or_Error
;
31472 ------------------------------------
31473 -- Record_Possible_Body_Reference --
31474 ------------------------------------
31476 procedure Record_Possible_Body_Reference
31477 (State_Id
: Entity_Id
;
31481 Spec_Id
: Entity_Id
;
31484 -- Ensure that we are dealing with a reference to a state
31486 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
31488 -- Climb the tree starting from the reference looking for a package body
31489 -- whose spec declares the referenced state. This criteria automatically
31490 -- excludes references in package specs which are legal. Note that it is
31491 -- not wise to emit an error now as the package body may lack pragma
31492 -- Refined_State or the referenced state may not be mentioned in the
31493 -- refinement. This approach avoids the generation of misleading errors.
31496 while Present
(Context
) loop
31497 if Nkind
(Context
) = N_Package_Body
then
31498 Spec_Id
:= Corresponding_Spec
(Context
);
31500 if Present
(Abstract_States
(Spec_Id
))
31501 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
31503 if No
(Body_References
(State_Id
)) then
31504 Set_Body_References
(State_Id
, New_Elmt_List
);
31507 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
31512 Context
:= Parent
(Context
);
31514 end Record_Possible_Body_Reference
;
31516 ------------------------------------------
31517 -- Relocate_Pragmas_To_Anonymous_Object --
31518 ------------------------------------------
31520 procedure Relocate_Pragmas_To_Anonymous_Object
31521 (Typ_Decl
: Node_Id
;
31522 Obj_Decl
: Node_Id
)
31526 Next_Decl
: Node_Id
;
31529 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
31530 Def
:= Protected_Definition
(Typ_Decl
);
31532 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
31533 Def
:= Task_Definition
(Typ_Decl
);
31536 -- The concurrent definition has a visible declaration list. Inspect it
31537 -- and relocate all canidate pragmas.
31539 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
31540 Decl
:= First
(Visible_Declarations
(Def
));
31541 while Present
(Decl
) loop
31543 -- Preserve the following declaration for iteration purposes due
31544 -- to possible relocation of a pragma.
31546 Next_Decl
:= Next
(Decl
);
31548 if Nkind
(Decl
) = N_Pragma
31549 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
31552 Insert_After
(Obj_Decl
, Decl
);
31554 -- Skip internally generated code
31556 elsif not Comes_From_Source
(Decl
) then
31559 -- No candidate pragmas are available for relocation
31568 end Relocate_Pragmas_To_Anonymous_Object
;
31570 ------------------------------
31571 -- Relocate_Pragmas_To_Body --
31572 ------------------------------
31574 procedure Relocate_Pragmas_To_Body
31575 (Subp_Body
: Node_Id
;
31576 Target_Body
: Node_Id
:= Empty
)
31578 procedure Relocate_Pragma
(Prag
: Node_Id
);
31579 -- Remove a single pragma from its current list and add it to the
31580 -- declarations of the proper body (either Subp_Body or Target_Body).
31582 ---------------------
31583 -- Relocate_Pragma --
31584 ---------------------
31586 procedure Relocate_Pragma
(Prag
: Node_Id
) is
31591 -- When subprogram stubs or expression functions are involves, the
31592 -- destination declaration list belongs to the proper body.
31594 if Present
(Target_Body
) then
31595 Target
:= Target_Body
;
31597 Target
:= Subp_Body
;
31600 Decls
:= Declarations
(Target
);
31604 Set_Declarations
(Target
, Decls
);
31607 -- Unhook the pragma from its current list
31610 Prepend
(Prag
, Decls
);
31611 end Relocate_Pragma
;
31615 Body_Id
: constant Entity_Id
:=
31616 Defining_Unit_Name
(Specification
(Subp_Body
));
31617 Next_Stmt
: Node_Id
;
31620 -- Start of processing for Relocate_Pragmas_To_Body
31623 -- Do not process a body that comes from a separate unit as no construct
31624 -- can possibly follow it.
31626 if not Is_List_Member
(Subp_Body
) then
31629 -- Do not relocate pragmas that follow a stub if the stub does not have
31632 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
31633 and then No
(Target_Body
)
31637 -- Do not process internally generated routine _Postconditions
31639 elsif Ekind
(Body_Id
) = E_Procedure
31640 and then Chars
(Body_Id
) = Name_uPostconditions
31645 -- Look at what is following the body. We are interested in certain kind
31646 -- of pragmas (either from source or byproducts of expansion) that can
31647 -- apply to a body [stub].
31649 Stmt
:= Next
(Subp_Body
);
31650 while Present
(Stmt
) loop
31652 -- Preserve the following statement for iteration purposes due to a
31653 -- possible relocation of a pragma.
31655 Next_Stmt
:= Next
(Stmt
);
31657 -- Move a candidate pragma following the body to the declarations of
31660 if Nkind
(Stmt
) = N_Pragma
31661 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
31664 -- If a source pragma Warnings follows the body, it applies to
31665 -- following statements and does not belong in the body.
31667 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
31668 and then Comes_From_Source
(Stmt
)
31672 Relocate_Pragma
(Stmt
);
31675 -- Skip internally generated code
31677 elsif not Comes_From_Source
(Stmt
) then
31680 -- No candidate pragmas are available for relocation
31688 end Relocate_Pragmas_To_Body
;
31690 -------------------
31691 -- Resolve_State --
31692 -------------------
31694 procedure Resolve_State
(N
: Node_Id
) is
31699 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
31700 Func
:= Entity
(N
);
31702 -- Handle overloading of state names by functions. Traverse the
31703 -- homonym chain looking for an abstract state.
31705 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
31706 pragma Assert
(Is_Overloaded
(N
));
31708 State
:= Homonym
(Func
);
31709 while Present
(State
) loop
31710 if Ekind
(State
) = E_Abstract_State
then
31712 -- Resolve the overloading by setting the proper entity of
31713 -- the reference to that of the state.
31715 Set_Etype
(N
, Standard_Void_Type
);
31716 Set_Entity
(N
, State
);
31717 Set_Is_Overloaded
(N
, False);
31719 Generate_Reference
(State
, N
);
31723 State
:= Homonym
(State
);
31726 -- A function can never act as a state. If the homonym chain does
31727 -- not contain a corresponding state, then something went wrong in
31728 -- the overloading mechanism.
31730 raise Program_Error
;
31735 ----------------------------
31736 -- Rewrite_Assertion_Kind --
31737 ----------------------------
31739 procedure Rewrite_Assertion_Kind
31741 From_Policy
: Boolean := False)
31747 if Nkind
(N
) = N_Attribute_Reference
31748 and then Attribute_Name
(N
) = Name_Class
31749 and then Nkind
(Prefix
(N
)) = N_Identifier
31751 case Chars
(Prefix
(N
)) is
31758 when Name_Type_Invariant
=>
31759 Nam
:= Name_uType_Invariant
;
31761 when Name_Invariant
=>
31762 Nam
:= Name_uInvariant
;
31768 -- Recommend standard use of aspect names Pre/Post
31770 elsif Nkind
(N
) = N_Identifier
31771 and then From_Policy
31772 and then Serious_Errors_Detected
= 0
31773 and then not ASIS_Mode
31775 if Chars
(N
) = Name_Precondition
31776 or else Chars
(N
) = Name_Postcondition
31778 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
31780 ("\use Assertion_Policy and aspect names Pre/Post for "
31781 & "Ada2012 conformance?", N
);
31787 if Nam
/= No_Name
then
31788 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
31790 end Rewrite_Assertion_Kind
;
31798 Dummy
:= Dummy
+ 1;
31801 --------------------------------
31802 -- Set_Encoded_Interface_Name --
31803 --------------------------------
31805 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
31806 Str
: constant String_Id
:= Strval
(S
);
31807 Len
: constant Nat
:= String_Length
(Str
);
31812 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
31815 -- Stores encoded value of character code CC. The encoding we use an
31816 -- underscore followed by four lower case hex digits.
31822 procedure Encode
is
31824 Store_String_Char
(Get_Char_Code
('_'));
31826 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
31828 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
31830 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
31832 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
31835 -- Start of processing for Set_Encoded_Interface_Name
31838 -- If first character is asterisk, this is a link name, and we leave it
31839 -- completely unmodified. We also ignore null strings (the latter case
31840 -- happens only in error cases).
31843 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
31845 Set_Interface_Name
(E
, S
);
31850 CC
:= Get_String_Char
(Str
, J
);
31852 exit when not In_Character_Range
(CC
);
31854 C
:= Get_Character
(CC
);
31856 exit when C
/= '_' and then C
/= '$'
31857 and then C
not in '0' .. '9'
31858 and then C
not in 'a' .. 'z'
31859 and then C
not in 'A' .. 'Z';
31862 Set_Interface_Name
(E
, S
);
31870 -- Here we need to encode. The encoding we use as follows:
31871 -- three underscores + four hex digits (lower case)
31875 for J
in 1 .. String_Length
(Str
) loop
31876 CC
:= Get_String_Char
(Str
, J
);
31878 if not In_Character_Range
(CC
) then
31881 C
:= Get_Character
(CC
);
31883 if C
= '_' or else C
= '$'
31884 or else C
in '0' .. '9'
31885 or else C
in 'a' .. 'z'
31886 or else C
in 'A' .. 'Z'
31888 Store_String_Char
(CC
);
31895 Set_Interface_Name
(E
,
31896 Make_String_Literal
(Sloc
(S
),
31897 Strval
=> End_String
));
31899 end Set_Encoded_Interface_Name
;
31901 ------------------------
31902 -- Set_Elab_Unit_Name --
31903 ------------------------
31905 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
31910 if Nkind
(N
) = N_Identifier
31911 and then Nkind
(With_Item
) = N_Identifier
31913 Set_Entity
(N
, Entity
(With_Item
));
31915 elsif Nkind
(N
) = N_Selected_Component
then
31916 Change_Selected_Component_To_Expanded_Name
(N
);
31917 Set_Entity
(N
, Entity
(With_Item
));
31918 Set_Entity
(Selector_Name
(N
), Entity
(N
));
31920 Pref
:= Prefix
(N
);
31921 Scop
:= Scope
(Entity
(N
));
31922 while Nkind
(Pref
) = N_Selected_Component
loop
31923 Change_Selected_Component_To_Expanded_Name
(Pref
);
31924 Set_Entity
(Selector_Name
(Pref
), Scop
);
31925 Set_Entity
(Pref
, Scop
);
31926 Pref
:= Prefix
(Pref
);
31927 Scop
:= Scope
(Scop
);
31930 Set_Entity
(Pref
, Scop
);
31933 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
31934 end Set_Elab_Unit_Name
;
31936 -------------------
31937 -- Test_Case_Arg --
31938 -------------------
31940 function Test_Case_Arg
31943 From_Aspect
: Boolean := False) return Node_Id
31945 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
31950 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
31955 -- The caller requests the aspect argument
31957 if From_Aspect
then
31958 if Present
(Aspect
)
31959 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
31961 Args
:= Expression
(Aspect
);
31963 -- "Name" and "Mode" may appear without an identifier as a
31964 -- positional association.
31966 if Present
(Expressions
(Args
)) then
31967 Arg
:= First
(Expressions
(Args
));
31969 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
31977 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
31982 -- Some or all arguments may appear as component associatons
31984 if Present
(Component_Associations
(Args
)) then
31985 Arg
:= First
(Component_Associations
(Args
));
31986 while Present
(Arg
) loop
31987 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
31996 -- Otherwise retrieve the argument directly from the pragma
31999 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
32001 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
32005 -- Skip argument "Name"
32009 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
32013 -- Skip argument "Mode"
32017 -- Arguments "Requires" and "Ensures" are optional and may not be
32020 while Present
(Arg
) loop
32021 if Chars
(Arg
) = Arg_Nam
then