1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, 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 -- Save the Ghost mode to restore on exit
475 Restore_Scope
: Boolean := False;
477 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
480 -- Do not analyze the pragma multiple times
482 if Is_Analyzed_Pragma
(N
) then
486 -- Set the Ghost mode in effect from the pragma. Due to the delayed
487 -- analysis of the pragma, the Ghost mode at point of declaration and
488 -- point of analysis may not necessarily be the same. Use the mode in
489 -- effect at the point of declaration.
493 -- Single and multiple contract cases must appear in aggregate form. If
494 -- this is not the case, then either the parser of the analysis of the
495 -- pragma failed to produce an aggregate.
497 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
499 if Present
(Component_Associations
(CCases
)) then
501 -- Ensure that the formal parameters are visible when analyzing all
502 -- clauses. This falls out of the general rule of aspects pertaining
503 -- to subprogram declarations.
505 if not In_Open_Scopes
(Spec_Id
) then
506 Restore_Scope
:= True;
507 Push_Scope
(Spec_Id
);
509 if Is_Generic_Subprogram
(Spec_Id
) then
510 Install_Generic_Formals
(Spec_Id
);
512 Install_Formals
(Spec_Id
);
516 CCase
:= First
(Component_Associations
(CCases
));
517 while Present
(CCase
) loop
518 Analyze_Contract_Case
(CCase
);
522 if Restore_Scope
then
526 -- Currently it is not possible to inline pre/postconditions on a
527 -- subprogram subject to pragma Inline_Always.
529 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
531 -- Otherwise the pragma is illegal
534 Error_Msg_N
("wrong syntax for constract cases", N
);
537 Set_Is_Analyzed_Pragma
(N
);
539 Restore_Ghost_Mode
(Saved_GM
);
540 end Analyze_Contract_Cases_In_Decl_Part
;
542 ----------------------------------
543 -- Analyze_Depends_In_Decl_Part --
544 ----------------------------------
546 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
547 Loc
: constant Source_Ptr
:= Sloc
(N
);
548 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
549 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
551 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
552 -- A list containing the entities of all the inputs processed so far.
553 -- The list is populated with unique entities because the same input
554 -- may appear in multiple input lists.
556 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
557 -- A list containing the entities of all the outputs processed so far.
558 -- The list is populated with unique entities because output items are
559 -- unique in a dependence relation.
561 Constits_Seen
: Elist_Id
:= No_Elist
;
562 -- A list containing the entities of all constituents processed so far.
563 -- It aids in detecting illegal usage of a state and a corresponding
564 -- constituent in pragma [Refinde_]Depends.
566 Global_Seen
: Boolean := False;
567 -- A flag set when pragma Global has been processed
569 Null_Output_Seen
: Boolean := False;
570 -- A flag used to track the legality of a null output
572 Result_Seen
: Boolean := False;
573 -- A flag set when Spec_Id'Result is processed
575 States_Seen
: Elist_Id
:= No_Elist
;
576 -- A list containing the entities of all states processed so far. It
577 -- helps in detecting illegal usage of a state and a corresponding
578 -- constituent in pragma [Refined_]Depends.
580 Subp_Inputs
: Elist_Id
:= No_Elist
;
581 Subp_Outputs
: Elist_Id
:= No_Elist
;
582 -- Two lists containing the full set of inputs and output of the related
583 -- subprograms. Note that these lists contain both nodes and entities.
585 Task_Input_Seen
: Boolean := False;
586 Task_Output_Seen
: Boolean := False;
587 -- Flags used to track the implicit dependence of a task unit on itself
589 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
590 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
591 -- to the name buffer. The individual kinds are as follows:
592 -- E_Abstract_State - "state"
593 -- E_Constant - "constant"
594 -- E_Generic_In_Out_Parameter - "generic parameter"
595 -- E_Generic_In_Parameter - "generic parameter"
596 -- E_In_Parameter - "parameter"
597 -- E_In_Out_Parameter - "parameter"
598 -- E_Loop_Parameter - "loop parameter"
599 -- E_Out_Parameter - "parameter"
600 -- E_Protected_Type - "current instance of protected type"
601 -- E_Task_Type - "current instance of task type"
602 -- E_Variable - "global"
604 procedure Analyze_Dependency_Clause
607 -- Verify the legality of a single dependency clause. Flag Is_Last
608 -- denotes whether Clause is the last clause in the relation.
610 procedure Check_Function_Return
;
611 -- Verify that Funtion'Result appears as one of the outputs
612 -- (SPARK RM 6.1.5(10)).
619 -- Ensure that an item fulfills its designated input and/or output role
620 -- as specified by pragma Global (if any) or the enclosing context. If
621 -- this is not the case, emit an error. Item and Item_Id denote the
622 -- attributes of an item. Flag Is_Input should be set when item comes
623 -- from an input list. Flag Self_Ref should be set when the item is an
624 -- output and the dependency clause has operator "+".
626 procedure Check_Usage
627 (Subp_Items
: Elist_Id
;
628 Used_Items
: Elist_Id
;
630 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
631 -- error if this is not the case.
633 procedure Normalize_Clause
(Clause
: Node_Id
);
634 -- Remove a self-dependency "+" from the input list of a clause
636 -----------------------------
637 -- Add_Item_To_Name_Buffer --
638 -----------------------------
640 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
642 if Ekind
(Item_Id
) = E_Abstract_State
then
643 Add_Str_To_Name_Buffer
("state");
645 elsif Ekind
(Item_Id
) = E_Constant
then
646 Add_Str_To_Name_Buffer
("constant");
648 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
649 E_Generic_In_Parameter
)
651 Add_Str_To_Name_Buffer
("generic parameter");
653 elsif Is_Formal
(Item_Id
) then
654 Add_Str_To_Name_Buffer
("parameter");
656 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
657 Add_Str_To_Name_Buffer
("loop parameter");
659 elsif Ekind
(Item_Id
) = E_Protected_Type
660 or else Is_Single_Protected_Object
(Item_Id
)
662 Add_Str_To_Name_Buffer
("current instance of protected type");
664 elsif Ekind
(Item_Id
) = E_Task_Type
665 or else Is_Single_Task_Object
(Item_Id
)
667 Add_Str_To_Name_Buffer
("current instance of task type");
669 elsif Ekind
(Item_Id
) = E_Variable
then
670 Add_Str_To_Name_Buffer
("global");
672 -- The routine should not be called with non-SPARK items
677 end Add_Item_To_Name_Buffer
;
679 -------------------------------
680 -- Analyze_Dependency_Clause --
681 -------------------------------
683 procedure Analyze_Dependency_Clause
687 procedure Analyze_Input_List
(Inputs
: Node_Id
);
688 -- Verify the legality of a single input list
690 procedure Analyze_Input_Output
695 Seen
: in out Elist_Id
;
696 Null_Seen
: in out Boolean;
697 Non_Null_Seen
: in out Boolean);
698 -- Verify the legality of a single input or output item. Flag
699 -- Is_Input should be set whenever Item is an input, False when it
700 -- denotes an output. Flag Self_Ref should be set when the item is an
701 -- output and the dependency clause has a "+". Flag Top_Level should
702 -- be set whenever Item appears immediately within an input or output
703 -- list. Seen is a collection of all abstract states, objects and
704 -- formals processed so far. Flag Null_Seen denotes whether a null
705 -- input or output has been encountered. Flag Non_Null_Seen denotes
706 -- whether a non-null input or output has been encountered.
708 ------------------------
709 -- Analyze_Input_List --
710 ------------------------
712 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
713 Inputs_Seen
: Elist_Id
:= No_Elist
;
714 -- A list containing the entities of all inputs that appear in the
715 -- current input list.
717 Non_Null_Input_Seen
: Boolean := False;
718 Null_Input_Seen
: Boolean := False;
719 -- Flags used to check the legality of an input list
724 -- Multiple inputs appear as an aggregate
726 if Nkind
(Inputs
) = N_Aggregate
then
727 if Present
(Component_Associations
(Inputs
)) then
729 ("nested dependency relations not allowed", Inputs
);
731 elsif Present
(Expressions
(Inputs
)) then
732 Input
:= First
(Expressions
(Inputs
));
733 while Present
(Input
) loop
740 Null_Seen
=> Null_Input_Seen
,
741 Non_Null_Seen
=> Non_Null_Input_Seen
);
746 -- Syntax error, always report
749 Error_Msg_N
("malformed input dependency list", Inputs
);
752 -- Process a solitary input
761 Null_Seen
=> Null_Input_Seen
,
762 Non_Null_Seen
=> Non_Null_Input_Seen
);
765 -- Detect an illegal dependency clause of the form
769 if Null_Output_Seen
and then Null_Input_Seen
then
771 ("null dependency clause cannot have a null input list",
774 end Analyze_Input_List
;
776 --------------------------
777 -- Analyze_Input_Output --
778 --------------------------
780 procedure Analyze_Input_Output
785 Seen
: in out Elist_Id
;
786 Null_Seen
: in out Boolean;
787 Non_Null_Seen
: in out Boolean)
789 procedure Current_Task_Instance_Seen
;
790 -- Set the appropriate global flag when the current instance of a
791 -- task unit is encountered.
793 --------------------------------
794 -- Current_Task_Instance_Seen --
795 --------------------------------
797 procedure Current_Task_Instance_Seen
is
800 Task_Input_Seen
:= True;
802 Task_Output_Seen
:= True;
804 end Current_Task_Instance_Seen
;
808 Is_Output
: constant Boolean := not Is_Input
;
812 -- Start of processing for Analyze_Input_Output
815 -- Multiple input or output items appear as an aggregate
817 if Nkind
(Item
) = N_Aggregate
then
818 if not Top_Level
then
819 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
821 elsif Present
(Component_Associations
(Item
)) then
823 ("nested dependency relations not allowed", Item
);
825 -- Recursively analyze the grouped items
827 elsif Present
(Expressions
(Item
)) then
828 Grouped
:= First
(Expressions
(Item
));
829 while Present
(Grouped
) loop
832 Is_Input
=> Is_Input
,
833 Self_Ref
=> Self_Ref
,
836 Null_Seen
=> Null_Seen
,
837 Non_Null_Seen
=> Non_Null_Seen
);
842 -- Syntax error, always report
845 Error_Msg_N
("malformed dependency list", Item
);
848 -- Process attribute 'Result in the context of a dependency clause
850 elsif Is_Attribute_Result
(Item
) then
851 Non_Null_Seen
:= True;
855 -- Attribute 'Result is allowed to appear on the output side of
856 -- a dependency clause (SPARK RM 6.1.5(6)).
859 SPARK_Msg_N
("function result cannot act as input", Item
);
863 ("cannot mix null and non-null dependency items", Item
);
869 -- Detect multiple uses of null in a single dependency list or
870 -- throughout the whole relation. Verify the placement of a null
871 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
873 elsif Nkind
(Item
) = N_Null
then
876 ("multiple null dependency relations not allowed", Item
);
878 elsif Non_Null_Seen
then
880 ("cannot mix null and non-null dependency items", Item
);
888 ("null output list must be the last clause in a "
889 & "dependency relation", Item
);
891 -- Catch a useless dependence of the form:
896 ("useless dependence, null depends on itself", Item
);
904 Non_Null_Seen
:= True;
907 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
911 Resolve_State
(Item
);
913 -- Find the entity of the item. If this is a renaming, climb
914 -- the renaming chain to reach the root object. Renamings of
915 -- non-entire objects do not yield an entity (Empty).
917 Item_Id
:= Entity_Of
(Item
);
919 if Present
(Item_Id
) then
923 if Ekind_In
(Item_Id
, E_Constant
, E_Loop_Parameter
)
926 -- Current instances of concurrent types
928 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
933 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
934 E_Generic_In_Parameter
,
942 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
944 -- The item denotes a concurrent type. Note that single
945 -- protected/task types are not considered here because
946 -- they behave as objects in the context of pragma
947 -- [Refined_]Depends.
949 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
951 -- This use is legal as long as the concurrent type is
952 -- the current instance of an enclosing type.
954 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
956 -- The dependence of a task unit on itself is
957 -- implicit and may or may not be explicitly
958 -- specified (SPARK RM 6.1.4).
960 if Ekind
(Item_Id
) = E_Task_Type
then
961 Current_Task_Instance_Seen
;
964 -- Otherwise this is not the current instance
968 ("invalid use of subtype mark in dependency "
972 -- The dependency of a task unit on itself is implicit
973 -- and may or may not be explicitly specified
976 elsif Is_Single_Task_Object
(Item_Id
)
977 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
979 Current_Task_Instance_Seen
;
982 -- Ensure that the item fulfills its role as input and/or
983 -- output as specified by pragma Global or the enclosing
986 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
988 -- Detect multiple uses of the same state, variable or
989 -- formal parameter. If this is not the case, add the
990 -- item to the list of processed relations.
992 if Contains
(Seen
, Item_Id
) then
994 ("duplicate use of item &", Item
, Item_Id
);
996 Append_New_Elmt
(Item_Id
, Seen
);
999 -- Detect illegal use of an input related to a null
1000 -- output. Such input items cannot appear in other
1001 -- input lists (SPARK RM 6.1.5(13)).
1004 and then Null_Output_Seen
1005 and then Contains
(All_Inputs_Seen
, Item_Id
)
1008 ("input of a null output list cannot appear in "
1009 & "multiple input lists", Item
);
1012 -- Add an input or a self-referential output to the list
1013 -- of all processed inputs.
1015 if Is_Input
or else Self_Ref
then
1016 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1019 -- State related checks (SPARK RM 6.1.5(3))
1021 if Ekind
(Item_Id
) = E_Abstract_State
then
1023 -- Package and subprogram bodies are instantiated
1024 -- individually in a separate compiler pass. Due to
1025 -- this mode of instantiation, the refinement of a
1026 -- state may no longer be visible when a subprogram
1027 -- body contract is instantiated. Since the generic
1028 -- template is legal, do not perform this check in
1029 -- the instance to circumvent this oddity.
1031 if Is_Generic_Instance
(Spec_Id
) then
1034 -- An abstract state with visible refinement cannot
1035 -- appear in pragma [Refined_]Depends as its place
1036 -- must be taken by some of its constituents
1037 -- (SPARK RM 6.1.4(7)).
1039 elsif Has_Visible_Refinement
(Item_Id
) then
1041 ("cannot mention state & in dependence relation",
1043 SPARK_Msg_N
("\use its constituents instead", Item
);
1046 -- If the reference to the abstract state appears in
1047 -- an enclosing package body that will eventually
1048 -- refine the state, record the reference for future
1052 Record_Possible_Body_Reference
1053 (State_Id
=> Item_Id
,
1058 -- When the item renames an entire object, replace the
1059 -- item with a reference to the object.
1061 if Entity
(Item
) /= Item_Id
then
1063 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1067 -- Add the entity of the current item to the list of
1070 if Ekind
(Item_Id
) = E_Abstract_State
then
1071 Append_New_Elmt
(Item_Id
, States_Seen
);
1073 -- The variable may eventually become a constituent of a
1074 -- single protected/task type. Record the reference now
1075 -- and verify its legality when analyzing the contract of
1076 -- the variable (SPARK RM 9.3).
1078 elsif Ekind
(Item_Id
) = E_Variable
then
1079 Record_Possible_Part_Of_Reference
1084 if Ekind_In
(Item_Id
, E_Abstract_State
,
1087 and then Present
(Encapsulating_State
(Item_Id
))
1089 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1092 -- All other input/output items are illegal
1093 -- (SPARK RM 6.1.5(1)).
1097 ("item must denote parameter, variable, state or "
1098 & "current instance of concurrent type", Item
);
1101 -- All other input/output items are illegal
1102 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1106 ("item must denote parameter, variable, state or current "
1107 & "instance of concurrent type", Item
);
1110 end Analyze_Input_Output
;
1118 Non_Null_Output_Seen
: Boolean := False;
1119 -- Flag used to check the legality of an output list
1121 -- Start of processing for Analyze_Dependency_Clause
1124 Inputs
:= Expression
(Clause
);
1127 -- An input list with a self-dependency appears as operator "+" where
1128 -- the actuals inputs are the right operand.
1130 if Nkind
(Inputs
) = N_Op_Plus
then
1131 Inputs
:= Right_Opnd
(Inputs
);
1135 -- Process the output_list of a dependency_clause
1137 Output
:= First
(Choices
(Clause
));
1138 while Present
(Output
) loop
1139 Analyze_Input_Output
1142 Self_Ref
=> Self_Ref
,
1144 Seen
=> All_Outputs_Seen
,
1145 Null_Seen
=> Null_Output_Seen
,
1146 Non_Null_Seen
=> Non_Null_Output_Seen
);
1151 -- Process the input_list of a dependency_clause
1153 Analyze_Input_List
(Inputs
);
1154 end Analyze_Dependency_Clause
;
1156 ---------------------------
1157 -- Check_Function_Return --
1158 ---------------------------
1160 procedure Check_Function_Return
is
1162 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1163 and then not Result_Seen
1166 ("result of & must appear in exactly one output list",
1169 end Check_Function_Return
;
1175 procedure Check_Role
1177 Item_Id
: Entity_Id
;
1182 (Item_Is_Input
: out Boolean;
1183 Item_Is_Output
: out Boolean);
1184 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1185 -- Item_Is_Output are set depending on the role.
1187 procedure Role_Error
1188 (Item_Is_Input
: Boolean;
1189 Item_Is_Output
: Boolean);
1190 -- Emit an error message concerning the incorrect use of Item in
1191 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1192 -- denote whether the item is an input and/or an output.
1199 (Item_Is_Input
: out Boolean;
1200 Item_Is_Output
: out Boolean)
1203 case Ekind
(Item_Id
) is
1207 when E_Abstract_State
=>
1209 -- When pragma Global is present it determines the mode of
1210 -- the abstract state.
1213 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1214 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1216 -- Otherwise the state has a default IN OUT mode, because it
1217 -- behaves as a variable.
1220 Item_Is_Input
:= True;
1221 Item_Is_Output
:= True;
1224 -- Constants and IN parameters
1227 | E_Generic_In_Parameter
1231 -- When pragma Global is present it determines the mode
1232 -- of constant objects as inputs (and such objects cannot
1233 -- appear as outputs in the Global contract).
1236 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1238 Item_Is_Input
:= True;
1241 Item_Is_Output
:= False;
1243 -- Variables and IN OUT parameters
1245 when E_Generic_In_Out_Parameter
1246 | E_In_Out_Parameter
1249 -- When pragma Global is present it determines the mode of
1254 -- A variable has mode IN when its type is unconstrained
1255 -- or tagged because array bounds, discriminants or tags
1259 Appears_In
(Subp_Inputs
, Item_Id
)
1260 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1262 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1264 -- Otherwise the variable has a default IN OUT mode
1267 Item_Is_Input
:= True;
1268 Item_Is_Output
:= True;
1271 when E_Out_Parameter
=>
1273 -- An OUT parameter of the related subprogram; it cannot
1274 -- appear in Global.
1276 if Scope
(Item_Id
) = Spec_Id
then
1278 -- The parameter has mode IN if its type is unconstrained
1279 -- or tagged because array bounds, discriminants or tags
1283 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1285 Item_Is_Output
:= True;
1287 -- An OUT parameter of an enclosing subprogram; it can
1288 -- appear in Global and behaves as a read-write variable.
1291 -- When pragma Global is present it determines the mode
1296 -- A variable has mode IN when its type is
1297 -- unconstrained or tagged because array
1298 -- bounds, discriminants or tags can be read.
1301 Appears_In
(Subp_Inputs
, Item_Id
)
1302 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1304 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1306 -- Otherwise the variable has a default IN OUT mode
1309 Item_Is_Input
:= True;
1310 Item_Is_Output
:= True;
1316 when E_Protected_Type
=>
1319 -- A variable has mode IN when its type is unconstrained
1320 -- or tagged because array bounds, discriminants or tags
1324 Appears_In
(Subp_Inputs
, Item_Id
)
1325 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1327 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1330 -- A protected type acts as a formal parameter of mode IN
1331 -- when it applies to a protected function.
1333 if Ekind
(Spec_Id
) = E_Function
then
1334 Item_Is_Input
:= True;
1335 Item_Is_Output
:= False;
1337 -- Otherwise the protected type acts as a formal of mode
1341 Item_Is_Input
:= True;
1342 Item_Is_Output
:= True;
1350 -- When pragma Global is present it determines the mode of
1355 Appears_In
(Subp_Inputs
, Item_Id
)
1356 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1358 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1360 -- Otherwise task types act as IN OUT parameters
1363 Item_Is_Input
:= True;
1364 Item_Is_Output
:= True;
1368 raise Program_Error
;
1376 procedure Role_Error
1377 (Item_Is_Input
: Boolean;
1378 Item_Is_Output
: Boolean)
1380 Error_Msg
: Name_Id
;
1385 -- When the item is not part of the input and the output set of
1386 -- the related subprogram, then it appears as extra in pragma
1387 -- [Refined_]Depends.
1389 if not Item_Is_Input
and then not Item_Is_Output
then
1390 Add_Item_To_Name_Buffer
(Item_Id
);
1391 Add_Str_To_Name_Buffer
1392 (" & cannot appear in dependence relation");
1394 Error_Msg
:= Name_Find
;
1395 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1397 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1399 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1400 & "set of subprogram %"), Item
, Item_Id
);
1402 -- The mode of the item and its role in pragma [Refined_]Depends
1403 -- are in conflict. Construct a detailed message explaining the
1404 -- illegality (SPARK RM 6.1.5(5-6)).
1407 if Item_Is_Input
then
1408 Add_Str_To_Name_Buffer
("read-only");
1410 Add_Str_To_Name_Buffer
("write-only");
1413 Add_Char_To_Name_Buffer
(' ');
1414 Add_Item_To_Name_Buffer
(Item_Id
);
1415 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1417 if Item_Is_Input
then
1418 Add_Str_To_Name_Buffer
("output");
1420 Add_Str_To_Name_Buffer
("input");
1423 Add_Str_To_Name_Buffer
(" in dependence relation");
1424 Error_Msg
:= Name_Find
;
1425 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1431 Item_Is_Input
: Boolean;
1432 Item_Is_Output
: Boolean;
1434 -- Start of processing for Check_Role
1437 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1442 if not Item_Is_Input
then
1443 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1446 -- Self-referential item
1449 if not Item_Is_Input
or else not Item_Is_Output
then
1450 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1455 elsif not Item_Is_Output
then
1456 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1464 procedure Check_Usage
1465 (Subp_Items
: Elist_Id
;
1466 Used_Items
: Elist_Id
;
1469 procedure Usage_Error
(Item_Id
: Entity_Id
);
1470 -- Emit an error concerning the illegal usage of an item
1476 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1477 Error_Msg
: Name_Id
;
1484 -- Unconstrained and tagged items are not part of the explicit
1485 -- input set of the related subprogram, they do not have to be
1486 -- present in a dependence relation and should not be flagged
1487 -- (SPARK RM 6.1.5(5)).
1489 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1492 Add_Item_To_Name_Buffer
(Item_Id
);
1493 Add_Str_To_Name_Buffer
1494 (" & is missing from input dependence list");
1496 Error_Msg
:= Name_Find
;
1497 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1499 ("\add `null ='> &` dependency to ignore this input",
1503 -- Output case (SPARK RM 6.1.5(10))
1508 Add_Item_To_Name_Buffer
(Item_Id
);
1509 Add_Str_To_Name_Buffer
1510 (" & is missing from output dependence list");
1512 Error_Msg
:= Name_Find
;
1513 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1521 Item_Id
: Entity_Id
;
1523 -- Start of processing for Check_Usage
1526 if No
(Subp_Items
) then
1530 -- Each input or output of the subprogram must appear in a dependency
1533 Elmt
:= First_Elmt
(Subp_Items
);
1534 while Present
(Elmt
) loop
1535 Item
:= Node
(Elmt
);
1537 if Nkind
(Item
) = N_Defining_Identifier
then
1540 Item_Id
:= Entity_Of
(Item
);
1543 -- The item does not appear in a dependency
1545 if Present
(Item_Id
)
1546 and then not Contains
(Used_Items
, Item_Id
)
1548 if Is_Formal
(Item_Id
) then
1549 Usage_Error
(Item_Id
);
1551 -- The current instance of a protected type behaves as a formal
1552 -- parameter (SPARK RM 6.1.4).
1554 elsif Ekind
(Item_Id
) = E_Protected_Type
1555 or else Is_Single_Protected_Object
(Item_Id
)
1557 Usage_Error
(Item_Id
);
1559 -- The current instance of a task type behaves as a formal
1560 -- parameter (SPARK RM 6.1.4).
1562 elsif Ekind
(Item_Id
) = E_Task_Type
1563 or else Is_Single_Task_Object
(Item_Id
)
1565 -- The dependence of a task unit on itself is implicit and
1566 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1567 -- Emit an error if only one input/output is present.
1569 if Task_Input_Seen
/= Task_Output_Seen
then
1570 Usage_Error
(Item_Id
);
1573 -- States and global objects are not used properly only when
1574 -- the subprogram is subject to pragma Global.
1576 elsif Global_Seen
then
1577 Usage_Error
(Item_Id
);
1585 ----------------------
1586 -- Normalize_Clause --
1587 ----------------------
1589 procedure Normalize_Clause
(Clause
: Node_Id
) is
1590 procedure Create_Or_Modify_Clause
1596 Multiple
: Boolean);
1597 -- Create a brand new clause to represent the self-reference or
1598 -- modify the input and/or output lists of an existing clause. Output
1599 -- denotes a self-referencial output. Outputs is the output list of a
1600 -- clause. Inputs is the input list of a clause. After denotes the
1601 -- clause after which the new clause is to be inserted. Flag In_Place
1602 -- should be set when normalizing the last output of an output list.
1603 -- Flag Multiple should be set when Output comes from a list with
1606 -----------------------------
1607 -- Create_Or_Modify_Clause --
1608 -----------------------------
1610 procedure Create_Or_Modify_Clause
1618 procedure Propagate_Output
1621 -- Handle the various cases of output propagation to the input
1622 -- list. Output denotes a self-referencial output item. Inputs
1623 -- is the input list of a clause.
1625 ----------------------
1626 -- Propagate_Output --
1627 ----------------------
1629 procedure Propagate_Output
1633 function In_Input_List
1635 Inputs
: List_Id
) return Boolean;
1636 -- Determine whether a particulat item appears in the input
1637 -- list of a clause.
1643 function In_Input_List
1645 Inputs
: List_Id
) return Boolean
1650 Elmt
:= First
(Inputs
);
1651 while Present
(Elmt
) loop
1652 if Entity_Of
(Elmt
) = Item
then
1664 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1667 -- Start of processing for Propagate_Output
1670 -- The clause is of the form:
1672 -- (Output =>+ null)
1674 -- Remove null input and replace it with a copy of the output:
1676 -- (Output => Output)
1678 if Nkind
(Inputs
) = N_Null
then
1679 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1681 -- The clause is of the form:
1683 -- (Output =>+ (Input1, ..., InputN))
1685 -- Determine whether the output is not already mentioned in the
1686 -- input list and if not, add it to the list of inputs:
1688 -- (Output => (Output, Input1, ..., InputN))
1690 elsif Nkind
(Inputs
) = N_Aggregate
then
1691 Grouped
:= Expressions
(Inputs
);
1693 if not In_Input_List
1697 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1700 -- The clause is of the form:
1702 -- (Output =>+ Input)
1704 -- If the input does not mention the output, group the two
1707 -- (Output => (Output, Input))
1709 elsif Entity_Of
(Inputs
) /= Output_Id
then
1711 Make_Aggregate
(Loc
,
1712 Expressions
=> New_List
(
1713 New_Copy_Tree
(Output
),
1714 New_Copy_Tree
(Inputs
))));
1716 end Propagate_Output
;
1720 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1721 New_Clause
: Node_Id
;
1723 -- Start of processing for Create_Or_Modify_Clause
1726 -- A null output depending on itself does not require any
1729 if Nkind
(Output
) = N_Null
then
1732 -- A function result cannot depend on itself because it cannot
1733 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1735 elsif Is_Attribute_Result
(Output
) then
1736 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1740 -- When performing the transformation in place, simply add the
1741 -- output to the list of inputs (if not already there). This
1742 -- case arises when dealing with the last output of an output
1743 -- list. Perform the normalization in place to avoid generating
1744 -- a malformed tree.
1747 Propagate_Output
(Output
, Inputs
);
1749 -- A list with multiple outputs is slowly trimmed until only
1750 -- one element remains. When this happens, replace aggregate
1751 -- with the element itself.
1755 Rewrite
(Outputs
, Output
);
1761 -- Unchain the output from its output list as it will appear in
1762 -- a new clause. Note that we cannot simply rewrite the output
1763 -- as null because this will violate the semantics of pragma
1768 -- Generate a new clause of the form:
1769 -- (Output => Inputs)
1772 Make_Component_Association
(Loc
,
1773 Choices
=> New_List
(Output
),
1774 Expression
=> New_Copy_Tree
(Inputs
));
1776 -- The new clause contains replicated content that has already
1777 -- been analyzed. There is not need to reanalyze or renormalize
1780 Set_Analyzed
(New_Clause
);
1783 (Output
=> First
(Choices
(New_Clause
)),
1784 Inputs
=> Expression
(New_Clause
));
1786 Insert_After
(After
, New_Clause
);
1788 end Create_Or_Modify_Clause
;
1792 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1794 Last_Output
: Node_Id
;
1795 Next_Output
: Node_Id
;
1798 -- Start of processing for Normalize_Clause
1801 -- A self-dependency appears as operator "+". Remove the "+" from the
1802 -- tree by moving the real inputs to their proper place.
1804 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1805 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1806 Inputs
:= Expression
(Clause
);
1808 -- Multiple outputs appear as an aggregate
1810 if Nkind
(Outputs
) = N_Aggregate
then
1811 Last_Output
:= Last
(Expressions
(Outputs
));
1813 Output
:= First
(Expressions
(Outputs
));
1814 while Present
(Output
) loop
1816 -- Normalization may remove an output from its list,
1817 -- preserve the subsequent output now.
1819 Next_Output
:= Next
(Output
);
1821 Create_Or_Modify_Clause
1826 In_Place
=> Output
= Last_Output
,
1829 Output
:= Next_Output
;
1835 Create_Or_Modify_Clause
1844 end Normalize_Clause
;
1848 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1849 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1853 Last_Clause
: Node_Id
;
1854 Restore_Scope
: Boolean := False;
1856 -- Start of processing for Analyze_Depends_In_Decl_Part
1859 -- Do not analyze the pragma multiple times
1861 if Is_Analyzed_Pragma
(N
) then
1865 -- Empty dependency list
1867 if Nkind
(Deps
) = N_Null
then
1869 -- Gather all states, objects and formal parameters that the
1870 -- subprogram may depend on. These items are obtained from the
1871 -- parameter profile or pragma [Refined_]Global (if available).
1873 Collect_Subprogram_Inputs_Outputs
1874 (Subp_Id
=> Subp_Id
,
1875 Subp_Inputs
=> Subp_Inputs
,
1876 Subp_Outputs
=> Subp_Outputs
,
1877 Global_Seen
=> Global_Seen
);
1879 -- Verify that every input or output of the subprogram appear in a
1882 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1883 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1884 Check_Function_Return
;
1886 -- Dependency clauses appear as component associations of an aggregate
1888 elsif Nkind
(Deps
) = N_Aggregate
then
1890 -- Do not attempt to perform analysis of a syntactically illegal
1891 -- clause as this will lead to misleading errors.
1893 if Has_Extra_Parentheses
(Deps
) then
1897 if Present
(Component_Associations
(Deps
)) then
1898 Last_Clause
:= Last
(Component_Associations
(Deps
));
1900 -- Gather all states, objects and formal parameters that the
1901 -- subprogram may depend on. These items are obtained from the
1902 -- parameter profile or pragma [Refined_]Global (if available).
1904 Collect_Subprogram_Inputs_Outputs
1905 (Subp_Id
=> Subp_Id
,
1906 Subp_Inputs
=> Subp_Inputs
,
1907 Subp_Outputs
=> Subp_Outputs
,
1908 Global_Seen
=> Global_Seen
);
1910 -- When pragma [Refined_]Depends appears on a single concurrent
1911 -- type, it is relocated to the anonymous object.
1913 if Is_Single_Concurrent_Object
(Spec_Id
) then
1916 -- Ensure that the formal parameters are visible when analyzing
1917 -- all clauses. This falls out of the general rule of aspects
1918 -- pertaining to subprogram declarations.
1920 elsif not In_Open_Scopes
(Spec_Id
) then
1921 Restore_Scope
:= True;
1922 Push_Scope
(Spec_Id
);
1924 if Ekind
(Spec_Id
) = E_Task_Type
then
1925 if Has_Discriminants
(Spec_Id
) then
1926 Install_Discriminants
(Spec_Id
);
1929 elsif Is_Generic_Subprogram
(Spec_Id
) then
1930 Install_Generic_Formals
(Spec_Id
);
1933 Install_Formals
(Spec_Id
);
1937 Clause
:= First
(Component_Associations
(Deps
));
1938 while Present
(Clause
) loop
1939 Errors
:= Serious_Errors_Detected
;
1941 -- The normalization mechanism may create extra clauses that
1942 -- contain replicated input and output names. There is no need
1943 -- to reanalyze them.
1945 if not Analyzed
(Clause
) then
1946 Set_Analyzed
(Clause
);
1948 Analyze_Dependency_Clause
1950 Is_Last
=> Clause
= Last_Clause
);
1953 -- Do not normalize a clause if errors were detected (count
1954 -- of Serious_Errors has increased) because the inputs and/or
1955 -- outputs may denote illegal items. Normalization is disabled
1956 -- in ASIS mode as it alters the tree by introducing new nodes
1957 -- similar to expansion.
1959 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1960 Normalize_Clause
(Clause
);
1966 if Restore_Scope
then
1970 -- Verify that every input or output of the subprogram appear in a
1973 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1974 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1975 Check_Function_Return
;
1977 -- The dependency list is malformed. This is a syntax error, always
1981 Error_Msg_N
("malformed dependency relation", Deps
);
1985 -- The top level dependency relation is malformed. This is a syntax
1986 -- error, always report.
1989 Error_Msg_N
("malformed dependency relation", Deps
);
1993 -- Ensure that a state and a corresponding constituent do not appear
1994 -- together in pragma [Refined_]Depends.
1996 Check_State_And_Constituent_Use
1997 (States
=> States_Seen
,
1998 Constits
=> Constits_Seen
,
2002 Set_Is_Analyzed_Pragma
(N
);
2003 end Analyze_Depends_In_Decl_Part
;
2005 --------------------------------------------
2006 -- Analyze_External_Property_In_Decl_Part --
2007 --------------------------------------------
2009 procedure Analyze_External_Property_In_Decl_Part
2011 Expr_Val
: out Boolean)
2013 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
2014 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2015 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2021 -- Do not analyze the pragma multiple times
2023 if Is_Analyzed_Pragma
(N
) then
2027 Error_Msg_Name_1
:= Pragma_Name
(N
);
2029 -- An external property pragma must apply to an effectively volatile
2030 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2031 -- The check is performed at the end of the declarative region due to a
2032 -- possible out-of-order arrangement of pragmas:
2035 -- pragma Async_Readers (Obj);
2036 -- pragma Volatile (Obj);
2038 if not Is_Effectively_Volatile
(Obj_Id
) then
2040 ("external property % must apply to a volatile object", N
);
2043 -- Ensure that the Boolean expression (if present) is static. A missing
2044 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2048 if Present
(Arg1
) then
2049 Expr
:= Get_Pragma_Arg
(Arg1
);
2051 if Is_OK_Static_Expression
(Expr
) then
2052 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2056 Set_Is_Analyzed_Pragma
(N
);
2057 end Analyze_External_Property_In_Decl_Part
;
2059 ---------------------------------
2060 -- Analyze_Global_In_Decl_Part --
2061 ---------------------------------
2063 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2064 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2065 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2066 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2068 Constits_Seen
: Elist_Id
:= No_Elist
;
2069 -- A list containing the entities of all constituents processed so far.
2070 -- It aids in detecting illegal usage of a state and a corresponding
2071 -- constituent in pragma [Refinde_]Global.
2073 Seen
: Elist_Id
:= No_Elist
;
2074 -- A list containing the entities of all the items processed so far. It
2075 -- plays a role in detecting distinct entities.
2077 States_Seen
: Elist_Id
:= No_Elist
;
2078 -- A list containing the entities of all states processed so far. It
2079 -- helps in detecting illegal usage of a state and a corresponding
2080 -- constituent in pragma [Refined_]Global.
2082 In_Out_Seen
: Boolean := False;
2083 Input_Seen
: Boolean := False;
2084 Output_Seen
: Boolean := False;
2085 Proof_Seen
: Boolean := False;
2086 -- Flags used to verify the consistency of modes
2088 procedure Analyze_Global_List
2090 Global_Mode
: Name_Id
:= Name_Input
);
2091 -- Verify the legality of a single global list declaration. Global_Mode
2092 -- denotes the current mode in effect.
2094 -------------------------
2095 -- Analyze_Global_List --
2096 -------------------------
2098 procedure Analyze_Global_List
2100 Global_Mode
: Name_Id
:= Name_Input
)
2102 procedure Analyze_Global_Item
2104 Global_Mode
: Name_Id
);
2105 -- Verify the legality of a single global item declaration denoted by
2106 -- Item. Global_Mode denotes the current mode in effect.
2108 procedure Check_Duplicate_Mode
2110 Status
: in out Boolean);
2111 -- Flag Status denotes whether a particular mode has been seen while
2112 -- processing a global list. This routine verifies that Mode is not a
2113 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2115 procedure Check_Mode_Restriction_In_Enclosing_Context
2117 Item_Id
: Entity_Id
);
2118 -- Verify that an item of mode In_Out or Output does not appear as an
2119 -- input in the Global aspect of an enclosing subprogram. If this is
2120 -- the case, emit an error. Item and Item_Id are respectively the
2121 -- item and its entity.
2123 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2124 -- Mode denotes either In_Out or Output. Depending on the kind of the
2125 -- related subprogram, emit an error if those two modes apply to a
2126 -- function (SPARK RM 6.1.4(10)).
2128 -------------------------
2129 -- Analyze_Global_Item --
2130 -------------------------
2132 procedure Analyze_Global_Item
2134 Global_Mode
: Name_Id
)
2136 Item_Id
: Entity_Id
;
2139 -- Detect one of the following cases
2141 -- with Global => (null, Name)
2142 -- with Global => (Name_1, null, Name_2)
2143 -- with Global => (Name, null)
2145 if Nkind
(Item
) = N_Null
then
2146 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2151 Resolve_State
(Item
);
2153 -- Find the entity of the item. If this is a renaming, climb the
2154 -- renaming chain to reach the root object. Renamings of non-
2155 -- entire objects do not yield an entity (Empty).
2157 Item_Id
:= Entity_Of
(Item
);
2159 if Present
(Item_Id
) then
2161 -- A global item may denote a formal parameter of an enclosing
2162 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2163 -- provide a better error diagnostic.
2165 if Is_Formal
(Item_Id
) then
2166 if Scope
(Item_Id
) = Spec_Id
then
2168 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2169 & "parameter of subprogram &"), Item
, Spec_Id
);
2173 -- A global item may denote a concurrent type as long as it is
2174 -- the current instance of an enclosing protected or task type
2175 -- (SPARK RM 6.1.4).
2177 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2178 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2180 -- Pragma [Refined_]Global associated with a protected
2181 -- subprogram cannot mention the current instance of a
2182 -- protected type because the instance behaves as a
2183 -- formal parameter.
2185 if Ekind
(Item_Id
) = E_Protected_Type
then
2186 if Scope
(Spec_Id
) = Item_Id
then
2187 Error_Msg_Name_1
:= Chars
(Item_Id
);
2189 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2190 & "cannot reference current instance of "
2191 & "protected type %"), Item
, Spec_Id
);
2195 -- Pragma [Refined_]Global associated with a task type
2196 -- cannot mention the current instance of a task type
2197 -- because the instance behaves as a formal parameter.
2199 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2200 if Spec_Id
= Item_Id
then
2201 Error_Msg_Name_1
:= Chars
(Item_Id
);
2203 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2204 & "cannot reference current instance of task "
2205 & "type %"), Item
, Spec_Id
);
2210 -- Otherwise the global item denotes a subtype mark that is
2211 -- not a current instance.
2215 ("invalid use of subtype mark in global list", Item
);
2219 -- A global item may denote the anonymous object created for a
2220 -- single protected/task type as long as the current instance
2221 -- is the same single type (SPARK RM 6.1.4).
2223 elsif Is_Single_Concurrent_Object
(Item_Id
)
2224 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2226 -- Pragma [Refined_]Global associated with a protected
2227 -- subprogram cannot mention the current instance of a
2228 -- protected type because the instance behaves as a formal
2231 if Is_Single_Protected_Object
(Item_Id
) then
2232 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2233 Error_Msg_Name_1
:= Chars
(Item_Id
);
2235 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2236 & "cannot reference current instance of protected "
2237 & "type %"), Item
, Spec_Id
);
2241 -- Pragma [Refined_]Global associated with a task type
2242 -- cannot mention the current instance of a task type
2243 -- because the instance behaves as a formal parameter.
2245 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2246 if Spec_Id
= Item_Id
then
2247 Error_Msg_Name_1
:= Chars
(Item_Id
);
2249 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2250 & "cannot reference current instance of task "
2251 & "type %"), Item
, Spec_Id
);
2256 -- A formal object may act as a global item inside a generic
2258 elsif Is_Formal_Object
(Item_Id
) then
2261 -- The only legal references are those to abstract states,
2262 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2264 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2270 ("global item must denote object, state or current "
2271 & "instance of concurrent type", Item
);
2275 -- State related checks
2277 if Ekind
(Item_Id
) = E_Abstract_State
then
2279 -- Package and subprogram bodies are instantiated
2280 -- individually in a separate compiler pass. Due to this
2281 -- mode of instantiation, the refinement of a state may
2282 -- no longer be visible when a subprogram body contract
2283 -- is instantiated. Since the generic template is legal,
2284 -- do not perform this check in the instance to circumvent
2287 if Is_Generic_Instance
(Spec_Id
) then
2290 -- An abstract state with visible refinement cannot appear
2291 -- in pragma [Refined_]Global as its place must be taken by
2292 -- some of its constituents (SPARK RM 6.1.4(7)).
2294 elsif Has_Visible_Refinement
(Item_Id
) then
2296 ("cannot mention state & in global refinement",
2298 SPARK_Msg_N
("\use its constituents instead", Item
);
2301 -- An external state cannot appear as a global item of a
2302 -- nonvolatile function (SPARK RM 7.1.3(8)).
2304 elsif Is_External_State
(Item_Id
)
2305 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2306 and then not Is_Volatile_Function
(Spec_Id
)
2309 ("external state & cannot act as global item of "
2310 & "nonvolatile function", Item
, Item_Id
);
2313 -- If the reference to the abstract state appears in an
2314 -- enclosing package body that will eventually refine the
2315 -- state, record the reference for future checks.
2318 Record_Possible_Body_Reference
2319 (State_Id
=> Item_Id
,
2323 -- Constant related checks
2325 elsif Ekind
(Item_Id
) = E_Constant
then
2327 -- A constant is a read-only item, therefore it cannot act
2330 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2332 ("constant & cannot act as output", Item
, Item_Id
);
2336 -- Loop parameter related checks
2338 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2340 -- A loop parameter is a read-only item, therefore it cannot
2341 -- act as an output.
2343 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2345 ("loop parameter & cannot act as output",
2350 -- Variable related checks. These are only relevant when
2351 -- SPARK_Mode is on as they are not standard Ada legality
2354 elsif SPARK_Mode
= On
2355 and then Ekind
(Item_Id
) = E_Variable
2356 and then Is_Effectively_Volatile
(Item_Id
)
2358 -- An effectively volatile object cannot appear as a global
2359 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2361 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2362 and then not Is_Volatile_Function
(Spec_Id
)
2365 ("volatile object & cannot act as global item of a "
2366 & "function", Item
, Item_Id
);
2369 -- An effectively volatile object with external property
2370 -- Effective_Reads set to True must have mode Output or
2371 -- In_Out (SPARK RM 7.1.3(10)).
2373 elsif Effective_Reads_Enabled
(Item_Id
)
2374 and then Global_Mode
= Name_Input
2377 ("volatile object & with property Effective_Reads must "
2378 & "have mode In_Out or Output", Item
, Item_Id
);
2383 -- When the item renames an entire object, replace the item
2384 -- with a reference to the object.
2386 if Entity
(Item
) /= Item_Id
then
2387 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2391 -- Some form of illegal construct masquerading as a name
2392 -- (SPARK RM 6.1.4(4)).
2396 ("global item must denote object, state or current instance "
2397 & "of concurrent type", Item
);
2401 -- Verify that an output does not appear as an input in an
2402 -- enclosing subprogram.
2404 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2405 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2408 -- The same entity might be referenced through various way.
2409 -- Check the entity of the item rather than the item itself
2410 -- (SPARK RM 6.1.4(10)).
2412 if Contains
(Seen
, Item_Id
) then
2413 SPARK_Msg_N
("duplicate global item", Item
);
2415 -- Add the entity of the current item to the list of processed
2419 Append_New_Elmt
(Item_Id
, Seen
);
2421 if Ekind
(Item_Id
) = E_Abstract_State
then
2422 Append_New_Elmt
(Item_Id
, States_Seen
);
2424 -- The variable may eventually become a constituent of a single
2425 -- protected/task type. Record the reference now and verify its
2426 -- legality when analyzing the contract of the variable
2429 elsif Ekind
(Item_Id
) = E_Variable
then
2430 Record_Possible_Part_Of_Reference
2435 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2436 and then Present
(Encapsulating_State
(Item_Id
))
2438 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2441 end Analyze_Global_Item
;
2443 --------------------------
2444 -- Check_Duplicate_Mode --
2445 --------------------------
2447 procedure Check_Duplicate_Mode
2449 Status
: in out Boolean)
2453 SPARK_Msg_N
("duplicate global mode", Mode
);
2457 end Check_Duplicate_Mode
;
2459 -------------------------------------------------
2460 -- Check_Mode_Restriction_In_Enclosing_Context --
2461 -------------------------------------------------
2463 procedure Check_Mode_Restriction_In_Enclosing_Context
2465 Item_Id
: Entity_Id
)
2467 Context
: Entity_Id
;
2469 Inputs
: Elist_Id
:= No_Elist
;
2470 Outputs
: Elist_Id
:= No_Elist
;
2473 -- Traverse the scope stack looking for enclosing subprograms
2474 -- subject to pragma [Refined_]Global.
2476 Context
:= Scope
(Subp_Id
);
2477 while Present
(Context
) and then Context
/= Standard_Standard
loop
2478 if Is_Subprogram
(Context
)
2480 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2482 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2484 Collect_Subprogram_Inputs_Outputs
2485 (Subp_Id
=> Context
,
2486 Subp_Inputs
=> Inputs
,
2487 Subp_Outputs
=> Outputs
,
2488 Global_Seen
=> Dummy
);
2490 -- The item is classified as In_Out or Output but appears as
2491 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2493 if Appears_In
(Inputs
, Item_Id
)
2494 and then not Appears_In
(Outputs
, Item_Id
)
2497 ("global item & cannot have mode In_Out or Output",
2501 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2502 & "subprogram &"), Item
, Context
);
2504 -- Stop the traversal once an error has been detected
2510 Context
:= Scope
(Context
);
2512 end Check_Mode_Restriction_In_Enclosing_Context
;
2514 ----------------------------------------
2515 -- Check_Mode_Restriction_In_Function --
2516 ----------------------------------------
2518 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2520 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2522 ("global mode & is not applicable to functions", Mode
);
2524 end Check_Mode_Restriction_In_Function
;
2532 -- Start of processing for Analyze_Global_List
2535 if Nkind
(List
) = N_Null
then
2536 Set_Analyzed
(List
);
2538 -- Single global item declaration
2540 elsif Nkind_In
(List
, N_Expanded_Name
,
2542 N_Selected_Component
)
2544 Analyze_Global_Item
(List
, Global_Mode
);
2546 -- Simple global list or moded global list declaration
2548 elsif Nkind
(List
) = N_Aggregate
then
2549 Set_Analyzed
(List
);
2551 -- The declaration of a simple global list appear as a collection
2554 if Present
(Expressions
(List
)) then
2555 if Present
(Component_Associations
(List
)) then
2557 ("cannot mix moded and non-moded global lists", List
);
2560 Item
:= First
(Expressions
(List
));
2561 while Present
(Item
) loop
2562 Analyze_Global_Item
(Item
, Global_Mode
);
2566 -- The declaration of a moded global list appears as a collection
2567 -- of component associations where individual choices denote
2570 elsif Present
(Component_Associations
(List
)) then
2571 if Present
(Expressions
(List
)) then
2573 ("cannot mix moded and non-moded global lists", List
);
2576 Assoc
:= First
(Component_Associations
(List
));
2577 while Present
(Assoc
) loop
2578 Mode
:= First
(Choices
(Assoc
));
2580 if Nkind
(Mode
) = N_Identifier
then
2581 if Chars
(Mode
) = Name_In_Out
then
2582 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2583 Check_Mode_Restriction_In_Function
(Mode
);
2585 elsif Chars
(Mode
) = Name_Input
then
2586 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2588 elsif Chars
(Mode
) = Name_Output
then
2589 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2590 Check_Mode_Restriction_In_Function
(Mode
);
2592 elsif Chars
(Mode
) = Name_Proof_In
then
2593 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2596 SPARK_Msg_N
("invalid mode selector", Mode
);
2600 SPARK_Msg_N
("invalid mode selector", Mode
);
2603 -- Items in a moded list appear as a collection of
2604 -- expressions. Reuse the existing machinery to analyze
2608 (List
=> Expression
(Assoc
),
2609 Global_Mode
=> Chars
(Mode
));
2617 raise Program_Error
;
2620 -- Any other attempt to declare a global item is illegal. This is a
2621 -- syntax error, always report.
2624 Error_Msg_N
("malformed global list", List
);
2626 end Analyze_Global_List
;
2630 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2632 Restore_Scope
: Boolean := False;
2634 -- Start of processing for Analyze_Global_In_Decl_Part
2637 -- Do not analyze the pragma multiple times
2639 if Is_Analyzed_Pragma
(N
) then
2643 -- There is nothing to be done for a null global list
2645 if Nkind
(Items
) = N_Null
then
2646 Set_Analyzed
(Items
);
2648 -- Analyze the various forms of global lists and items. Note that some
2649 -- of these may be malformed in which case the analysis emits error
2653 -- When pragma [Refined_]Global appears on a single concurrent type,
2654 -- it is relocated to the anonymous object.
2656 if Is_Single_Concurrent_Object
(Spec_Id
) then
2659 -- Ensure that the formal parameters are visible when processing an
2660 -- item. This falls out of the general rule of aspects pertaining to
2661 -- subprogram declarations.
2663 elsif not In_Open_Scopes
(Spec_Id
) then
2664 Restore_Scope
:= True;
2665 Push_Scope
(Spec_Id
);
2667 if Ekind
(Spec_Id
) = E_Task_Type
then
2668 if Has_Discriminants
(Spec_Id
) then
2669 Install_Discriminants
(Spec_Id
);
2672 elsif Is_Generic_Subprogram
(Spec_Id
) then
2673 Install_Generic_Formals
(Spec_Id
);
2676 Install_Formals
(Spec_Id
);
2680 Analyze_Global_List
(Items
);
2682 if Restore_Scope
then
2687 -- Ensure that a state and a corresponding constituent do not appear
2688 -- together in pragma [Refined_]Global.
2690 Check_State_And_Constituent_Use
2691 (States
=> States_Seen
,
2692 Constits
=> Constits_Seen
,
2695 Set_Is_Analyzed_Pragma
(N
);
2696 end Analyze_Global_In_Decl_Part
;
2698 --------------------------------------------
2699 -- Analyze_Initial_Condition_In_Decl_Part --
2700 --------------------------------------------
2702 -- WARNING: This routine manages Ghost regions. Return statements must be
2703 -- replaced by gotos which jump to the end of the routine and restore the
2706 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2707 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2708 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2709 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2711 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2712 -- Save the Ghost mode to restore on exit
2715 -- Do not analyze the pragma multiple times
2717 if Is_Analyzed_Pragma
(N
) then
2721 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2722 -- analysis of the pragma, the Ghost mode at point of declaration and
2723 -- point of analysis may not necessarily be the same. Use the mode in
2724 -- effect at the point of declaration.
2728 -- The expression is preanalyzed because it has not been moved to its
2729 -- final place yet. A direct analysis may generate side effects and this
2730 -- is not desired at this point.
2732 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2733 Set_Is_Analyzed_Pragma
(N
);
2735 Restore_Ghost_Mode
(Saved_GM
);
2736 end Analyze_Initial_Condition_In_Decl_Part
;
2738 --------------------------------------
2739 -- Analyze_Initializes_In_Decl_Part --
2740 --------------------------------------
2742 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2743 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2744 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2746 Constits_Seen
: Elist_Id
:= No_Elist
;
2747 -- A list containing the entities of all constituents processed so far.
2748 -- It aids in detecting illegal usage of a state and a corresponding
2749 -- constituent in pragma Initializes.
2751 Items_Seen
: Elist_Id
:= No_Elist
;
2752 -- A list of all initialization items processed so far. This list is
2753 -- used to detect duplicate items.
2755 Non_Null_Seen
: Boolean := False;
2756 Null_Seen
: Boolean := False;
2757 -- Flags used to check the legality of a null initialization list
2759 States_And_Objs
: Elist_Id
:= No_Elist
;
2760 -- A list of all abstract states and objects declared in the visible
2761 -- declarations of the related package. This list is used to detect the
2762 -- legality of initialization items.
2764 States_Seen
: Elist_Id
:= No_Elist
;
2765 -- A list containing the entities of all states processed so far. It
2766 -- helps in detecting illegal usage of a state and a corresponding
2767 -- constituent in pragma Initializes.
2769 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2770 -- Verify the legality of a single initialization item
2772 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2773 -- Verify the legality of a single initialization item followed by a
2774 -- list of input items.
2776 procedure Collect_States_And_Objects
;
2777 -- Inspect the visible declarations of the related package and gather
2778 -- the entities of all abstract states and objects in States_And_Objs.
2780 ---------------------------------
2781 -- Analyze_Initialization_Item --
2782 ---------------------------------
2784 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2785 Item_Id
: Entity_Id
;
2788 -- Null initialization list
2790 if Nkind
(Item
) = N_Null
then
2792 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2794 elsif Non_Null_Seen
then
2796 ("cannot mix null and non-null initialization items", Item
);
2801 -- Initialization item
2804 Non_Null_Seen
:= True;
2808 ("cannot mix null and non-null initialization items", Item
);
2812 Resolve_State
(Item
);
2814 if Is_Entity_Name
(Item
) then
2815 Item_Id
:= Entity_Of
(Item
);
2817 if Present
(Item_Id
)
2818 and then Ekind_In
(Item_Id
, E_Abstract_State
,
2822 -- When the initialization item is undefined, it appears as
2823 -- Any_Id. Do not continue with the analysis of the item.
2825 if Item_Id
= Any_Id
then
2828 -- The state or variable must be declared in the visible
2829 -- declarations of the package (SPARK RM 7.1.5(7)).
2831 elsif not Contains
(States_And_Objs
, Item_Id
) then
2832 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2834 ("initialization item & must appear in the visible "
2835 & "declarations of package %", Item
, Item_Id
);
2837 -- Detect a duplicate use of the same initialization item
2838 -- (SPARK RM 7.1.5(5)).
2840 elsif Contains
(Items_Seen
, Item_Id
) then
2841 SPARK_Msg_N
("duplicate initialization item", Item
);
2843 -- The item is legal, add it to the list of processed states
2847 Append_New_Elmt
(Item_Id
, Items_Seen
);
2849 if Ekind
(Item_Id
) = E_Abstract_State
then
2850 Append_New_Elmt
(Item_Id
, States_Seen
);
2853 if Present
(Encapsulating_State
(Item_Id
)) then
2854 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2858 -- The item references something that is not a state or object
2859 -- (SPARK RM 7.1.5(3)).
2863 ("initialization item must denote object or state", Item
);
2866 -- Some form of illegal construct masquerading as a name
2867 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2871 ("initialization item must denote object or state", Item
);
2874 end Analyze_Initialization_Item
;
2876 ---------------------------------------------
2877 -- Analyze_Initialization_Item_With_Inputs --
2878 ---------------------------------------------
2880 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2881 Inputs_Seen
: Elist_Id
:= No_Elist
;
2882 -- A list of all inputs processed so far. This list is used to detect
2883 -- duplicate uses of an input.
2885 Non_Null_Seen
: Boolean := False;
2886 Null_Seen
: Boolean := False;
2887 -- Flags used to check the legality of an input list
2889 procedure Analyze_Input_Item
(Input
: Node_Id
);
2890 -- Verify the legality of a single input item
2892 ------------------------
2893 -- Analyze_Input_Item --
2894 ------------------------
2896 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2897 Input_Id
: Entity_Id
;
2898 Input_OK
: Boolean := True;
2903 if Nkind
(Input
) = N_Null
then
2906 ("multiple null initializations not allowed", Item
);
2908 elsif Non_Null_Seen
then
2910 ("cannot mix null and non-null initialization item", Item
);
2918 Non_Null_Seen
:= True;
2922 ("cannot mix null and non-null initialization item", Item
);
2926 Resolve_State
(Input
);
2928 if Is_Entity_Name
(Input
) then
2929 Input_Id
:= Entity_Of
(Input
);
2931 if Present
(Input_Id
)
2932 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2934 E_Generic_In_Out_Parameter
,
2935 E_Generic_In_Parameter
,
2941 -- The input cannot denote states or objects declared
2942 -- within the related package (SPARK RM 7.1.5(4)).
2944 if Within_Scope
(Input_Id
, Current_Scope
) then
2946 -- Do not consider generic formal parameters or their
2947 -- respective mappings to generic formals. Even though
2948 -- the formals appear within the scope of the package,
2949 -- it is allowed for an initialization item to depend
2950 -- on an input item.
2952 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2953 E_Generic_In_Parameter
)
2957 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2958 and then Present
(Corresponding_Generic_Association
2959 (Declaration_Node
(Input_Id
)))
2965 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2967 ("input item & cannot denote a visible object or "
2968 & "state of package %", Input
, Input_Id
);
2972 -- Detect a duplicate use of the same input item
2973 -- (SPARK RM 7.1.5(5)).
2975 if Contains
(Inputs_Seen
, Input_Id
) then
2977 SPARK_Msg_N
("duplicate input item", Input
);
2980 -- Input is legal, add it to the list of processed inputs
2983 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2985 if Ekind
(Input_Id
) = E_Abstract_State
then
2986 Append_New_Elmt
(Input_Id
, States_Seen
);
2989 if Ekind_In
(Input_Id
, E_Abstract_State
,
2992 and then Present
(Encapsulating_State
(Input_Id
))
2994 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2998 -- The input references something that is not a state or an
2999 -- object (SPARK RM 7.1.5(3)).
3003 ("input item must denote object or state", Input
);
3006 -- Some form of illegal construct masquerading as a name
3007 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3011 ("input item must denote object or state", Input
);
3014 end Analyze_Input_Item
;
3018 Inputs
: constant Node_Id
:= Expression
(Item
);
3022 Name_Seen
: Boolean := False;
3023 -- A flag used to detect multiple item names
3025 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3028 -- Inspect the name of an item with inputs
3030 Elmt
:= First
(Choices
(Item
));
3031 while Present
(Elmt
) loop
3033 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3036 Analyze_Initialization_Item
(Elmt
);
3042 -- Multiple input items appear as an aggregate
3044 if Nkind
(Inputs
) = N_Aggregate
then
3045 if Present
(Expressions
(Inputs
)) then
3046 Input
:= First
(Expressions
(Inputs
));
3047 while Present
(Input
) loop
3048 Analyze_Input_Item
(Input
);
3053 if Present
(Component_Associations
(Inputs
)) then
3055 ("inputs must appear in named association form", Inputs
);
3058 -- Single input item
3061 Analyze_Input_Item
(Inputs
);
3063 end Analyze_Initialization_Item_With_Inputs
;
3065 --------------------------------
3066 -- Collect_States_And_Objects --
3067 --------------------------------
3069 procedure Collect_States_And_Objects
is
3070 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3074 -- Collect the abstract states defined in the package (if any)
3076 if Present
(Abstract_States
(Pack_Id
)) then
3077 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3080 -- Collect all objects that appear in the visible declarations of the
3083 if Present
(Visible_Declarations
(Pack_Spec
)) then
3084 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3085 while Present
(Decl
) loop
3086 if Comes_From_Source
(Decl
)
3087 and then Nkind_In
(Decl
, N_Object_Declaration
,
3088 N_Object_Renaming_Declaration
)
3090 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3092 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3094 (Anonymous_Object
(Defining_Entity
(Decl
)),
3101 end Collect_States_And_Objects
;
3105 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3108 -- Start of processing for Analyze_Initializes_In_Decl_Part
3111 -- Do not analyze the pragma multiple times
3113 if Is_Analyzed_Pragma
(N
) then
3117 -- Nothing to do when the initialization list is empty
3119 if Nkind
(Inits
) = N_Null
then
3123 -- Single and multiple initialization clauses appear as an aggregate. If
3124 -- this is not the case, then either the parser or the analysis of the
3125 -- pragma failed to produce an aggregate.
3127 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3129 -- Initialize the various lists used during analysis
3131 Collect_States_And_Objects
;
3133 if Present
(Expressions
(Inits
)) then
3134 Init
:= First
(Expressions
(Inits
));
3135 while Present
(Init
) loop
3136 Analyze_Initialization_Item
(Init
);
3141 if Present
(Component_Associations
(Inits
)) then
3142 Init
:= First
(Component_Associations
(Inits
));
3143 while Present
(Init
) loop
3144 Analyze_Initialization_Item_With_Inputs
(Init
);
3149 -- Ensure that a state and a corresponding constituent do not appear
3150 -- together in pragma Initializes.
3152 Check_State_And_Constituent_Use
3153 (States
=> States_Seen
,
3154 Constits
=> Constits_Seen
,
3157 Set_Is_Analyzed_Pragma
(N
);
3158 end Analyze_Initializes_In_Decl_Part
;
3160 ---------------------
3161 -- Analyze_Part_Of --
3162 ---------------------
3164 procedure Analyze_Part_Of
3166 Item_Id
: Entity_Id
;
3168 Encap_Id
: out Entity_Id
;
3169 Legal
: out Boolean)
3171 Encap_Typ
: Entity_Id
;
3172 Item_Decl
: Node_Id
;
3173 Pack_Id
: Entity_Id
;
3174 Placement
: State_Space_Kind
;
3175 Parent_Unit
: Entity_Id
;
3178 -- Assume that the indicator is illegal
3183 if Nkind_In
(Encap
, N_Expanded_Name
,
3185 N_Selected_Component
)
3188 Resolve_State
(Encap
);
3190 Encap_Id
:= Entity
(Encap
);
3192 -- The encapsulator is an abstract state
3194 if Ekind
(Encap_Id
) = E_Abstract_State
then
3197 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3199 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3202 -- Otherwise the encapsulator is not a legal choice
3206 ("indicator Part_Of must denote abstract state, single "
3207 & "protected type or single task type", Encap
);
3211 -- This is a syntax error, always report
3215 ("indicator Part_Of must denote abstract state, single protected "
3216 & "type or single task type", Encap
);
3220 -- Catch a case where indicator Part_Of denotes the abstract view of a
3221 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3223 if From_Limited_With
(Encap_Id
)
3224 and then Present
(Non_Limited_View
(Encap_Id
))
3225 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3227 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3228 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3232 -- The encapsulator is an abstract state
3234 if Ekind
(Encap_Id
) = E_Abstract_State
then
3236 -- Determine where the object, package instantiation or state lives
3237 -- with respect to the enclosing packages or package bodies.
3239 Find_Placement_In_State_Space
3240 (Item_Id
=> Item_Id
,
3241 Placement
=> Placement
,
3242 Pack_Id
=> Pack_Id
);
3244 -- The item appears in a non-package construct with a declarative
3245 -- part (subprogram, block, etc). As such, the item is not allowed
3246 -- to be a part of an encapsulating state because the item is not
3249 if Placement
= Not_In_Package
then
3251 ("indicator Part_Of cannot appear in this context "
3252 & "(SPARK RM 7.2.6(5))", Indic
);
3253 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3255 ("\& is not part of the hidden state of package %",
3259 -- The item appears in the visible state space of some package. In
3260 -- general this scenario does not warrant Part_Of except when the
3261 -- package is a private child unit and the encapsulating state is
3262 -- declared in a parent unit or a public descendant of that parent
3265 elsif Placement
= Visible_State_Space
then
3266 if Is_Child_Unit
(Pack_Id
)
3267 and then Is_Private_Descendant
(Pack_Id
)
3269 -- A variable or state abstraction which is part of the visible
3270 -- state of a private child unit (or one of its public
3271 -- descendants) must have its Part_Of indicator specified. The
3272 -- Part_Of indicator must denote a state abstraction declared
3273 -- by either the parent unit of the private unit or by a public
3274 -- descendant of that parent unit.
3276 -- Find nearest private ancestor (which can be the current unit
3279 Parent_Unit
:= Pack_Id
;
3280 while Present
(Parent_Unit
) loop
3283 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3284 Parent_Unit
:= Scope
(Parent_Unit
);
3287 Parent_Unit
:= Scope
(Parent_Unit
);
3289 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3291 ("indicator Part_Of must denote abstract state of & "
3292 & "or of its public descendant (SPARK RM 7.2.6(3))",
3293 Indic
, Parent_Unit
);
3296 elsif Scope
(Encap_Id
) = Parent_Unit
3298 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3299 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3305 ("indicator Part_Of must denote abstract state of & "
3306 & "or of its public descendant (SPARK RM 7.2.6(3))",
3307 Indic
, Parent_Unit
);
3311 -- Indicator Part_Of is not needed when the related package is not
3312 -- a private child unit or a public descendant thereof.
3316 ("indicator Part_Of cannot appear in this context "
3317 & "(SPARK RM 7.2.6(5))", Indic
);
3318 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3320 ("\& is declared in the visible part of package %",
3325 -- When the item appears in the private state space of a package, the
3326 -- encapsulating state must be declared in the same package.
3328 elsif Placement
= Private_State_Space
then
3329 if Scope
(Encap_Id
) /= Pack_Id
then
3331 ("indicator Part_Of must denote an abstract state of "
3332 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3333 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3335 ("\& is declared in the private part of package %",
3340 -- Items declared in the body state space of a package do not need
3341 -- Part_Of indicators as the refinement has already been seen.
3345 ("indicator Part_Of cannot appear in this context "
3346 & "(SPARK RM 7.2.6(5))", Indic
);
3348 if Scope
(Encap_Id
) = Pack_Id
then
3349 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3351 ("\& is declared in the body of package %", Indic
, Item_Id
);
3357 -- The encapsulator is a single concurrent type
3360 Encap_Typ
:= Etype
(Encap_Id
);
3362 -- Only abstract states and variables can act as constituents of an
3363 -- encapsulating single concurrent type.
3365 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3368 -- The constituent is a constant
3370 elsif Ekind
(Item_Id
) = E_Constant
then
3371 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3373 (Fix_Msg
(Encap_Typ
, "constant & cannot act as constituent of "
3374 & "single protected type %"), Indic
, Item_Id
);
3377 -- The constituent is a package instantiation
3380 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3382 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3383 & "constituent of single protected type %"), Indic
, Item_Id
);
3387 -- When the item denotes an abstract state of a nested package, use
3388 -- the declaration of the package to detect proper placement.
3393 -- with Abstract_State => (State with Part_Of => T)
3395 if Ekind
(Item_Id
) = E_Abstract_State
then
3396 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3398 Item_Decl
:= Declaration_Node
(Item_Id
);
3401 -- Both the item and its encapsulating single concurrent type must
3402 -- appear in the same declarative region (SPARK RM 9.3). Note that
3403 -- privacy is ignored.
3405 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3406 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3408 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3409 & "immediately within the same region as single protected "
3410 & "type %"), Indic
, Item_Id
);
3414 -- The declaration of the item should follow the declaration of its
3415 -- encapsulating single concurrent type and must appear in the same
3416 -- declarative region (SPARK RM 9.3).
3422 N
:= Next
(Declaration_Node
(Encap_Id
));
3423 while Present
(N
) loop
3424 exit when N
= Item_Decl
;
3428 -- The single concurrent type might be in the visible part of a
3429 -- package, and the declaration of the item in the private part
3430 -- of the same package.
3434 Pack
: constant Node_Id
:=
3435 Parent
(Declaration_Node
(Encap_Id
));
3437 if Nkind
(Pack
) = N_Package_Specification
3438 and then not In_Private_Part
(Encap_Id
)
3440 N
:= First
(Private_Declarations
(Pack
));
3441 while Present
(N
) loop
3442 exit when N
= Item_Decl
;
3451 ("indicator Part_Of must denote a previously declared "
3452 & "single protected type or single task type", Encap
);
3459 end Analyze_Part_Of
;
3461 ----------------------------------
3462 -- Analyze_Part_Of_In_Decl_Part --
3463 ----------------------------------
3465 procedure Analyze_Part_Of_In_Decl_Part
3467 Freeze_Id
: Entity_Id
:= Empty
)
3469 Encap
: constant Node_Id
:=
3470 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3471 Errors
: constant Nat
:= Serious_Errors_Detected
;
3472 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3473 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3474 Constits
: Elist_Id
;
3475 Encap_Id
: Entity_Id
;
3479 -- Detect any discrepancies between the placement of the variable with
3480 -- respect to general state space and the encapsulating state or single
3487 Encap_Id
=> Encap_Id
,
3490 -- The Part_Of indicator turns the variable into a constituent of the
3491 -- encapsulating state or single concurrent type.
3494 pragma Assert
(Present
(Encap_Id
));
3495 Constits
:= Part_Of_Constituents
(Encap_Id
);
3497 if No
(Constits
) then
3498 Constits
:= New_Elmt_List
;
3499 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3502 Append_Elmt
(Var_Id
, Constits
);
3503 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3505 -- A Part_Of constituent partially refines an abstract state. This
3506 -- property does not apply to protected or task units.
3508 if Ekind
(Encap_Id
) = E_Abstract_State
then
3509 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3513 -- Emit a clarification message when the encapsulator is undefined,
3514 -- possibly due to contract freezing.
3516 if Errors
/= Serious_Errors_Detected
3517 and then Present
(Freeze_Id
)
3518 and then Has_Undefined_Reference
(Encap
)
3520 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3522 end Analyze_Part_Of_In_Decl_Part
;
3524 --------------------
3525 -- Analyze_Pragma --
3526 --------------------
3528 procedure Analyze_Pragma
(N
: Node_Id
) is
3529 Loc
: constant Source_Ptr
:= Sloc
(N
);
3531 Pname
: Name_Id
:= Pragma_Name
(N
);
3532 -- Name of the source pragma, or name of the corresponding aspect for
3533 -- pragmas which originate in a source aspect. In the latter case, the
3534 -- name may be different from the pragma name.
3536 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3538 Pragma_Exit
: exception;
3539 -- This exception is used to exit pragma processing completely. It
3540 -- is used when an error is detected, and no further processing is
3541 -- required. It is also used if an earlier error has left the tree in
3542 -- a state where the pragma should not be processed.
3545 -- Number of pragma argument associations
3551 -- First four pragma arguments (pragma argument association nodes, or
3552 -- Empty if the corresponding argument does not exist).
3554 type Name_List
is array (Natural range <>) of Name_Id
;
3555 type Args_List
is array (Natural range <>) of Node_Id
;
3556 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3558 -----------------------
3559 -- Local Subprograms --
3560 -----------------------
3562 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3563 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3564 -- get the given string argument, and place it in Name_Buffer, adding
3565 -- leading and trailing asterisks if they are not already present. The
3566 -- caller has already checked that Arg is a static string expression.
3568 procedure Ada_2005_Pragma
;
3569 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3570 -- Ada 95 mode, these are implementation defined pragmas, so should be
3571 -- caught by the No_Implementation_Pragmas restriction.
3573 procedure Ada_2012_Pragma
;
3574 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3575 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3576 -- should be caught by the No_Implementation_Pragmas restriction.
3578 procedure Analyze_Depends_Global
3579 (Spec_Id
: out Entity_Id
;
3580 Subp_Decl
: out Node_Id
;
3581 Legal
: out Boolean);
3582 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3583 -- legality of the placement and related context of the pragma. Spec_Id
3584 -- is the entity of the related subprogram. Subp_Decl is the declaration
3585 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3587 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3588 -- Inspect the remainder of the list containing pragma N and look for
3589 -- a pragma that matches Id. If found, analyze the pragma.
3591 procedure Analyze_Pre_Post_Condition
;
3592 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3594 procedure Analyze_Refined_Depends_Global_Post
3595 (Spec_Id
: out Entity_Id
;
3596 Body_Id
: out Entity_Id
;
3597 Legal
: out Boolean);
3598 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3599 -- Refined_Global and Refined_Post. Verify the legality of the placement
3600 -- and related context of the pragma. Spec_Id is the entity of the
3601 -- related subprogram. Body_Id is the entity of the subprogram body.
3602 -- Flag Legal is set when the pragma is legal.
3604 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3605 -- Perform full analysis of pragma Unmodified and the write aspect of
3606 -- pragma Unused. Flag Is_Unused should be set when verifying the
3607 -- semantics of pragma Unused.
3609 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3610 -- Perform full analysis of pragma Unreferenced and the read aspect of
3611 -- pragma Unused. Flag Is_Unused should be set when verifying the
3612 -- semantics of pragma Unused.
3614 procedure Check_Ada_83_Warning
;
3615 -- Issues a warning message for the current pragma if operating in Ada
3616 -- 83 mode (used for language pragmas that are not a standard part of
3617 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3620 procedure Check_Arg_Count
(Required
: Nat
);
3621 -- Check argument count for pragma is equal to given parameter. If not,
3622 -- then issue an error message and raise Pragma_Exit.
3624 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3625 -- Arg which can either be a pragma argument association, in which case
3626 -- the check is applied to the expression of the association or an
3627 -- expression directly.
3629 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3630 -- Check that an argument has the right form for an EXTERNAL_NAME
3631 -- parameter of an extended import/export pragma. The rule is that the
3632 -- name must be an identifier or string literal (in Ada 83 mode) or a
3633 -- static string expression (in Ada 95 mode).
3635 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3636 -- Check the specified argument Arg to make sure that it is an
3637 -- identifier. If not give error and raise Pragma_Exit.
3639 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3640 -- Check the specified argument Arg to make sure that it is an integer
3641 -- literal. If not give error and raise Pragma_Exit.
3643 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3644 -- Check the specified argument Arg to make sure that it has the proper
3645 -- syntactic form for a local name and meets the semantic requirements
3646 -- for a local name. The local name is analyzed as part of the
3647 -- processing for this call. In addition, the local name is required
3648 -- to represent an entity at the library level.
3650 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3651 -- Check the specified argument Arg to make sure that it has the proper
3652 -- syntactic form for a local name and meets the semantic requirements
3653 -- for a local name. The local name is analyzed as part of the
3654 -- processing for this call.
3656 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3657 -- Check the specified argument Arg to make sure that it is a valid
3658 -- locking policy name. If not give error and raise Pragma_Exit.
3660 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3661 -- Check the specified argument Arg to make sure that it is a valid
3662 -- elaboration policy name. If not give error and raise Pragma_Exit.
3664 procedure Check_Arg_Is_One_Of
3667 procedure Check_Arg_Is_One_Of
3669 N1
, N2
, N3
: Name_Id
);
3670 procedure Check_Arg_Is_One_Of
3672 N1
, N2
, N3
, N4
: Name_Id
);
3673 procedure Check_Arg_Is_One_Of
3675 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3676 -- Check the specified argument Arg to make sure that it is an
3677 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3678 -- present). If not then give error and raise Pragma_Exit.
3680 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3681 -- Check the specified argument Arg to make sure that it is a valid
3682 -- queuing policy name. If not give error and raise Pragma_Exit.
3684 procedure Check_Arg_Is_OK_Static_Expression
3686 Typ
: Entity_Id
:= Empty
);
3687 -- Check the specified argument Arg to make sure that it is a static
3688 -- expression of the given type (i.e. it will be analyzed and resolved
3689 -- using this type, which can be any valid argument to Resolve, e.g.
3690 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3691 -- Typ is left Empty, then any static expression is allowed. Includes
3692 -- checking that the argument does not raise Constraint_Error.
3694 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3695 -- Check the specified argument Arg to make sure that it is a valid task
3696 -- dispatching policy name. If not give error and raise Pragma_Exit.
3698 procedure Check_Arg_Order
(Names
: Name_List
);
3699 -- Checks for an instance of two arguments with identifiers for the
3700 -- current pragma which are not in the sequence indicated by Names,
3701 -- and if so, generates a fatal message about bad order of arguments.
3703 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3704 -- Check there are at least N arguments present
3706 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3707 -- Check there are no more than N arguments present
3709 procedure Check_Component
3712 In_Variant_Part
: Boolean := False);
3713 -- Examine an Unchecked_Union component for correct use of per-object
3714 -- constrained subtypes, and for restrictions on finalizable components.
3715 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3716 -- should be set when Comp comes from a record variant.
3718 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3719 -- Check if a rep item of the same name as the current pragma is already
3720 -- chained as a rep pragma to the given entity. If so give a message
3721 -- about the duplicate, and then raise Pragma_Exit so does not return.
3722 -- Note that if E is a type, then this routine avoids flagging a pragma
3723 -- which applies to a parent type from which E is derived.
3725 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3726 -- Nam is an N_String_Literal node containing the external name set by
3727 -- an Import or Export pragma (or extended Import or Export pragma).
3728 -- This procedure checks for possible duplications if this is the export
3729 -- case, and if found, issues an appropriate error message.
3731 procedure Check_Expr_Is_OK_Static_Expression
3733 Typ
: Entity_Id
:= Empty
);
3734 -- Check the specified expression Expr to make sure that it is a static
3735 -- expression of the given type (i.e. it will be analyzed and resolved
3736 -- using this type, which can be any valid argument to Resolve, e.g.
3737 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3738 -- Typ is left Empty, then any static expression is allowed. Includes
3739 -- checking that the expression does not raise Constraint_Error.
3741 procedure Check_First_Subtype
(Arg
: Node_Id
);
3742 -- Checks that Arg, whose expression is an entity name, references a
3745 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3746 -- Checks that the given argument has an identifier, and if so, requires
3747 -- it to match the given identifier name. If there is no identifier, or
3748 -- a non-matching identifier, then an error message is given and
3749 -- Pragma_Exit is raised.
3751 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3752 -- Checks that the given argument has an identifier, and if so, requires
3753 -- it to match one of the given identifier names. If there is no
3754 -- identifier, or a non-matching identifier, then an error message is
3755 -- given and Pragma_Exit is raised.
3757 procedure Check_In_Main_Program
;
3758 -- Common checks for pragmas that appear within a main program
3759 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3761 procedure Check_Interrupt_Or_Attach_Handler
;
3762 -- Common processing for first argument of pragma Interrupt_Handler or
3763 -- pragma Attach_Handler.
3765 procedure Check_Loop_Pragma_Placement
;
3766 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3767 -- appear immediately within a construct restricted to loops, and that
3768 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3770 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3771 -- Check that pragma appears in a declarative part, or in a package
3772 -- specification, i.e. that it does not occur in a statement sequence
3775 procedure Check_No_Identifier
(Arg
: Node_Id
);
3776 -- Checks that the given argument does not have an identifier. If
3777 -- an identifier is present, then an error message is issued, and
3778 -- Pragma_Exit is raised.
3780 procedure Check_No_Identifiers
;
3781 -- Checks that none of the arguments to the pragma has an identifier.
3782 -- If any argument has an identifier, then an error message is issued,
3783 -- and Pragma_Exit is raised.
3785 procedure Check_No_Link_Name
;
3786 -- Checks that no link name is specified
3788 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3789 -- Checks if the given argument has an identifier, and if so, requires
3790 -- it to match the given identifier name. If there is a non-matching
3791 -- identifier, then an error message is given and Pragma_Exit is raised.
3793 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3794 -- Checks if the given argument has an identifier, and if so, requires
3795 -- it to match the given identifier name. If there is a non-matching
3796 -- identifier, then an error message is given and Pragma_Exit is raised.
3797 -- In this version of the procedure, the identifier name is given as
3798 -- a string with lower case letters.
3800 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3801 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3802 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3803 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3804 -- is an OK static boolean expression. Emit an error if this is not the
3807 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3808 -- Constr is a constraint from an N_Subtype_Indication node from a
3809 -- component constraint in an Unchecked_Union type. This routine checks
3810 -- that the constraint is static as required by the restrictions for
3813 procedure Check_Valid_Configuration_Pragma
;
3814 -- Legality checks for placement of a configuration pragma
3816 procedure Check_Valid_Library_Unit_Pragma
;
3817 -- Legality checks for library unit pragmas. A special case arises for
3818 -- pragmas in generic instances that come from copies of the original
3819 -- library unit pragmas in the generic templates. In the case of other
3820 -- than library level instantiations these can appear in contexts which
3821 -- would normally be invalid (they only apply to the original template
3822 -- and to library level instantiations), and they are simply ignored,
3823 -- which is implemented by rewriting them as null statements.
3825 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3826 -- Check an Unchecked_Union variant for lack of nested variants and
3827 -- presence of at least one component. UU_Typ is the related Unchecked_
3830 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3831 -- Subsidiary routine to the processing of pragmas Abstract_State,
3832 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3833 -- Refined_Global and Refined_State. Transform argument Arg into
3834 -- an aggregate if not one already. N_Null is never transformed.
3835 -- Arg may denote an aspect specification or a pragma argument
3838 procedure Error_Pragma
(Msg
: String);
3839 pragma No_Return
(Error_Pragma
);
3840 -- Outputs error message for current pragma. The message contains a %
3841 -- that will be replaced with the pragma name, and the flag is placed
3842 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3843 -- calls Fix_Error (see spec of that procedure for details).
3845 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3846 pragma No_Return
(Error_Pragma_Arg
);
3847 -- Outputs error message for current pragma. The message may contain
3848 -- a % that will be replaced with the pragma name. The parameter Arg
3849 -- may either be a pragma argument association, in which case the flag
3850 -- is placed on the expression of this association, or an expression,
3851 -- in which case the flag is placed directly on the expression. The
3852 -- message is placed using Error_Msg_N, so the message may also contain
3853 -- an & insertion character which will reference the given Arg value.
3854 -- After placing the message, Pragma_Exit is raised. Note: this routine
3855 -- calls Fix_Error (see spec of that procedure for details).
3857 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3858 pragma No_Return
(Error_Pragma_Arg
);
3859 -- Similar to above form of Error_Pragma_Arg except that two messages
3860 -- are provided, the second is a continuation comment starting with \.
3862 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3863 pragma No_Return
(Error_Pragma_Arg_Ident
);
3864 -- Outputs error message for current pragma. The message may contain a %
3865 -- that will be replaced with the pragma name. The parameter Arg must be
3866 -- a pragma argument association with a non-empty identifier (i.e. its
3867 -- Chars field must be set), and the error message is placed on the
3868 -- identifier. The message is placed using Error_Msg_N so the message
3869 -- may also contain an & insertion character which will reference
3870 -- the identifier. After placing the message, Pragma_Exit is raised.
3871 -- Note: this routine calls Fix_Error (see spec of that procedure for
3874 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3875 pragma No_Return
(Error_Pragma_Ref
);
3876 -- Outputs error message for current pragma. The message may contain
3877 -- a % that will be replaced with the pragma name. The parameter Ref
3878 -- must be an entity whose name can be referenced by & and sloc by #.
3879 -- After placing the message, Pragma_Exit is raised. Note: this routine
3880 -- calls Fix_Error (see spec of that procedure for details).
3882 function Find_Lib_Unit_Name
return Entity_Id
;
3883 -- Used for a library unit pragma to find the entity to which the
3884 -- library unit pragma applies, returns the entity found.
3886 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3887 -- If the pragma is a compilation unit pragma, the id must denote the
3888 -- compilation unit in the same compilation, and the pragma must appear
3889 -- in the list of preceding or trailing pragmas. If it is a program
3890 -- unit pragma that is not a compilation unit pragma, then the
3891 -- identifier must be visible.
3893 function Find_Unique_Parameterless_Procedure
3895 Arg
: Node_Id
) return Entity_Id
;
3896 -- Used for a procedure pragma to find the unique parameterless
3897 -- procedure identified by Name, returns it if it exists, otherwise
3898 -- errors out and uses Arg as the pragma argument for the message.
3900 function Fix_Error
(Msg
: String) return String;
3901 -- This is called prior to issuing an error message. Msg is the normal
3902 -- error message issued in the pragma case. This routine checks for the
3903 -- case of a pragma coming from an aspect in the source, and returns a
3904 -- message suitable for the aspect case as follows:
3906 -- Each substring "pragma" is replaced by "aspect"
3908 -- If "argument of" is at the start of the error message text, it is
3909 -- replaced by "entity for".
3911 -- If "argument" is at the start of the error message text, it is
3912 -- replaced by "entity".
3914 -- So for example, "argument of pragma X must be discrete type"
3915 -- returns "entity for aspect X must be a discrete type".
3917 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3918 -- be different from the pragma name). If the current pragma results
3919 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3920 -- original pragma name.
3922 procedure Gather_Associations
3924 Args
: out Args_List
);
3925 -- This procedure is used to gather the arguments for a pragma that
3926 -- permits arbitrary ordering of parameters using the normal rules
3927 -- for named and positional parameters. The Names argument is a list
3928 -- of Name_Id values that corresponds to the allowed pragma argument
3929 -- association identifiers in order. The result returned in Args is
3930 -- a list of corresponding expressions that are the pragma arguments.
3931 -- Note that this is a list of expressions, not of pragma argument
3932 -- associations (Gather_Associations has completely checked all the
3933 -- optional identifiers when it returns). An entry in Args is Empty
3934 -- on return if the corresponding argument is not present.
3936 procedure GNAT_Pragma
;
3937 -- Called for all GNAT defined pragmas to check the relevant restriction
3938 -- (No_Implementation_Pragmas).
3940 function Is_Before_First_Decl
3941 (Pragma_Node
: Node_Id
;
3942 Decls
: List_Id
) return Boolean;
3943 -- Return True if Pragma_Node is before the first declarative item in
3944 -- Decls where Decls is the list of declarative items.
3946 function Is_Configuration_Pragma
return Boolean;
3947 -- Determines if the placement of the current pragma is appropriate
3948 -- for a configuration pragma.
3950 function Is_In_Context_Clause
return Boolean;
3951 -- Returns True if pragma appears within the context clause of a unit,
3952 -- and False for any other placement (does not generate any messages).
3954 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3955 -- Analyzes the argument, and determines if it is a static string
3956 -- expression, returns True if so, False if non-static or not String.
3957 -- A special case is that a string literal returns True in Ada 83 mode
3958 -- (which has no such thing as static string expressions). Note that
3959 -- the call analyzes its argument, so this cannot be used for the case
3960 -- where an identifier might not be declared.
3962 procedure Pragma_Misplaced
;
3963 pragma No_Return
(Pragma_Misplaced
);
3964 -- Issue fatal error message for misplaced pragma
3966 procedure Process_Atomic_Independent_Shared_Volatile
;
3967 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3968 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3969 -- and treated as being identical in effect to pragma Atomic.
3971 procedure Process_Compile_Time_Warning_Or_Error
;
3972 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3974 procedure Process_Convention
3975 (C
: out Convention_Id
;
3976 Ent
: out Entity_Id
);
3977 -- Common processing for Convention, Interface, Import and Export.
3978 -- Checks first two arguments of pragma, and sets the appropriate
3979 -- convention value in the specified entity or entities. On return
3980 -- C is the convention, Ent is the referenced entity.
3982 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3983 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3984 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3986 procedure Process_Extended_Import_Export_Object_Pragma
3987 (Arg_Internal
: Node_Id
;
3988 Arg_External
: Node_Id
;
3989 Arg_Size
: Node_Id
);
3990 -- Common processing for the pragmas Import/Export_Object. The three
3991 -- arguments correspond to the three named parameters of the pragmas. An
3992 -- argument is empty if the corresponding parameter is not present in
3995 procedure Process_Extended_Import_Export_Internal_Arg
3996 (Arg_Internal
: Node_Id
:= Empty
);
3997 -- Common processing for all extended Import and Export pragmas. The
3998 -- argument is the pragma parameter for the Internal argument. If
3999 -- Arg_Internal is empty or inappropriate, an error message is posted.
4000 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4001 -- set to identify the referenced entity.
4003 procedure Process_Extended_Import_Export_Subprogram_Pragma
4004 (Arg_Internal
: Node_Id
;
4005 Arg_External
: Node_Id
;
4006 Arg_Parameter_Types
: Node_Id
;
4007 Arg_Result_Type
: Node_Id
:= Empty
;
4008 Arg_Mechanism
: Node_Id
;
4009 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4010 -- Common processing for all extended Import and Export pragmas applying
4011 -- to subprograms. The caller omits any arguments that do not apply to
4012 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4013 -- only in the Import_Function and Export_Function cases). The argument
4014 -- names correspond to the allowed pragma association identifiers.
4016 procedure Process_Generic_List
;
4017 -- Common processing for Share_Generic and Inline_Generic
4019 procedure Process_Import_Or_Interface
;
4020 -- Common processing for Import or Interface
4022 procedure Process_Import_Predefined_Type
;
4023 -- Processing for completing a type with pragma Import. This is used
4024 -- to declare types that match predefined C types, especially for cases
4025 -- without corresponding Ada predefined type.
4027 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4028 -- Inline status of a subprogram, indicated as follows:
4029 -- Suppressed: inlining is suppressed for the subprogram
4030 -- Disabled: no inlining is requested for the subprogram
4031 -- Enabled: inlining is requested/required for the subprogram
4033 procedure Process_Inline
(Status
: Inline_Status
);
4034 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4035 -- indicates the inline status specified by the pragma.
4037 procedure Process_Interface_Name
4038 (Subprogram_Def
: Entity_Id
;
4042 -- Given the last two arguments of pragma Import, pragma Export, or
4043 -- pragma Interface_Name, performs validity checks and sets the
4044 -- Interface_Name field of the given subprogram entity to the
4045 -- appropriate external or link name, depending on the arguments given.
4046 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4047 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4048 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4049 -- nor Link_Arg is present, the interface name is set to the default
4050 -- from the subprogram name. In addition, the pragma itself is passed
4051 -- to analyze any expressions in the case the pragma came from an aspect
4054 procedure Process_Interrupt_Or_Attach_Handler
;
4055 -- Common processing for Interrupt and Attach_Handler pragmas
4057 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4058 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4059 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4060 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4061 -- is not set in the Restrictions case.
4063 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4064 -- Common processing for Suppress and Unsuppress. The boolean parameter
4065 -- Suppress_Case is True for the Suppress case, and False for the
4068 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4069 -- Subsidiary to the analysis of pragmas Independent[_Components].
4070 -- Record such a pragma N applied to entity E for future checks.
4072 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4073 -- This procedure sets the Is_Exported flag for the given entity,
4074 -- checking that the entity was not previously imported. Arg is
4075 -- the argument that specified the entity. A check is also made
4076 -- for exporting inappropriate entities.
4078 procedure Set_Extended_Import_Export_External_Name
4079 (Internal_Ent
: Entity_Id
;
4080 Arg_External
: Node_Id
);
4081 -- Common processing for all extended import export pragmas. The first
4082 -- argument, Internal_Ent, is the internal entity, which has already
4083 -- been checked for validity by the caller. Arg_External is from the
4084 -- Import or Export pragma, and may be null if no External parameter
4085 -- was present. If Arg_External is present and is a non-null string
4086 -- (a null string is treated as the default), then the Interface_Name
4087 -- field of Internal_Ent is set appropriately.
4089 procedure Set_Imported
(E
: Entity_Id
);
4090 -- This procedure sets the Is_Imported flag for the given entity,
4091 -- checking that it is not previously exported or imported.
4093 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4094 -- Mech is a parameter passing mechanism (see Import_Function syntax
4095 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4096 -- has the right form, and if not issues an error message. If the
4097 -- argument has the right form then the Mechanism field of Ent is
4098 -- set appropriately.
4100 procedure Set_Rational_Profile
;
4101 -- Activate the set of configuration pragmas and permissions that make
4102 -- up the Rational profile.
4104 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4105 -- Activate the set of configuration pragmas and restrictions that make
4106 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4107 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4108 -- which is used for error messages on any constructs violating the
4111 ----------------------------------
4112 -- Acquire_Warning_Match_String --
4113 ----------------------------------
4115 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4117 String_To_Name_Buffer
4118 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4120 -- Add asterisk at start if not already there
4122 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4123 Name_Buffer
(2 .. Name_Len
+ 1) :=
4124 Name_Buffer
(1 .. Name_Len
);
4125 Name_Buffer
(1) := '*';
4126 Name_Len
:= Name_Len
+ 1;
4129 -- Add asterisk at end if not already there
4131 if Name_Buffer
(Name_Len
) /= '*' then
4132 Name_Len
:= Name_Len
+ 1;
4133 Name_Buffer
(Name_Len
) := '*';
4135 end Acquire_Warning_Match_String
;
4137 ---------------------
4138 -- Ada_2005_Pragma --
4139 ---------------------
4141 procedure Ada_2005_Pragma
is
4143 if Ada_Version
<= Ada_95
then
4144 Check_Restriction
(No_Implementation_Pragmas
, N
);
4146 end Ada_2005_Pragma
;
4148 ---------------------
4149 -- Ada_2012_Pragma --
4150 ---------------------
4152 procedure Ada_2012_Pragma
is
4154 if Ada_Version
<= Ada_2005
then
4155 Check_Restriction
(No_Implementation_Pragmas
, N
);
4157 end Ada_2012_Pragma
;
4159 ----------------------------
4160 -- Analyze_Depends_Global --
4161 ----------------------------
4163 procedure Analyze_Depends_Global
4164 (Spec_Id
: out Entity_Id
;
4165 Subp_Decl
: out Node_Id
;
4166 Legal
: out Boolean)
4169 -- Assume that the pragma is illegal
4176 Check_Arg_Count
(1);
4178 -- Ensure the proper placement of the pragma. Depends/Global must be
4179 -- associated with a subprogram declaration or a body that acts as a
4182 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4186 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4189 -- Generic subprogram
4191 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4194 -- Object declaration of a single concurrent type
4196 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4197 and then Is_Single_Concurrent_Object
4198 (Unique_Defining_Entity
(Subp_Decl
))
4204 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4207 -- Subprogram body acts as spec
4209 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4210 and then No
(Corresponding_Spec
(Subp_Decl
))
4214 -- Subprogram body stub acts as spec
4216 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4217 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4221 -- Subprogram declaration
4223 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4228 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4236 -- If we get here, then the pragma is legal
4239 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4241 -- When the related context is an entry, the entry must belong to a
4242 -- protected unit (SPARK RM 6.1.4(6)).
4244 if Is_Entry_Declaration
(Spec_Id
)
4245 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4250 -- When the related context is an anonymous object created for a
4251 -- simple concurrent type, the type must be a task
4252 -- (SPARK RM 6.1.4(6)).
4254 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4255 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4261 -- A pragma that applies to a Ghost entity becomes Ghost for the
4262 -- purposes of legality checks and removal of ignored Ghost code.
4264 Mark_Ghost_Pragma
(N
, Spec_Id
);
4265 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4266 end Analyze_Depends_Global
;
4268 ------------------------
4269 -- Analyze_If_Present --
4270 ------------------------
4272 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4276 pragma Assert
(Is_List_Member
(N
));
4278 -- Inspect the declarations or statements following pragma N looking
4279 -- for another pragma whose Id matches the caller's request. If it is
4280 -- available, analyze it.
4283 while Present
(Stmt
) loop
4284 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4285 Analyze_Pragma
(Stmt
);
4288 -- The first source declaration or statement immediately following
4289 -- N ends the region where a pragma may appear.
4291 elsif Comes_From_Source
(Stmt
) then
4297 end Analyze_If_Present
;
4299 --------------------------------
4300 -- Analyze_Pre_Post_Condition --
4301 --------------------------------
4303 procedure Analyze_Pre_Post_Condition
is
4304 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4305 Subp_Decl
: Node_Id
;
4306 Subp_Id
: Entity_Id
;
4308 Duplicates_OK
: Boolean := False;
4309 -- Flag set when a pre/postcondition allows multiple pragmas of the
4312 In_Body_OK
: Boolean := False;
4313 -- Flag set when a pre/postcondition is allowed to appear on a body
4314 -- even though the subprogram may have a spec.
4316 Is_Pre_Post
: Boolean := False;
4317 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4320 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4321 -- Implement rules in AI12-0131: an overriding operation can have
4322 -- a class-wide precondition only if one of its ancestors has an
4323 -- explicit class-wide precondition.
4325 -----------------------------
4326 -- Inherits_Class_Wide_Pre --
4327 -----------------------------
4329 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4330 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4333 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4336 -- Check ancestors on the overriding operation to examine the
4337 -- preconditions that may apply to them.
4339 while Present
(Prev
) loop
4340 Cont
:= Contract
(Prev
);
4341 if Present
(Cont
) then
4342 Prag
:= Pre_Post_Conditions
(Cont
);
4343 while Present
(Prag
) loop
4344 if Class_Present
(Prag
) then
4348 Prag
:= Next_Pragma
(Prag
);
4352 -- For a type derived from a generic formal type, the operation
4353 -- inheriting the condition is a renaming, not an overriding of
4354 -- the operation of the formal. Ditto for an inherited
4355 -- operation which has no explicit contracts.
4357 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4358 or else not Comes_From_Source
(Prev
)
4360 Prev
:= Alias
(Prev
);
4362 Prev
:= Overridden_Operation
(Prev
);
4366 -- If the controlling type of the subprogram has progenitors, an
4367 -- interface operation implemented by the current operation may
4368 -- have a class-wide precondition.
4370 if Has_Interfaces
(Typ
) then
4375 Prim_Elmt
: Elmt_Id
;
4376 Prim_List
: Elist_Id
;
4379 Collect_Interfaces
(Typ
, Ints
);
4380 Elmt
:= First_Elmt
(Ints
);
4382 -- Iterate over the primitive operations of each interface
4384 while Present
(Elmt
) loop
4385 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4386 Prim_Elmt
:= First_Elmt
(Prim_List
);
4387 while Present
(Prim_Elmt
) loop
4388 Prim
:= Node
(Prim_Elmt
);
4389 if Chars
(Prim
) = Chars
(E
)
4390 and then Present
(Contract
(Prim
))
4391 and then Class_Present
4392 (Pre_Post_Conditions
(Contract
(Prim
)))
4397 Next_Elmt
(Prim_Elmt
);
4406 end Inherits_Class_Wide_Pre
;
4408 -- Start of processing for Analyze_Pre_Post_Condition
4411 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4412 -- offer uniformity among the various kinds of pre/postconditions by
4413 -- rewriting the pragma identifier. This allows the retrieval of the
4414 -- original pragma name by routine Original_Aspect_Pragma_Name.
4416 if Comes_From_Source
(N
) then
4417 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4418 Is_Pre_Post
:= True;
4419 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4420 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4422 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4423 Is_Pre_Post
:= True;
4424 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4425 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4429 -- Determine the semantics with respect to duplicates and placement
4430 -- in a body. Pragmas Precondition and Postcondition were introduced
4431 -- before aspects and are not subject to the same aspect-like rules.
4433 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4434 Duplicates_OK
:= True;
4440 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4441 -- argument without an identifier.
4444 Check_Arg_Count
(1);
4445 Check_No_Identifiers
;
4447 -- Pragmas Precondition and Postcondition have complex argument
4451 Check_At_Least_N_Arguments
(1);
4452 Check_At_Most_N_Arguments
(2);
4453 Check_Optional_Identifier
(Arg1
, Name_Check
);
4455 if Present
(Arg2
) then
4456 Check_Optional_Identifier
(Arg2
, Name_Message
);
4457 Preanalyze_Spec_Expression
4458 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4462 -- For a pragma PPC in the extended main source unit, record enabled
4464 -- ??? nothing checks that the pragma is in the main source unit
4466 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4467 Set_SCO_Pragma_Enabled
(Loc
);
4470 -- Ensure the proper placement of the pragma
4473 Find_Related_Declaration_Or_Body
4474 (N
, Do_Checks
=> not Duplicates_OK
);
4476 -- When a pre/postcondition pragma applies to an abstract subprogram,
4477 -- its original form must be an aspect with 'Class.
4479 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4480 if not From_Aspect_Specification
(N
) then
4482 ("pragma % cannot be applied to abstract subprogram");
4484 elsif not Class_Present
(N
) then
4486 ("aspect % requires ''Class for abstract subprogram");
4489 -- Entry declaration
4491 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4494 -- Generic subprogram declaration
4496 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4501 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4502 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4506 -- Subprogram body stub
4508 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4509 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4513 -- Subprogram declaration
4515 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4517 -- AI05-0230: When a pre/postcondition pragma applies to a null
4518 -- procedure, its original form must be an aspect with 'Class.
4520 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4521 and then Null_Present
(Specification
(Subp_Decl
))
4522 and then From_Aspect_Specification
(N
)
4523 and then not Class_Present
(N
)
4525 Error_Pragma
("aspect % requires ''Class for null procedure");
4528 -- Implement the legality checks mandated by AI12-0131:
4529 -- Pre'Class shall not be specified for an overriding primitive
4530 -- subprogram of a tagged type T unless the Pre'Class aspect is
4531 -- specified for the corresponding primitive subprogram of some
4535 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4538 if Class_Present
(N
)
4539 and then Pragma_Name
(N
) = Name_Precondition
4540 and then Present
(Overridden_Operation
(E
))
4541 and then not Inherits_Class_Wide_Pre
(E
)
4544 ("illegal class-wide precondition on overriding operation",
4545 Corresponding_Aspect
(N
));
4549 -- A renaming declaration may inherit a generated pragma, its
4550 -- placement comes from expansion, not from source.
4552 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4553 and then not Comes_From_Source
(N
)
4557 -- Otherwise the placement is illegal
4564 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4566 -- A pragma that applies to a Ghost entity becomes Ghost for the
4567 -- purposes of legality checks and removal of ignored Ghost code.
4569 Mark_Ghost_Pragma
(N
, Subp_Id
);
4571 -- Chain the pragma on the contract for further processing by
4572 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4574 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4576 -- Fully analyze the pragma when it appears inside an entry or
4577 -- subprogram body because it cannot benefit from forward references.
4579 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4581 N_Subprogram_Body_Stub
)
4583 -- The legality checks of pragmas Precondition and Postcondition
4584 -- are affected by the SPARK mode in effect and the volatility of
4585 -- the context. Analyze all pragmas in a specific order.
4587 Analyze_If_Present
(Pragma_SPARK_Mode
);
4588 Analyze_If_Present
(Pragma_Volatile_Function
);
4589 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4591 end Analyze_Pre_Post_Condition
;
4593 -----------------------------------------
4594 -- Analyze_Refined_Depends_Global_Post --
4595 -----------------------------------------
4597 procedure Analyze_Refined_Depends_Global_Post
4598 (Spec_Id
: out Entity_Id
;
4599 Body_Id
: out Entity_Id
;
4600 Legal
: out Boolean)
4602 Body_Decl
: Node_Id
;
4603 Spec_Decl
: Node_Id
;
4606 -- Assume that the pragma is illegal
4613 Check_Arg_Count
(1);
4614 Check_No_Identifiers
;
4616 -- Verify the placement of the pragma and check for duplicates. The
4617 -- pragma must apply to a subprogram body [stub].
4619 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4623 if Nkind
(Body_Decl
) = N_Entry_Body
then
4628 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4631 -- Subprogram body stub
4633 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4638 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4646 Body_Id
:= Defining_Entity
(Body_Decl
);
4647 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4649 -- The pragma must apply to the second declaration of a subprogram.
4650 -- In other words, the body [stub] cannot acts as a spec.
4652 if No
(Spec_Id
) then
4653 Error_Pragma
("pragma % cannot apply to a stand alone body");
4656 -- Catch the case where the subprogram body is a subunit and acts as
4657 -- the third declaration of the subprogram.
4659 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4660 Error_Pragma
("pragma % cannot apply to a subunit");
4664 -- A refined pragma can only apply to the body [stub] of a subprogram
4665 -- declared in the visible part of a package. Retrieve the context of
4666 -- the subprogram declaration.
4668 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4670 -- When dealing with protected entries or protected subprograms, use
4671 -- the enclosing protected type as the proper context.
4673 if Ekind_In
(Spec_Id
, E_Entry
,
4677 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4679 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4682 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4684 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4685 & "subprogram declared in a package specification"));
4689 -- If we get here, then the pragma is legal
4693 -- A pragma that applies to a Ghost entity becomes Ghost for the
4694 -- purposes of legality checks and removal of ignored Ghost code.
4696 Mark_Ghost_Pragma
(N
, Spec_Id
);
4698 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4699 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4701 end Analyze_Refined_Depends_Global_Post
;
4703 ----------------------------------
4704 -- Analyze_Unmodified_Or_Unused --
4705 ----------------------------------
4707 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4712 Ghost_Error_Posted
: Boolean := False;
4713 -- Flag set when an error concerning the illegal mix of Ghost and
4714 -- non-Ghost variables is emitted.
4716 Ghost_Id
: Entity_Id
:= Empty
;
4717 -- The entity of the first Ghost variable encountered while
4718 -- processing the arguments of the pragma.
4722 Check_At_Least_N_Arguments
(1);
4724 -- Loop through arguments
4727 while Present
(Arg
) loop
4728 Check_No_Identifier
(Arg
);
4730 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4731 -- in fact generate reference, so that the entity will have a
4732 -- reference, which will inhibit any warnings about it not
4733 -- being referenced, and also properly show up in the ali file
4734 -- as a reference. But this reference is recorded before the
4735 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4736 -- generated for this reference.
4738 Check_Arg_Is_Local_Name
(Arg
);
4739 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4741 if Is_Entity_Name
(Arg_Expr
) then
4742 Arg_Id
:= Entity
(Arg_Expr
);
4744 -- Skip processing the argument if already flagged
4746 if Is_Assignable
(Arg_Id
)
4747 and then not Has_Pragma_Unmodified
(Arg_Id
)
4748 and then not Has_Pragma_Unused
(Arg_Id
)
4750 Set_Has_Pragma_Unmodified
(Arg_Id
);
4753 Set_Has_Pragma_Unused
(Arg_Id
);
4756 -- A pragma that applies to a Ghost entity becomes Ghost for
4757 -- the purposes of legality checks and removal of ignored
4760 Mark_Ghost_Pragma
(N
, Arg_Id
);
4762 -- Capture the entity of the first Ghost variable being
4763 -- processed for error detection purposes.
4765 if Is_Ghost_Entity
(Arg_Id
) then
4766 if No
(Ghost_Id
) then
4770 -- Otherwise the variable is non-Ghost. It is illegal to mix
4771 -- references to Ghost and non-Ghost entities
4774 elsif Present
(Ghost_Id
)
4775 and then not Ghost_Error_Posted
4777 Ghost_Error_Posted
:= True;
4779 Error_Msg_Name_1
:= Pname
;
4781 ("pragma % cannot mention ghost and non-ghost "
4784 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4785 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4787 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4788 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4791 -- Warn if already flagged as Unused or Unmodified
4793 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4794 if Has_Pragma_Unused
(Arg_Id
) then
4796 ("??pragma Unused already given for &!", Arg_Expr
,
4800 ("??pragma Unmodified already given for &!", Arg_Expr
,
4804 -- Otherwise the pragma referenced an illegal entity
4808 ("pragma% can only be applied to a variable", Arg_Expr
);
4814 end Analyze_Unmodified_Or_Unused
;
4816 -----------------------------------
4817 -- Analyze_Unreference_Or_Unused --
4818 -----------------------------------
4820 procedure Analyze_Unreferenced_Or_Unused
4821 (Is_Unused
: Boolean := False)
4828 Ghost_Error_Posted
: Boolean := False;
4829 -- Flag set when an error concerning the illegal mix of Ghost and
4830 -- non-Ghost names is emitted.
4832 Ghost_Id
: Entity_Id
:= Empty
;
4833 -- The entity of the first Ghost name encountered while processing
4834 -- the arguments of the pragma.
4838 Check_At_Least_N_Arguments
(1);
4840 -- Check case of appearing within context clause
4842 if not Is_Unused
and then Is_In_Context_Clause
then
4844 -- The arguments must all be units mentioned in a with clause in
4845 -- the same context clause. Note that Par.Prag already checked
4846 -- that the arguments are either identifiers or selected
4850 while Present
(Arg
) loop
4851 Citem
:= First
(List_Containing
(N
));
4852 while Citem
/= N
loop
4853 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4855 if Nkind
(Citem
) = N_With_Clause
4856 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4858 Set_Has_Pragma_Unreferenced
4861 (Library_Unit
(Citem
))));
4862 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4871 ("argument of pragma% is not withed unit", Arg
);
4877 -- Case of not in list of context items
4881 while Present
(Arg
) loop
4882 Check_No_Identifier
(Arg
);
4884 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4885 -- in fact generate reference, so that the entity will have a
4886 -- reference, which will inhibit any warnings about it not
4887 -- being referenced, and also properly show up in the ali file
4888 -- as a reference. But this reference is recorded before the
4889 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4890 -- generated for this reference.
4892 Check_Arg_Is_Local_Name
(Arg
);
4893 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4895 if Is_Entity_Name
(Arg_Expr
) then
4896 Arg_Id
:= Entity
(Arg_Expr
);
4898 -- Warn if already flagged as Unused or Unreferenced and
4899 -- skip processing the argument.
4901 if Has_Pragma_Unreferenced
(Arg_Id
) then
4902 if Has_Pragma_Unused
(Arg_Id
) then
4904 ("??pragma Unused already given for &!", Arg_Expr
,
4908 ("??pragma Unreferenced already given for &!",
4912 -- Apply Unreferenced to the entity
4915 -- If the entity is overloaded, the pragma applies to the
4916 -- most recent overloading, as documented. In this case,
4917 -- name resolution does not generate a reference, so it
4918 -- must be done here explicitly.
4920 if Is_Overloaded
(Arg_Expr
) then
4921 Generate_Reference
(Arg_Id
, N
);
4924 Set_Has_Pragma_Unreferenced
(Arg_Id
);
4927 Set_Has_Pragma_Unused
(Arg_Id
);
4930 -- A pragma that applies to a Ghost entity becomes Ghost
4931 -- for the purposes of legality checks and removal of
4932 -- ignored Ghost code.
4934 Mark_Ghost_Pragma
(N
, Arg_Id
);
4936 -- Capture the entity of the first Ghost name being
4937 -- processed for error detection purposes.
4939 if Is_Ghost_Entity
(Arg_Id
) then
4940 if No
(Ghost_Id
) then
4944 -- Otherwise the name is non-Ghost. It is illegal to mix
4945 -- references to Ghost and non-Ghost entities
4948 elsif Present
(Ghost_Id
)
4949 and then not Ghost_Error_Posted
4951 Ghost_Error_Posted
:= True;
4953 Error_Msg_Name_1
:= Pname
;
4955 ("pragma % cannot mention ghost and non-ghost "
4958 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4960 ("\& # declared as ghost", N
, Ghost_Id
);
4962 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4964 ("\& # declared as non-ghost", N
, Arg_Id
);
4972 end Analyze_Unreferenced_Or_Unused
;
4974 --------------------------
4975 -- Check_Ada_83_Warning --
4976 --------------------------
4978 procedure Check_Ada_83_Warning
is
4980 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4981 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4983 end Check_Ada_83_Warning
;
4985 ---------------------
4986 -- Check_Arg_Count --
4987 ---------------------
4989 procedure Check_Arg_Count
(Required
: Nat
) is
4991 if Arg_Count
/= Required
then
4992 Error_Pragma
("wrong number of arguments for pragma%");
4994 end Check_Arg_Count
;
4996 --------------------------------
4997 -- Check_Arg_Is_External_Name --
4998 --------------------------------
5000 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5001 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5004 if Nkind
(Argx
) = N_Identifier
then
5008 Analyze_And_Resolve
(Argx
, Standard_String
);
5010 if Is_OK_Static_Expression
(Argx
) then
5013 elsif Etype
(Argx
) = Any_Type
then
5016 -- An interesting special case, if we have a string literal and
5017 -- we are in Ada 83 mode, then we allow it even though it will
5018 -- not be flagged as static. This allows expected Ada 83 mode
5019 -- use of external names which are string literals, even though
5020 -- technically these are not static in Ada 83.
5022 elsif Ada_Version
= Ada_83
5023 and then Nkind
(Argx
) = N_String_Literal
5027 -- Here we have a real error (non-static expression)
5030 Error_Msg_Name_1
:= Pname
;
5031 Flag_Non_Static_Expr
5032 (Fix_Error
("argument for pragma% must be a identifier or "
5033 & "static string expression!"), Argx
);
5038 end Check_Arg_Is_External_Name
;
5040 -----------------------------
5041 -- Check_Arg_Is_Identifier --
5042 -----------------------------
5044 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5045 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5047 if Nkind
(Argx
) /= N_Identifier
then
5048 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5050 end Check_Arg_Is_Identifier
;
5052 ----------------------------------
5053 -- Check_Arg_Is_Integer_Literal --
5054 ----------------------------------
5056 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5057 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5059 if Nkind
(Argx
) /= N_Integer_Literal
then
5061 ("argument for pragma% must be integer literal", Argx
);
5063 end Check_Arg_Is_Integer_Literal
;
5065 -------------------------------------------
5066 -- Check_Arg_Is_Library_Level_Local_Name --
5067 -------------------------------------------
5071 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5072 -- | library_unit_NAME
5074 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5076 Check_Arg_Is_Local_Name
(Arg
);
5078 -- If it came from an aspect, we want to give the error just as if it
5079 -- came from source.
5081 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5082 and then (Comes_From_Source
(N
)
5083 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5086 ("argument for pragma% must be library level entity", Arg
);
5088 end Check_Arg_Is_Library_Level_Local_Name
;
5090 -----------------------------
5091 -- Check_Arg_Is_Local_Name --
5092 -----------------------------
5096 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5097 -- | library_unit_NAME
5099 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5100 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5103 -- If this pragma came from an aspect specification, we don't want to
5104 -- check for this error, because that would cause spurious errors, in
5105 -- case a type is frozen in a scope more nested than the type. The
5106 -- aspect itself of course can't be anywhere but on the declaration
5109 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5110 if From_Aspect_Specification
(Parent
(Arg
)) then
5114 -- Arg is the Expression of an N_Pragma_Argument_Association
5117 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5124 if Nkind
(Argx
) not in N_Direct_Name
5125 and then (Nkind
(Argx
) /= N_Attribute_Reference
5126 or else Present
(Expressions
(Argx
))
5127 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5128 and then (not Is_Entity_Name
(Argx
)
5129 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5131 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5134 -- No further check required if not an entity name
5136 if not Is_Entity_Name
(Argx
) then
5142 Ent
: constant Entity_Id
:= Entity
(Argx
);
5143 Scop
: constant Entity_Id
:= Scope
(Ent
);
5146 -- Case of a pragma applied to a compilation unit: pragma must
5147 -- occur immediately after the program unit in the compilation.
5149 if Is_Compilation_Unit
(Ent
) then
5151 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5154 -- Case of pragma placed immediately after spec
5156 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5159 -- Case of pragma placed immediately after body
5161 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5162 and then Present
(Corresponding_Body
(Decl
))
5166 (Parent
(Unit_Declaration_Node
5167 (Corresponding_Body
(Decl
))));
5169 -- All other cases are illegal
5176 -- Special restricted placement rule from 10.2.1(11.8/2)
5178 elsif Is_Generic_Formal
(Ent
)
5179 and then Prag_Id
= Pragma_Preelaborable_Initialization
5181 OK
:= List_Containing
(N
) =
5182 Generic_Formal_Declarations
5183 (Unit_Declaration_Node
(Scop
));
5185 -- If this is an aspect applied to a subprogram body, the
5186 -- pragma is inserted in its declarative part.
5188 elsif From_Aspect_Specification
(N
)
5189 and then Ent
= Current_Scope
5191 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5195 -- If the aspect is a predicate (possibly others ???) and the
5196 -- context is a record type, this is a discriminant expression
5197 -- within a type declaration, that freezes the predicated
5200 elsif From_Aspect_Specification
(N
)
5201 and then Prag_Id
= Pragma_Predicate
5202 and then Ekind
(Current_Scope
) = E_Record_Type
5203 and then Scop
= Scope
(Current_Scope
)
5207 -- Default case, just check that the pragma occurs in the scope
5208 -- of the entity denoted by the name.
5211 OK
:= Current_Scope
= Scop
;
5216 ("pragma% argument must be in same declarative part", Arg
);
5220 end Check_Arg_Is_Local_Name
;
5222 ---------------------------------
5223 -- Check_Arg_Is_Locking_Policy --
5224 ---------------------------------
5226 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5227 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5230 Check_Arg_Is_Identifier
(Argx
);
5232 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5233 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5235 end Check_Arg_Is_Locking_Policy
;
5237 -----------------------------------------------
5238 -- Check_Arg_Is_Partition_Elaboration_Policy --
5239 -----------------------------------------------
5241 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5242 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5245 Check_Arg_Is_Identifier
(Argx
);
5247 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5249 ("& is not a valid partition elaboration policy name", Argx
);
5251 end Check_Arg_Is_Partition_Elaboration_Policy
;
5253 -------------------------
5254 -- Check_Arg_Is_One_Of --
5255 -------------------------
5257 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5258 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5261 Check_Arg_Is_Identifier
(Argx
);
5263 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5264 Error_Msg_Name_2
:= N1
;
5265 Error_Msg_Name_3
:= N2
;
5266 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5268 end Check_Arg_Is_One_Of
;
5270 procedure Check_Arg_Is_One_Of
5272 N1
, N2
, N3
: Name_Id
)
5274 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5277 Check_Arg_Is_Identifier
(Argx
);
5279 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5280 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5282 end Check_Arg_Is_One_Of
;
5284 procedure Check_Arg_Is_One_Of
5286 N1
, N2
, N3
, N4
: Name_Id
)
5288 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5291 Check_Arg_Is_Identifier
(Argx
);
5293 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5294 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5296 end Check_Arg_Is_One_Of
;
5298 procedure Check_Arg_Is_One_Of
5300 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5302 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5305 Check_Arg_Is_Identifier
(Argx
);
5307 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5308 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5310 end Check_Arg_Is_One_Of
;
5312 ---------------------------------
5313 -- Check_Arg_Is_Queuing_Policy --
5314 ---------------------------------
5316 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5317 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5320 Check_Arg_Is_Identifier
(Argx
);
5322 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5323 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5325 end Check_Arg_Is_Queuing_Policy
;
5327 ---------------------------------------
5328 -- Check_Arg_Is_OK_Static_Expression --
5329 ---------------------------------------
5331 procedure Check_Arg_Is_OK_Static_Expression
5333 Typ
: Entity_Id
:= Empty
)
5336 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5337 end Check_Arg_Is_OK_Static_Expression
;
5339 ------------------------------------------
5340 -- Check_Arg_Is_Task_Dispatching_Policy --
5341 ------------------------------------------
5343 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5344 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5347 Check_Arg_Is_Identifier
(Argx
);
5349 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5351 ("& is not an allowed task dispatching policy name", Argx
);
5353 end Check_Arg_Is_Task_Dispatching_Policy
;
5355 ---------------------
5356 -- Check_Arg_Order --
5357 ---------------------
5359 procedure Check_Arg_Order
(Names
: Name_List
) is
5362 Highest_So_Far
: Natural := 0;
5363 -- Highest index in Names seen do far
5367 for J
in 1 .. Arg_Count
loop
5368 if Chars
(Arg
) /= No_Name
then
5369 for K
in Names
'Range loop
5370 if Chars
(Arg
) = Names
(K
) then
5371 if K
< Highest_So_Far
then
5372 Error_Msg_Name_1
:= Pname
;
5374 ("parameters out of order for pragma%", Arg
);
5375 Error_Msg_Name_1
:= Names
(K
);
5376 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5377 Error_Msg_N
("\% must appear before %", Arg
);
5381 Highest_So_Far
:= K
;
5389 end Check_Arg_Order
;
5391 --------------------------------
5392 -- Check_At_Least_N_Arguments --
5393 --------------------------------
5395 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5397 if Arg_Count
< N
then
5398 Error_Pragma
("too few arguments for pragma%");
5400 end Check_At_Least_N_Arguments
;
5402 -------------------------------
5403 -- Check_At_Most_N_Arguments --
5404 -------------------------------
5406 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5409 if Arg_Count
> N
then
5411 for J
in 1 .. N
loop
5413 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5416 end Check_At_Most_N_Arguments
;
5418 ---------------------
5419 -- Check_Component --
5420 ---------------------
5422 procedure Check_Component
5425 In_Variant_Part
: Boolean := False)
5427 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5428 Sindic
: constant Node_Id
:=
5429 Subtype_Indication
(Component_Definition
(Comp
));
5430 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5433 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5434 -- object constraint, then the component type shall be an Unchecked_
5437 if Nkind
(Sindic
) = N_Subtype_Indication
5438 and then Has_Per_Object_Constraint
(Comp_Id
)
5439 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5442 ("component subtype subject to per-object constraint "
5443 & "must be an Unchecked_Union", Comp
);
5445 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5446 -- the body of a generic unit, or within the body of any of its
5447 -- descendant library units, no part of the type of a component
5448 -- declared in a variant_part of the unchecked union type shall be of
5449 -- a formal private type or formal private extension declared within
5450 -- the formal part of the generic unit.
5452 elsif Ada_Version
>= Ada_2012
5453 and then In_Generic_Body
(UU_Typ
)
5454 and then In_Variant_Part
5455 and then Is_Private_Type
(Typ
)
5456 and then Is_Generic_Type
(Typ
)
5459 ("component of unchecked union cannot be of generic type", Comp
);
5461 elsif Needs_Finalization
(Typ
) then
5463 ("component of unchecked union cannot be controlled", Comp
);
5465 elsif Has_Task
(Typ
) then
5467 ("component of unchecked union cannot have tasks", Comp
);
5469 end Check_Component
;
5471 ----------------------------
5472 -- Check_Duplicate_Pragma --
5473 ----------------------------
5475 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5476 Id
: Entity_Id
:= E
;
5480 -- Nothing to do if this pragma comes from an aspect specification,
5481 -- since we could not be duplicating a pragma, and we dealt with the
5482 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5484 if From_Aspect_Specification
(N
) then
5488 -- Otherwise current pragma may duplicate previous pragma or a
5489 -- previously given aspect specification or attribute definition
5490 -- clause for the same pragma.
5492 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5496 -- If the entity is a type, then we have to make sure that the
5497 -- ostensible duplicate is not for a parent type from which this
5501 if Nkind
(P
) = N_Pragma
then
5503 Args
: constant List_Id
:=
5504 Pragma_Argument_Associations
(P
);
5507 and then Is_Entity_Name
(Expression
(First
(Args
)))
5508 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5509 and then Entity
(Expression
(First
(Args
))) /= E
5515 elsif Nkind
(P
) = N_Aspect_Specification
5516 and then Is_Type
(Entity
(P
))
5517 and then Entity
(P
) /= E
5523 -- Here we have a definite duplicate
5525 Error_Msg_Name_1
:= Pragma_Name
(N
);
5526 Error_Msg_Sloc
:= Sloc
(P
);
5528 -- For a single protected or a single task object, the error is
5529 -- issued on the original entity.
5531 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5532 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5535 if Nkind
(P
) = N_Aspect_Specification
5536 or else From_Aspect_Specification
(P
)
5538 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5540 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5545 end Check_Duplicate_Pragma
;
5547 ----------------------------------
5548 -- Check_Duplicated_Export_Name --
5549 ----------------------------------
5551 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5552 String_Val
: constant String_Id
:= Strval
(Nam
);
5555 -- We are only interested in the export case, and in the case of
5556 -- generics, it is the instance, not the template, that is the
5557 -- problem (the template will generate a warning in any case).
5559 if not Inside_A_Generic
5560 and then (Prag_Id
= Pragma_Export
5562 Prag_Id
= Pragma_Export_Procedure
5564 Prag_Id
= Pragma_Export_Valued_Procedure
5566 Prag_Id
= Pragma_Export_Function
)
5568 for J
in Externals
.First
.. Externals
.Last
loop
5569 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5570 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5571 Error_Msg_N
("external name duplicates name given#", Nam
);
5576 Externals
.Append
(Nam
);
5578 end Check_Duplicated_Export_Name
;
5580 ----------------------------------------
5581 -- Check_Expr_Is_OK_Static_Expression --
5582 ----------------------------------------
5584 procedure Check_Expr_Is_OK_Static_Expression
5586 Typ
: Entity_Id
:= Empty
)
5589 if Present
(Typ
) then
5590 Analyze_And_Resolve
(Expr
, Typ
);
5592 Analyze_And_Resolve
(Expr
);
5595 -- An expression cannot be considered static if its resolution failed
5596 -- or if it's erroneous. Stop the analysis of the related pragma.
5598 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5601 elsif Is_OK_Static_Expression
(Expr
) then
5604 -- An interesting special case, if we have a string literal and we
5605 -- are in Ada 83 mode, then we allow it even though it will not be
5606 -- flagged as static. This allows the use of Ada 95 pragmas like
5607 -- Import in Ada 83 mode. They will of course be flagged with
5608 -- warnings as usual, but will not cause errors.
5610 elsif Ada_Version
= Ada_83
5611 and then Nkind
(Expr
) = N_String_Literal
5615 -- Finally, we have a real error
5618 Error_Msg_Name_1
:= Pname
;
5619 Flag_Non_Static_Expr
5620 (Fix_Error
("argument for pragma% must be a static expression!"),
5624 end Check_Expr_Is_OK_Static_Expression
;
5626 -------------------------
5627 -- Check_First_Subtype --
5628 -------------------------
5630 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5631 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5632 Ent
: constant Entity_Id
:= Entity
(Argx
);
5635 if Is_First_Subtype
(Ent
) then
5638 elsif Is_Type
(Ent
) then
5640 ("pragma% cannot apply to subtype", Argx
);
5642 elsif Is_Object
(Ent
) then
5644 ("pragma% cannot apply to object, requires a type", Argx
);
5648 ("pragma% cannot apply to&, requires a type", Argx
);
5650 end Check_First_Subtype
;
5652 ----------------------
5653 -- Check_Identifier --
5654 ----------------------
5656 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5659 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5661 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5662 Error_Msg_Name_1
:= Pname
;
5663 Error_Msg_Name_2
:= Id
;
5664 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5668 end Check_Identifier
;
5670 --------------------------------
5671 -- Check_Identifier_Is_One_Of --
5672 --------------------------------
5674 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5677 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5679 if Chars
(Arg
) = No_Name
then
5680 Error_Msg_Name_1
:= Pname
;
5681 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5684 elsif Chars
(Arg
) /= N1
5685 and then Chars
(Arg
) /= N2
5687 Error_Msg_Name_1
:= Pname
;
5688 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5692 end Check_Identifier_Is_One_Of
;
5694 ---------------------------
5695 -- Check_In_Main_Program --
5696 ---------------------------
5698 procedure Check_In_Main_Program
is
5699 P
: constant Node_Id
:= Parent
(N
);
5702 -- Must be in subprogram body
5704 if Nkind
(P
) /= N_Subprogram_Body
then
5705 Error_Pragma
("% pragma allowed only in subprogram");
5707 -- Otherwise warn if obviously not main program
5709 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5710 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5712 Error_Msg_Name_1
:= Pname
;
5714 ("??pragma% is only effective in main program", N
);
5716 end Check_In_Main_Program
;
5718 ---------------------------------------
5719 -- Check_Interrupt_Or_Attach_Handler --
5720 ---------------------------------------
5722 procedure Check_Interrupt_Or_Attach_Handler
is
5723 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5724 Handler_Proc
, Proc_Scope
: Entity_Id
;
5729 if Prag_Id
= Pragma_Interrupt_Handler
then
5730 Check_Restriction
(No_Dynamic_Attachment
, N
);
5733 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5734 Proc_Scope
:= Scope
(Handler_Proc
);
5736 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5738 ("argument of pragma% must be protected procedure", Arg1
);
5741 -- For pragma case (as opposed to access case), check placement.
5742 -- We don't need to do that for aspects, because we have the
5743 -- check that they aspect applies an appropriate procedure.
5745 if not From_Aspect_Specification
(N
)
5746 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5748 Error_Pragma
("pragma% must be in protected definition");
5751 if not Is_Library_Level_Entity
(Proc_Scope
) then
5753 ("argument for pragma% must be library level entity", Arg1
);
5756 -- AI05-0033: A pragma cannot appear within a generic body, because
5757 -- instance can be in a nested scope. The check that protected type
5758 -- is itself a library-level declaration is done elsewhere.
5760 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5761 -- handle code prior to AI-0033. Analysis tools typically are not
5762 -- interested in this pragma in any case, so no need to worry too
5763 -- much about its placement.
5765 if Inside_A_Generic
then
5766 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5767 and then In_Package_Body
(Scope
(Current_Scope
))
5768 and then not Relaxed_RM_Semantics
5770 Error_Pragma
("pragma% cannot be used inside a generic");
5773 end Check_Interrupt_Or_Attach_Handler
;
5775 ---------------------------------
5776 -- Check_Loop_Pragma_Placement --
5777 ---------------------------------
5779 procedure Check_Loop_Pragma_Placement
is
5780 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5781 -- Verify whether the current pragma is properly grouped with other
5782 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5783 -- related loop where the pragma appears.
5785 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5786 -- Determine whether an arbitrary statement Stmt denotes pragma
5787 -- Loop_Invariant or Loop_Variant.
5789 procedure Placement_Error
(Constr
: Node_Id
);
5790 pragma No_Return
(Placement_Error
);
5791 -- Node Constr denotes the last loop restricted construct before we
5792 -- encountered an illegal relation between enclosing constructs. Emit
5793 -- an error depending on what Constr was.
5795 --------------------------------
5796 -- Check_Loop_Pragma_Grouping --
5797 --------------------------------
5799 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5800 Stop_Search
: exception;
5801 -- This exception is used to terminate the recursive descent of
5802 -- routine Check_Grouping.
5804 procedure Check_Grouping
(L
: List_Id
);
5805 -- Find the first group of pragmas in list L and if successful,
5806 -- ensure that the current pragma is part of that group. The
5807 -- routine raises Stop_Search once such a check is performed to
5808 -- halt the recursive descent.
5810 procedure Grouping_Error
(Prag
: Node_Id
);
5811 pragma No_Return
(Grouping_Error
);
5812 -- Emit an error concerning the current pragma indicating that it
5813 -- should be placed after pragma Prag.
5815 --------------------
5816 -- Check_Grouping --
5817 --------------------
5819 procedure Check_Grouping
(L
: List_Id
) is
5822 Prag
: Node_Id
:= Empty
; -- init to avoid warning
5825 -- Inspect the list of declarations or statements looking for
5826 -- the first grouping of pragmas:
5829 -- pragma Loop_Invariant ...;
5830 -- pragma Loop_Variant ...;
5832 -- pragma Loop_Variant ...; -- current pragma
5834 -- If the current pragma is not in the grouping, then it must
5835 -- either appear in a different declarative or statement list
5836 -- or the construct at (1) is separating the pragma from the
5840 while Present
(Stmt
) loop
5842 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5843 -- inside a loop or a block housed inside a loop. Inspect
5844 -- the declarations and statements of the block as they may
5845 -- contain the first grouping.
5847 if Nkind
(Stmt
) = N_Block_Statement
then
5848 HSS
:= Handled_Statement_Sequence
(Stmt
);
5850 Check_Grouping
(Declarations
(Stmt
));
5852 if Present
(HSS
) then
5853 Check_Grouping
(Statements
(HSS
));
5856 -- First pragma of the first topmost grouping has been found
5858 elsif Is_Loop_Pragma
(Stmt
) then
5860 -- The group and the current pragma are not in the same
5861 -- declarative or statement list.
5863 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5864 Grouping_Error
(Stmt
);
5866 -- Try to reach the current pragma from the first pragma
5867 -- of the grouping while skipping other members:
5869 -- pragma Loop_Invariant ...; -- first pragma
5870 -- pragma Loop_Variant ...; -- member
5872 -- pragma Loop_Variant ...; -- current pragma
5875 while Present
(Stmt
) loop
5876 -- The current pragma is either the first pragma
5877 -- of the group or is a member of the group.
5878 -- Stop the search as the placement is legal.
5883 -- Skip group members, but keep track of the
5884 -- last pragma in the group.
5886 elsif Is_Loop_Pragma
(Stmt
) then
5889 -- Skip declarations and statements generated by
5890 -- the compiler during expansion.
5892 elsif not Comes_From_Source
(Stmt
) then
5895 -- A non-pragma is separating the group from the
5896 -- current pragma, the placement is illegal.
5899 Grouping_Error
(Prag
);
5905 -- If the traversal did not reach the current pragma,
5906 -- then the list must be malformed.
5908 raise Program_Error
;
5916 --------------------
5917 -- Grouping_Error --
5918 --------------------
5920 procedure Grouping_Error
(Prag
: Node_Id
) is
5922 Error_Msg_Sloc
:= Sloc
(Prag
);
5923 Error_Pragma
("pragma% must appear next to pragma#");
5926 -- Start of processing for Check_Loop_Pragma_Grouping
5929 -- Inspect the statements of the loop or nested blocks housed
5930 -- within to determine whether the current pragma is part of the
5931 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5933 Check_Grouping
(Statements
(Loop_Stmt
));
5936 when Stop_Search
=> null;
5937 end Check_Loop_Pragma_Grouping
;
5939 --------------------
5940 -- Is_Loop_Pragma --
5941 --------------------
5943 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5945 -- Inspect the original node as Loop_Invariant and Loop_Variant
5946 -- pragmas are rewritten to null when assertions are disabled.
5948 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5950 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
5951 Name_Loop_Invariant
,
5958 ---------------------
5959 -- Placement_Error --
5960 ---------------------
5962 procedure Placement_Error
(Constr
: Node_Id
) is
5963 LA
: constant String := " with Loop_Entry";
5966 if Prag_Id
= Pragma_Assert
then
5967 Error_Msg_String
(1 .. LA
'Length) := LA
;
5968 Error_Msg_Strlen
:= LA
'Length;
5970 Error_Msg_Strlen
:= 0;
5973 if Nkind
(Constr
) = N_Pragma
then
5975 ("pragma %~ must appear immediately within the statements "
5979 ("block containing pragma %~ must appear immediately within "
5980 & "the statements of a loop", Constr
);
5982 end Placement_Error
;
5984 -- Local declarations
5989 -- Start of processing for Check_Loop_Pragma_Placement
5992 -- Check that pragma appears immediately within a loop statement,
5993 -- ignoring intervening block statements.
5997 while Present
(Stmt
) loop
5999 -- The pragma or previous block must appear immediately within the
6000 -- current block's declarative or statement part.
6002 if Nkind
(Stmt
) = N_Block_Statement
then
6003 if (No
(Declarations
(Stmt
))
6004 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6006 List_Containing
(Prev
) /=
6007 Statements
(Handled_Statement_Sequence
(Stmt
))
6009 Placement_Error
(Prev
);
6012 -- Keep inspecting the parents because we are now within a
6013 -- chain of nested blocks.
6017 Stmt
:= Parent
(Stmt
);
6020 -- The pragma or previous block must appear immediately within the
6021 -- statements of the loop.
6023 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6024 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6025 Placement_Error
(Prev
);
6028 -- Stop the traversal because we reached the innermost loop
6029 -- regardless of whether we encountered an error or not.
6033 -- Ignore a handled statement sequence. Note that this node may
6034 -- be related to a subprogram body in which case we will emit an
6035 -- error on the next iteration of the search.
6037 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6038 Stmt
:= Parent
(Stmt
);
6040 -- Any other statement breaks the chain from the pragma to the
6044 Placement_Error
(Prev
);
6049 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6050 -- grouped together with other such pragmas.
6052 if Is_Loop_Pragma
(N
) then
6054 -- The previous check should have located the related loop
6056 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6057 Check_Loop_Pragma_Grouping
(Stmt
);
6059 end Check_Loop_Pragma_Placement
;
6061 -------------------------------------------
6062 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6063 -------------------------------------------
6065 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6074 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6077 elsif Nkind_In
(P
, N_Package_Specification
,
6082 -- Note: the following tests seem a little peculiar, because
6083 -- they test for bodies, but if we were in the statement part
6084 -- of the body, we would already have hit the handled statement
6085 -- sequence, so the only way we get here is by being in the
6086 -- declarative part of the body.
6088 elsif Nkind_In
(P
, N_Subprogram_Body
,
6099 Error_Pragma
("pragma% is not in declarative part or package spec");
6100 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6102 -------------------------
6103 -- Check_No_Identifier --
6104 -------------------------
6106 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6108 if Nkind
(Arg
) = N_Pragma_Argument_Association
6109 and then Chars
(Arg
) /= No_Name
6111 Error_Pragma_Arg_Ident
6112 ("pragma% does not permit identifier& here", Arg
);
6114 end Check_No_Identifier
;
6116 --------------------------
6117 -- Check_No_Identifiers --
6118 --------------------------
6120 procedure Check_No_Identifiers
is
6124 for J
in 1 .. Arg_Count
loop
6125 Check_No_Identifier
(Arg_Node
);
6128 end Check_No_Identifiers
;
6130 ------------------------
6131 -- Check_No_Link_Name --
6132 ------------------------
6134 procedure Check_No_Link_Name
is
6136 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6140 if Present
(Arg4
) then
6142 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6144 end Check_No_Link_Name
;
6146 -------------------------------
6147 -- Check_Optional_Identifier --
6148 -------------------------------
6150 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6153 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6154 and then Chars
(Arg
) /= No_Name
6156 if Chars
(Arg
) /= Id
then
6157 Error_Msg_Name_1
:= Pname
;
6158 Error_Msg_Name_2
:= Id
;
6159 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6163 end Check_Optional_Identifier
;
6165 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6167 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6168 end Check_Optional_Identifier
;
6170 -------------------------------------
6171 -- Check_Static_Boolean_Expression --
6172 -------------------------------------
6174 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6176 if Present
(Expr
) then
6177 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6179 if not Is_OK_Static_Expression
(Expr
) then
6181 ("expression of pragma % must be static", Expr
);
6184 end Check_Static_Boolean_Expression
;
6186 -----------------------------
6187 -- Check_Static_Constraint --
6188 -----------------------------
6190 -- Note: for convenience in writing this procedure, in addition to
6191 -- the officially (i.e. by spec) allowed argument which is always a
6192 -- constraint, it also allows ranges and discriminant associations.
6193 -- Above is not clear ???
6195 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6197 procedure Require_Static
(E
: Node_Id
);
6198 -- Require given expression to be static expression
6200 --------------------
6201 -- Require_Static --
6202 --------------------
6204 procedure Require_Static
(E
: Node_Id
) is
6206 if not Is_OK_Static_Expression
(E
) then
6207 Flag_Non_Static_Expr
6208 ("non-static constraint not allowed in Unchecked_Union!", E
);
6213 -- Start of processing for Check_Static_Constraint
6216 case Nkind
(Constr
) is
6217 when N_Discriminant_Association
=>
6218 Require_Static
(Expression
(Constr
));
6221 Require_Static
(Low_Bound
(Constr
));
6222 Require_Static
(High_Bound
(Constr
));
6224 when N_Attribute_Reference
=>
6225 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6226 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6228 when N_Range_Constraint
=>
6229 Check_Static_Constraint
(Range_Expression
(Constr
));
6231 when N_Index_Or_Discriminant_Constraint
=>
6235 IDC
:= First
(Constraints
(Constr
));
6236 while Present
(IDC
) loop
6237 Check_Static_Constraint
(IDC
);
6245 end Check_Static_Constraint
;
6247 --------------------------------------
6248 -- Check_Valid_Configuration_Pragma --
6249 --------------------------------------
6251 -- A configuration pragma must appear in the context clause of a
6252 -- compilation unit, and only other pragmas may precede it. Note that
6253 -- the test also allows use in a configuration pragma file.
6255 procedure Check_Valid_Configuration_Pragma
is
6257 if not Is_Configuration_Pragma
then
6258 Error_Pragma
("incorrect placement for configuration pragma%");
6260 end Check_Valid_Configuration_Pragma
;
6262 -------------------------------------
6263 -- Check_Valid_Library_Unit_Pragma --
6264 -------------------------------------
6266 procedure Check_Valid_Library_Unit_Pragma
is
6268 Parent_Node
: Node_Id
;
6269 Unit_Name
: Entity_Id
;
6270 Unit_Kind
: Node_Kind
;
6271 Unit_Node
: Node_Id
;
6272 Sindex
: Source_File_Index
;
6275 if not Is_List_Member
(N
) then
6279 Plist
:= List_Containing
(N
);
6280 Parent_Node
:= Parent
(Plist
);
6282 if Parent_Node
= Empty
then
6285 -- Case of pragma appearing after a compilation unit. In this case
6286 -- it must have an argument with the corresponding name and must
6287 -- be part of the following pragmas of its parent.
6289 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6290 if Plist
/= Pragmas_After
(Parent_Node
) then
6293 elsif Arg_Count
= 0 then
6295 ("argument required if outside compilation unit");
6298 Check_No_Identifiers
;
6299 Check_Arg_Count
(1);
6300 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6301 Unit_Kind
:= Nkind
(Unit_Node
);
6303 Analyze
(Get_Pragma_Arg
(Arg1
));
6305 if Unit_Kind
= N_Generic_Subprogram_Declaration
6306 or else Unit_Kind
= N_Subprogram_Declaration
6308 Unit_Name
:= Defining_Entity
(Unit_Node
);
6310 elsif Unit_Kind
in N_Generic_Instantiation
then
6311 Unit_Name
:= Defining_Entity
(Unit_Node
);
6314 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6317 if Chars
(Unit_Name
) /=
6318 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6321 ("pragma% argument is not current unit name", Arg1
);
6324 if Ekind
(Unit_Name
) = E_Package
6325 and then Present
(Renamed_Entity
(Unit_Name
))
6327 Error_Pragma
("pragma% not allowed for renamed package");
6331 -- Pragma appears other than after a compilation unit
6334 -- Here we check for the generic instantiation case and also
6335 -- for the case of processing a generic formal package. We
6336 -- detect these cases by noting that the Sloc on the node
6337 -- does not belong to the current compilation unit.
6339 Sindex
:= Source_Index
(Current_Sem_Unit
);
6341 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6342 Rewrite
(N
, Make_Null_Statement
(Loc
));
6345 -- If before first declaration, the pragma applies to the
6346 -- enclosing unit, and the name if present must be this name.
6348 elsif Is_Before_First_Decl
(N
, Plist
) then
6349 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6350 Unit_Kind
:= Nkind
(Unit_Node
);
6352 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6355 elsif Unit_Kind
= N_Subprogram_Body
6356 and then not Acts_As_Spec
(Unit_Node
)
6360 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6363 elsif Nkind
(Parent_Node
) = N_Package_Specification
6364 and then Plist
= Private_Declarations
(Parent_Node
)
6368 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6369 or else Nkind
(Parent_Node
) =
6370 N_Generic_Subprogram_Declaration
)
6371 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6375 elsif Arg_Count
> 0 then
6376 Analyze
(Get_Pragma_Arg
(Arg1
));
6378 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6380 ("name in pragma% must be enclosing unit", Arg1
);
6383 -- It is legal to have no argument in this context
6389 -- Error if not before first declaration. This is because a
6390 -- library unit pragma argument must be the name of a library
6391 -- unit (RM 10.1.5(7)), but the only names permitted in this
6392 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6393 -- generic subprogram declarations or generic instantiations.
6397 ("pragma% misplaced, must be before first declaration");
6401 end Check_Valid_Library_Unit_Pragma
;
6407 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6408 Clist
: constant Node_Id
:= Component_List
(Variant
);
6412 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6413 while Present
(Comp
) loop
6414 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6415 Next_Non_Pragma
(Comp
);
6419 ---------------------------
6420 -- Ensure_Aggregate_Form --
6421 ---------------------------
6423 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6424 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6425 Expr
: constant Node_Id
:= Expression
(Arg
);
6426 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6427 Comps
: List_Id
:= No_List
;
6428 Exprs
: List_Id
:= No_List
;
6429 Nam
: Name_Id
:= No_Name
;
6430 Nam_Loc
: Source_Ptr
;
6433 -- The pragma argument is in positional form:
6435 -- pragma Depends (Nam => ...)
6439 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6440 -- argument association.
6442 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6444 Nam_Loc
:= Sloc
(Arg
);
6446 -- Remove the pragma argument name as this will be captured in the
6449 Set_Chars
(Arg
, No_Name
);
6452 -- The argument is already in aggregate form, but the presence of a
6453 -- name causes this to be interpreted as named association which in
6454 -- turn must be converted into an aggregate.
6456 -- pragma Global (In_Out => (A, B, C))
6460 -- pragma Global ((In_Out => (A, B, C)))
6462 -- aggregate aggregate
6464 if Nkind
(Expr
) = N_Aggregate
then
6465 if Nam
= No_Name
then
6469 -- Do not transform a null argument into an aggregate as N_Null has
6470 -- special meaning in formal verification pragmas.
6472 elsif Nkind
(Expr
) = N_Null
then
6476 -- Everything comes from source if the original comes from source
6478 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6480 -- Positional argument is transformed into an aggregate with an
6481 -- Expressions list.
6483 if Nam
= No_Name
then
6484 Exprs
:= New_List
(Relocate_Node
(Expr
));
6486 -- An associative argument is transformed into an aggregate with
6487 -- Component_Associations.
6491 Make_Component_Association
(Loc
,
6492 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6493 Expression
=> Relocate_Node
(Expr
)));
6496 Set_Expression
(Arg
,
6497 Make_Aggregate
(Loc
,
6498 Component_Associations
=> Comps
,
6499 Expressions
=> Exprs
));
6501 -- Restore Comes_From_Source default
6503 Set_Comes_From_Source_Default
(CFSD
);
6504 end Ensure_Aggregate_Form
;
6510 procedure Error_Pragma
(Msg
: String) is
6512 Error_Msg_Name_1
:= Pname
;
6513 Error_Msg_N
(Fix_Error
(Msg
), N
);
6517 ----------------------
6518 -- Error_Pragma_Arg --
6519 ----------------------
6521 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6523 Error_Msg_Name_1
:= Pname
;
6524 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6526 end Error_Pragma_Arg
;
6528 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6530 Error_Msg_Name_1
:= Pname
;
6531 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6532 Error_Pragma_Arg
(Msg2
, Arg
);
6533 end Error_Pragma_Arg
;
6535 ----------------------------
6536 -- Error_Pragma_Arg_Ident --
6537 ----------------------------
6539 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6541 Error_Msg_Name_1
:= Pname
;
6542 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6544 end Error_Pragma_Arg_Ident
;
6546 ----------------------
6547 -- Error_Pragma_Ref --
6548 ----------------------
6550 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6552 Error_Msg_Name_1
:= Pname
;
6553 Error_Msg_Sloc
:= Sloc
(Ref
);
6554 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6556 end Error_Pragma_Ref
;
6558 ------------------------
6559 -- Find_Lib_Unit_Name --
6560 ------------------------
6562 function Find_Lib_Unit_Name
return Entity_Id
is
6564 -- Return inner compilation unit entity, for case of nested
6565 -- categorization pragmas. This happens in generic unit.
6567 if Nkind
(Parent
(N
)) = N_Package_Specification
6568 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6570 return Defining_Entity
(Parent
(N
));
6572 return Current_Scope
;
6574 end Find_Lib_Unit_Name
;
6576 ----------------------------
6577 -- Find_Program_Unit_Name --
6578 ----------------------------
6580 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6581 Unit_Name
: Entity_Id
;
6582 Unit_Kind
: Node_Kind
;
6583 P
: constant Node_Id
:= Parent
(N
);
6586 if Nkind
(P
) = N_Compilation_Unit
then
6587 Unit_Kind
:= Nkind
(Unit
(P
));
6589 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6590 N_Package_Declaration
)
6591 or else Unit_Kind
in N_Generic_Declaration
6593 Unit_Name
:= Defining_Entity
(Unit
(P
));
6595 if Chars
(Id
) = Chars
(Unit_Name
) then
6596 Set_Entity
(Id
, Unit_Name
);
6597 Set_Etype
(Id
, Etype
(Unit_Name
));
6599 Set_Etype
(Id
, Any_Type
);
6601 ("cannot find program unit referenced by pragma%");
6605 Set_Etype
(Id
, Any_Type
);
6606 Error_Pragma
("pragma% inapplicable to this unit");
6612 end Find_Program_Unit_Name
;
6614 -----------------------------------------
6615 -- Find_Unique_Parameterless_Procedure --
6616 -----------------------------------------
6618 function Find_Unique_Parameterless_Procedure
6620 Arg
: Node_Id
) return Entity_Id
6622 Proc
: Entity_Id
:= Empty
;
6625 -- The body of this procedure needs some comments ???
6627 if not Is_Entity_Name
(Name
) then
6629 ("argument of pragma% must be entity name", Arg
);
6631 elsif not Is_Overloaded
(Name
) then
6632 Proc
:= Entity
(Name
);
6634 if Ekind
(Proc
) /= E_Procedure
6635 or else Present
(First_Formal
(Proc
))
6638 ("argument of pragma% must be parameterless procedure", Arg
);
6643 Found
: Boolean := False;
6645 Index
: Interp_Index
;
6648 Get_First_Interp
(Name
, Index
, It
);
6649 while Present
(It
.Nam
) loop
6652 if Ekind
(Proc
) = E_Procedure
6653 and then No
(First_Formal
(Proc
))
6657 Set_Entity
(Name
, Proc
);
6658 Set_Is_Overloaded
(Name
, False);
6661 ("ambiguous handler name for pragma% ", Arg
);
6665 Get_Next_Interp
(Index
, It
);
6670 ("argument of pragma% must be parameterless procedure",
6673 Proc
:= Entity
(Name
);
6679 end Find_Unique_Parameterless_Procedure
;
6685 function Fix_Error
(Msg
: String) return String is
6686 Res
: String (Msg
'Range) := Msg
;
6687 Res_Last
: Natural := Msg
'Last;
6691 -- If we have a rewriting of another pragma, go to that pragma
6693 if Is_Rewrite_Substitution
(N
)
6694 and then Nkind
(Original_Node
(N
)) = N_Pragma
6696 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6699 -- Case where pragma comes from an aspect specification
6701 if From_Aspect_Specification
(N
) then
6703 -- Change appearence of "pragma" in message to "aspect"
6706 while J
<= Res_Last
- 5 loop
6707 if Res
(J
.. J
+ 5) = "pragma" then
6708 Res
(J
.. J
+ 5) := "aspect";
6716 -- Change "argument of" at start of message to "entity for"
6719 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6721 Res
(Res
'First .. Res
'First + 9) := "entity for";
6722 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6723 Res
(Res
'First + 11 .. Res_Last
);
6724 Res_Last
:= Res_Last
- 1;
6727 -- Change "argument" at start of message to "entity"
6730 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6732 Res
(Res
'First .. Res
'First + 5) := "entity";
6733 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6734 Res
(Res
'First + 8 .. Res_Last
);
6735 Res_Last
:= Res_Last
- 2;
6738 -- Get name from corresponding aspect
6740 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6743 -- Return possibly modified message
6745 return Res
(Res
'First .. Res_Last
);
6748 -------------------------
6749 -- Gather_Associations --
6750 -------------------------
6752 procedure Gather_Associations
6754 Args
: out Args_List
)
6759 -- Initialize all parameters to Empty
6761 for J
in Args
'Range loop
6765 -- That's all we have to do if there are no argument associations
6767 if No
(Pragma_Argument_Associations
(N
)) then
6771 -- Otherwise first deal with any positional parameters present
6773 Arg
:= First
(Pragma_Argument_Associations
(N
));
6774 for Index
in Args
'Range loop
6775 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6776 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6780 -- Positional parameters all processed, if any left, then we
6781 -- have too many positional parameters.
6783 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6785 ("too many positional associations for pragma%", Arg
);
6788 -- Process named parameters if any are present
6790 while Present
(Arg
) loop
6791 if Chars
(Arg
) = No_Name
then
6793 ("positional association cannot follow named association",
6797 for Index
in Names
'Range loop
6798 if Names
(Index
) = Chars
(Arg
) then
6799 if Present
(Args
(Index
)) then
6801 ("duplicate argument association for pragma%", Arg
);
6803 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6808 if Index
= Names
'Last then
6809 Error_Msg_Name_1
:= Pname
;
6810 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6812 -- Check for possible misspelling
6814 for Index1
in Names
'Range loop
6815 if Is_Bad_Spelling_Of
6816 (Chars
(Arg
), Names
(Index1
))
6818 Error_Msg_Name_1
:= Names
(Index1
);
6819 Error_Msg_N
-- CODEFIX
6820 ("\possible misspelling of%", Arg
);
6832 end Gather_Associations
;
6838 procedure GNAT_Pragma
is
6840 -- We need to check the No_Implementation_Pragmas restriction for
6841 -- the case of a pragma from source. Note that the case of aspects
6842 -- generating corresponding pragmas marks these pragmas as not being
6843 -- from source, so this test also catches that case.
6845 if Comes_From_Source
(N
) then
6846 Check_Restriction
(No_Implementation_Pragmas
, N
);
6850 --------------------------
6851 -- Is_Before_First_Decl --
6852 --------------------------
6854 function Is_Before_First_Decl
6855 (Pragma_Node
: Node_Id
;
6856 Decls
: List_Id
) return Boolean
6858 Item
: Node_Id
:= First
(Decls
);
6861 -- Only other pragmas can come before this pragma
6864 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6867 elsif Item
= Pragma_Node
then
6873 end Is_Before_First_Decl
;
6875 -----------------------------
6876 -- Is_Configuration_Pragma --
6877 -----------------------------
6879 -- A configuration pragma must appear in the context clause of a
6880 -- compilation unit, and only other pragmas may precede it. Note that
6881 -- the test below also permits use in a configuration pragma file.
6883 function Is_Configuration_Pragma
return Boolean is
6884 Lis
: constant List_Id
:= List_Containing
(N
);
6885 Par
: constant Node_Id
:= Parent
(N
);
6889 -- If no parent, then we are in the configuration pragma file,
6890 -- so the placement is definitely appropriate.
6895 -- Otherwise we must be in the context clause of a compilation unit
6896 -- and the only thing allowed before us in the context list is more
6897 -- configuration pragmas.
6899 elsif Nkind
(Par
) = N_Compilation_Unit
6900 and then Context_Items
(Par
) = Lis
6907 elsif Nkind
(Prg
) /= N_Pragma
then
6917 end Is_Configuration_Pragma
;
6919 --------------------------
6920 -- Is_In_Context_Clause --
6921 --------------------------
6923 function Is_In_Context_Clause
return Boolean is
6925 Parent_Node
: Node_Id
;
6928 if not Is_List_Member
(N
) then
6932 Plist
:= List_Containing
(N
);
6933 Parent_Node
:= Parent
(Plist
);
6935 if Parent_Node
= Empty
6936 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6937 or else Context_Items
(Parent_Node
) /= Plist
6944 end Is_In_Context_Clause
;
6946 ---------------------------------
6947 -- Is_Static_String_Expression --
6948 ---------------------------------
6950 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6951 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6952 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6955 Analyze_And_Resolve
(Argx
);
6957 -- Special case Ada 83, where the expression will never be static,
6958 -- but we will return true if we had a string literal to start with.
6960 if Ada_Version
= Ada_83
then
6963 -- Normal case, true only if we end up with a string literal that
6964 -- is marked as being the result of evaluating a static expression.
6967 return Is_OK_Static_Expression
(Argx
)
6968 and then Nkind
(Argx
) = N_String_Literal
;
6971 end Is_Static_String_Expression
;
6973 ----------------------
6974 -- Pragma_Misplaced --
6975 ----------------------
6977 procedure Pragma_Misplaced
is
6979 Error_Pragma
("incorrect placement of pragma%");
6980 end Pragma_Misplaced
;
6982 ------------------------------------------------
6983 -- Process_Atomic_Independent_Shared_Volatile --
6984 ------------------------------------------------
6986 procedure Process_Atomic_Independent_Shared_Volatile
is
6987 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
6988 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
6990 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
6991 -- Appropriately set flags on the given entity (either an array or
6992 -- record component, or an object declaration) according to the
6995 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
6996 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6997 -- no explicit alignment was given, set alignment to unknown, since
6998 -- back end knows what the alignment requirements are for atomic and
6999 -- full access arrays. Note: this is necessary for derived types.
7001 -------------------------
7002 -- Check_VFA_Conflicts --
7003 -------------------------
7005 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7009 VFA_And_Atomic
: Boolean := False;
7010 -- Set True if atomic component present
7012 VFA_And_Aliased
: Boolean := False;
7013 -- Set True if aliased component present
7016 -- Fetch the type in case we are dealing with an object or
7019 if Is_Type
(Ent
) then
7022 pragma Assert
(Is_Object
(Ent
)
7024 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7029 -- Check Atomic and VFA used together
7031 if Prag_Id
= Pragma_Volatile_Full_Access
7032 or else Is_Volatile_Full_Access
(Ent
)
7034 if Prag_Id
= Pragma_Atomic
7035 or else Prag_Id
= Pragma_Shared
7036 or else Is_Atomic
(Ent
)
7038 VFA_And_Atomic
:= True;
7040 elsif Is_Array_Type
(Typ
) then
7041 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7043 -- Note: Has_Atomic_Components is not used below, as this flag
7044 -- represents the pragma of the same name, Atomic_Components,
7045 -- which only applies to arrays.
7047 elsif Is_Record_Type
(Typ
) then
7048 -- Attributes cannot be applied to discriminants, only
7049 -- regular record components.
7051 Comp
:= First_Component
(Typ
);
7052 while Present
(Comp
) loop
7054 or else Is_Atomic
(Typ
)
7056 VFA_And_Atomic
:= True;
7061 Next_Component
(Comp
);
7065 if VFA_And_Atomic
then
7067 ("cannot have Volatile_Full_Access and Atomic for same "
7072 -- Check for the application of VFA to an entity that has aliased
7075 if Prag_Id
= Pragma_Volatile_Full_Access
then
7076 if Is_Array_Type
(Typ
)
7077 and then Has_Aliased_Components
(Typ
)
7079 VFA_And_Aliased
:= True;
7081 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7082 -- and Has_Independent_Components, applies only to arrays.
7083 -- However, this flag does not have a corresponding pragma, so
7084 -- perhaps it should be possible to apply it to record types as
7085 -- well. Should this be done ???
7087 elsif Is_Record_Type
(Typ
) then
7088 -- It is possible to have an aliased discriminant, so they
7089 -- must be checked along with normal components.
7091 Comp
:= First_Component_Or_Discriminant
(Typ
);
7092 while Present
(Comp
) loop
7093 if Is_Aliased
(Comp
)
7094 or else Is_Aliased
(Etype
(Comp
))
7096 VFA_And_Aliased
:= True;
7097 Check_SPARK_05_Restriction
7098 ("aliased is not allowed", Comp
);
7103 Next_Component_Or_Discriminant
(Comp
);
7107 if VFA_And_Aliased
then
7109 ("cannot apply Volatile_Full_Access (aliased component "
7113 end Check_VFA_Conflicts
;
7115 ------------------------------
7116 -- Mark_Component_Or_Object --
7117 ------------------------------
7119 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7121 if Prag_Id
= Pragma_Atomic
7122 or else Prag_Id
= Pragma_Shared
7123 or else Prag_Id
= Pragma_Volatile_Full_Access
7125 if Prag_Id
= Pragma_Volatile_Full_Access
then
7126 Set_Is_Volatile_Full_Access
(Ent
);
7128 Set_Is_Atomic
(Ent
);
7131 -- If the object declaration has an explicit initialization, a
7132 -- temporary may have to be created to hold the expression, to
7133 -- ensure that access to the object remains atomic.
7135 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7136 and then Present
(Expression
(Parent
(Ent
)))
7138 Set_Has_Delayed_Freeze
(Ent
);
7142 -- Atomic/Shared/Volatile_Full_Access imply Independent
7144 if Prag_Id
/= Pragma_Volatile
then
7145 Set_Is_Independent
(Ent
);
7147 if Prag_Id
= Pragma_Independent
then
7148 Record_Independence_Check
(N
, Ent
);
7152 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7154 if Prag_Id
/= Pragma_Independent
then
7155 Set_Is_Volatile
(Ent
);
7156 Set_Treat_As_Volatile
(Ent
);
7158 end Mark_Component_Or_Object
;
7160 --------------------
7161 -- Set_Atomic_VFA --
7162 --------------------
7164 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7166 if Prag_Id
= Pragma_Volatile_Full_Access
then
7167 Set_Is_Volatile_Full_Access
(Ent
);
7169 Set_Is_Atomic
(Ent
);
7172 if not Has_Alignment_Clause
(Ent
) then
7173 Set_Alignment
(Ent
, Uint_0
);
7183 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7186 Check_Ada_83_Warning
;
7187 Check_No_Identifiers
;
7188 Check_Arg_Count
(1);
7189 Check_Arg_Is_Local_Name
(Arg1
);
7190 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7192 if Etype
(E_Arg
) = Any_Type
then
7196 E
:= Entity
(E_Arg
);
7198 -- A pragma that applies to a Ghost entity becomes Ghost for the
7199 -- purposes of legality checks and removal of ignored Ghost code.
7201 Mark_Ghost_Pragma
(N
, E
);
7203 -- Check duplicate before we chain ourselves
7205 Check_Duplicate_Pragma
(E
);
7207 -- Check appropriateness of the entity
7209 Decl
:= Declaration_Node
(E
);
7211 -- Deal with the case where the pragma/attribute is applied to a type
7214 if Rep_Item_Too_Early
(E
, N
)
7215 or else Rep_Item_Too_Late
(E
, N
)
7219 Check_First_Subtype
(Arg1
);
7222 -- Attribute belongs on the base type. If the view of the type is
7223 -- currently private, it also belongs on the underlying type.
7225 if Prag_Id
= Pragma_Atomic
7226 or else Prag_Id
= Pragma_Shared
7227 or else Prag_Id
= Pragma_Volatile_Full_Access
7230 Set_Atomic_VFA
(Base_Type
(E
));
7231 Set_Atomic_VFA
(Underlying_Type
(E
));
7234 -- Atomic/Shared/Volatile_Full_Access imply Independent
7236 if Prag_Id
/= Pragma_Volatile
then
7237 Set_Is_Independent
(E
);
7238 Set_Is_Independent
(Base_Type
(E
));
7239 Set_Is_Independent
(Underlying_Type
(E
));
7241 if Prag_Id
= Pragma_Independent
then
7242 Record_Independence_Check
(N
, Base_Type
(E
));
7246 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7248 if Prag_Id
/= Pragma_Independent
then
7249 Set_Is_Volatile
(E
);
7250 Set_Is_Volatile
(Base_Type
(E
));
7251 Set_Is_Volatile
(Underlying_Type
(E
));
7253 Set_Treat_As_Volatile
(E
);
7254 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7257 -- Apply Volatile to the composite type's individual components,
7260 if Prag_Id
= Pragma_Volatile
7261 and then Is_Record_Type
(Etype
(E
))
7266 Comp
:= First_Component
(E
);
7267 while Present
(Comp
) loop
7268 Mark_Component_Or_Object
(Comp
);
7270 Next_Component
(Comp
);
7275 -- Deal with the case where the pragma/attribute applies to a
7276 -- component or object declaration.
7278 elsif Nkind
(Decl
) = N_Object_Declaration
7279 or else (Nkind
(Decl
) = N_Component_Declaration
7280 and then Original_Record_Component
(E
) = E
)
7282 if Rep_Item_Too_Late
(E
, N
) then
7286 Mark_Component_Or_Object
(E
);
7288 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7291 -- Perform the checks needed to assure the proper use of the GNAT
7292 -- pragma Volatile_Full_Access.
7294 Check_VFA_Conflicts
(E
);
7296 -- The following check is only relevant when SPARK_Mode is on as
7297 -- this is not a standard Ada legality rule. Pragma Volatile can
7298 -- only apply to a full type declaration or an object declaration
7299 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7300 -- untagged derived types that are rewritten as subtypes of their
7301 -- respective root types.
7304 and then Prag_Id
= Pragma_Volatile
7306 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
7307 N_Object_Declaration
)
7310 ("argument of pragma % must denote a full type or object "
7311 & "declaration", Arg1
);
7313 end Process_Atomic_Independent_Shared_Volatile
;
7315 -------------------------------------------
7316 -- Process_Compile_Time_Warning_Or_Error --
7317 -------------------------------------------
7319 procedure Process_Compile_Time_Warning_Or_Error
is
7320 Validation_Needed
: Boolean := False;
7322 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7323 -- Tree visitor that checks if N is an attribute reference that can
7324 -- be statically computed by the back end. Validation_Needed is set
7325 -- to True if found.
7331 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7333 if Nkind
(N
) = N_Attribute_Reference
7334 and then Is_Entity_Name
(Prefix
(N
))
7337 Attr_Id
: constant Attribute_Id
:=
7338 Get_Attribute_Id
(Attribute_Name
(N
));
7340 if Attr_Id
= Attribute_Alignment
7341 or else Attr_Id
= Attribute_Size
7343 Validation_Needed
:= True;
7351 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7355 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7357 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7360 Check_Arg_Count
(2);
7361 Check_No_Identifiers
;
7362 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7363 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7365 if Compile_Time_Known_Value
(Arg1x
) then
7366 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7368 -- Register the expression for its validation after the back end has
7369 -- been called if it has occurrences of attributes Size or Alignment
7370 -- (because they may be statically computed by the back end and hence
7371 -- the whole expression needs to be reevaluated).
7374 Check_Expression
(Arg1x
);
7376 if Validation_Needed
then
7377 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7380 end Process_Compile_Time_Warning_Or_Error
;
7382 ------------------------
7383 -- Process_Convention --
7384 ------------------------
7386 procedure Process_Convention
7387 (C
: out Convention_Id
;
7388 Ent
: out Entity_Id
)
7392 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7393 -- Called if we have more than one Export/Import/Convention pragma.
7394 -- This is generally illegal, but we have a special case of allowing
7395 -- Import and Interface to coexist if they specify the convention in
7396 -- a consistent manner. We are allowed to do this, since Interface is
7397 -- an implementation defined pragma, and we choose to do it since we
7398 -- know Rational allows this combination. S is the entity id of the
7399 -- subprogram in question. This procedure also sets the special flag
7400 -- Import_Interface_Present in both pragmas in the case where we do
7401 -- have matching Import and Interface pragmas.
7403 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7404 -- Set convention in entity E, and also flag that the entity has a
7405 -- convention pragma. If entity is for a private or incomplete type,
7406 -- also set convention and flag on underlying type. This procedure
7407 -- also deals with the special case of C_Pass_By_Copy convention,
7408 -- and error checks for inappropriate convention specification.
7410 -------------------------------
7411 -- Diagnose_Multiple_Pragmas --
7412 -------------------------------
7414 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7415 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7419 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7420 -- Decl is a pragma node. This function returns True if this
7421 -- pragma has a first argument that is an identifier with a
7422 -- Chars field corresponding to the Convention_Id C.
7424 function Same_Name
(Decl
: Node_Id
) return Boolean;
7425 -- Decl is a pragma node. This function returns True if this
7426 -- pragma has a second argument that is an identifier with a
7427 -- Chars field that matches the Chars of the current subprogram.
7429 ---------------------
7430 -- Same_Convention --
7431 ---------------------
7433 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7434 Arg1
: constant Node_Id
:=
7435 First
(Pragma_Argument_Associations
(Decl
));
7438 if Present
(Arg1
) then
7440 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7442 if Nkind
(Arg
) = N_Identifier
7443 and then Is_Convention_Name
(Chars
(Arg
))
7444 and then Get_Convention_Id
(Chars
(Arg
)) = C
7452 end Same_Convention
;
7458 function Same_Name
(Decl
: Node_Id
) return Boolean is
7459 Arg1
: constant Node_Id
:=
7460 First
(Pragma_Argument_Associations
(Decl
));
7468 Arg2
:= Next
(Arg1
);
7475 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7477 if Nkind
(Arg
) = N_Identifier
7478 and then Chars
(Arg
) = Chars
(S
)
7487 -- Start of processing for Diagnose_Multiple_Pragmas
7492 -- Definitely give message if we have Convention/Export here
7494 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7497 -- If we have an Import or Export, scan back from pragma to
7498 -- find any previous pragma applying to the same procedure.
7499 -- The scan will be terminated by the start of the list, or
7500 -- hitting the subprogram declaration. This won't allow one
7501 -- pragma to appear in the public part and one in the private
7502 -- part, but that seems very unlikely in practice.
7506 while Present
(Decl
) and then Decl
/= Pdec
loop
7508 -- Look for pragma with same name as us
7510 if Nkind
(Decl
) = N_Pragma
7511 and then Same_Name
(Decl
)
7513 -- Give error if same as our pragma or Export/Convention
7515 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7518 Pragma_Name_Unmapped
(N
))
7522 -- Case of Import/Interface or the other way round
7524 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7525 Name_Interface
, Name_Import
)
7527 -- Here we know that we have Import and Interface. It
7528 -- doesn't matter which way round they are. See if
7529 -- they specify the same convention. If so, all OK,
7530 -- and set special flags to stop other messages
7532 if Same_Convention
(Decl
) then
7533 Set_Import_Interface_Present
(N
);
7534 Set_Import_Interface_Present
(Decl
);
7537 -- If different conventions, special message
7540 Error_Msg_Sloc
:= Sloc
(Decl
);
7542 ("convention differs from that given#", Arg1
);
7552 -- Give message if needed if we fall through those tests
7553 -- except on Relaxed_RM_Semantics where we let go: either this
7554 -- is a case accepted/ignored by other Ada compilers (e.g.
7555 -- a mix of Convention and Import), or another error will be
7556 -- generated later (e.g. using both Import and Export).
7558 if Err
and not Relaxed_RM_Semantics
then
7560 ("at most one Convention/Export/Import pragma is allowed",
7563 end Diagnose_Multiple_Pragmas
;
7565 --------------------------------
7566 -- Set_Convention_From_Pragma --
7567 --------------------------------
7569 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7571 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7572 -- for an overridden dispatching operation. Technically this is
7573 -- an amendment and should only be done in Ada 2005 mode. However,
7574 -- this is clearly a mistake, since the problem that is addressed
7575 -- by this AI is that there is a clear gap in the RM.
7577 if Is_Dispatching_Operation
(E
)
7578 and then Present
(Overridden_Operation
(E
))
7579 and then C
/= Convention
(Overridden_Operation
(E
))
7582 ("cannot change convention for overridden dispatching "
7583 & "operation", Arg1
);
7586 -- Special checks for Convention_Stdcall
7588 if C
= Convention_Stdcall
then
7590 -- A dispatching call is not allowed. A dispatching subprogram
7591 -- cannot be used to interface to the Win32 API, so in fact
7592 -- this check does not impose any effective restriction.
7594 if Is_Dispatching_Operation
(E
) then
7595 Error_Msg_Sloc
:= Sloc
(E
);
7597 -- Note: make this unconditional so that if there is more
7598 -- than one call to which the pragma applies, we get a
7599 -- message for each call. Also don't use Error_Pragma,
7600 -- so that we get multiple messages.
7603 ("dispatching subprogram# cannot use Stdcall convention!",
7606 -- Several allowed cases
7608 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7612 or else Ekind
(E
) = E_Variable
7614 -- A component as well. The entity does not have its Ekind
7615 -- set until the enclosing record declaration is fully
7618 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7620 -- An access to subprogram is also allowed
7624 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7626 -- Allow internal call to set convention of subprogram type
7628 or else Ekind
(E
) = E_Subprogram_Type
7634 ("second argument of pragma% must be subprogram (type)",
7639 -- Set the convention
7641 Set_Convention
(E
, C
);
7642 Set_Has_Convention_Pragma
(E
);
7644 -- For the case of a record base type, also set the convention of
7645 -- any anonymous access types declared in the record which do not
7646 -- currently have a specified convention.
7648 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7653 Comp
:= First_Component
(E
);
7654 while Present
(Comp
) loop
7655 if Present
(Etype
(Comp
))
7656 and then Ekind_In
(Etype
(Comp
),
7657 E_Anonymous_Access_Type
,
7658 E_Anonymous_Access_Subprogram_Type
)
7659 and then not Has_Convention_Pragma
(Comp
)
7661 Set_Convention
(Comp
, C
);
7664 Next_Component
(Comp
);
7669 -- Deal with incomplete/private type case, where underlying type
7670 -- is available, so set convention of that underlying type.
7672 if Is_Incomplete_Or_Private_Type
(E
)
7673 and then Present
(Underlying_Type
(E
))
7675 Set_Convention
(Underlying_Type
(E
), C
);
7676 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7679 -- A class-wide type should inherit the convention of the specific
7680 -- root type (although this isn't specified clearly by the RM).
7682 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7683 Set_Convention
(Class_Wide_Type
(E
), C
);
7686 -- If the entity is a record type, then check for special case of
7687 -- C_Pass_By_Copy, which is treated the same as C except that the
7688 -- special record flag is set. This convention is only permitted
7689 -- on record types (see AI95-00131).
7691 if Cname
= Name_C_Pass_By_Copy
then
7692 if Is_Record_Type
(E
) then
7693 Set_C_Pass_By_Copy
(Base_Type
(E
));
7694 elsif Is_Incomplete_Or_Private_Type
(E
)
7695 and then Is_Record_Type
(Underlying_Type
(E
))
7697 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7700 ("C_Pass_By_Copy convention allowed only for record type",
7705 -- If the entity is a derived boolean type, check for the special
7706 -- case of convention C, C++, or Fortran, where we consider any
7707 -- nonzero value to represent true.
7709 if Is_Discrete_Type
(E
)
7710 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7716 C
= Convention_Fortran
)
7718 Set_Nonzero_Is_True
(Base_Type
(E
));
7720 end Set_Convention_From_Pragma
;
7724 Comp_Unit
: Unit_Number_Type
;
7729 -- Start of processing for Process_Convention
7732 Check_At_Least_N_Arguments
(2);
7733 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7734 Check_Arg_Is_Identifier
(Arg1
);
7735 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7737 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7738 -- tested again below to set the critical flag).
7740 if Cname
= Name_C_Pass_By_Copy
then
7743 -- Otherwise we must have something in the standard convention list
7745 elsif Is_Convention_Name
(Cname
) then
7746 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7748 -- Otherwise warn on unrecognized convention
7751 if Warn_On_Export_Import
then
7753 ("??unrecognized convention name, C assumed",
7754 Get_Pragma_Arg
(Arg1
));
7760 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7761 Check_Arg_Is_Local_Name
(Arg2
);
7763 Id
:= Get_Pragma_Arg
(Arg2
);
7766 if not Is_Entity_Name
(Id
) then
7767 Error_Pragma_Arg
("entity name required", Arg2
);
7772 -- Set entity to return
7776 -- Ada_Pass_By_Copy special checking
7778 if C
= Convention_Ada_Pass_By_Copy
then
7779 if not Is_First_Subtype
(E
) then
7781 ("convention `Ada_Pass_By_Copy` only allowed for types",
7785 if Is_By_Reference_Type
(E
) then
7787 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7791 -- Ada_Pass_By_Reference special checking
7793 elsif C
= Convention_Ada_Pass_By_Reference
then
7794 if not Is_First_Subtype
(E
) then
7796 ("convention `Ada_Pass_By_Reference` only allowed for types",
7800 if Is_By_Copy_Type
(E
) then
7802 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7807 -- Go to renamed subprogram if present, since convention applies to
7808 -- the actual renamed entity, not to the renaming entity. If the
7809 -- subprogram is inherited, go to parent subprogram.
7811 if Is_Subprogram
(E
)
7812 and then Present
(Alias
(E
))
7814 if Nkind
(Parent
(Declaration_Node
(E
))) =
7815 N_Subprogram_Renaming_Declaration
7817 if Scope
(E
) /= Scope
(Alias
(E
)) then
7819 ("cannot apply pragma% to non-local entity&#", E
);
7824 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7825 N_Private_Extension_Declaration
)
7826 and then Scope
(E
) = Scope
(Alias
(E
))
7830 -- Return the parent subprogram the entity was inherited from
7836 -- Check that we are not applying this to a specless body. Relax this
7837 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7839 if Is_Subprogram
(E
)
7840 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7841 and then not Relaxed_RM_Semantics
7844 ("pragma% requires separate spec and must come before body");
7847 -- Check that we are not applying this to a named constant
7849 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7850 Error_Msg_Name_1
:= Pname
;
7852 ("cannot apply pragma% to named constant!",
7853 Get_Pragma_Arg
(Arg2
));
7855 ("\supply appropriate type for&!", Arg2
);
7858 if Ekind
(E
) = E_Enumeration_Literal
then
7859 Error_Pragma
("enumeration literal not allowed for pragma%");
7862 -- Check for rep item appearing too early or too late
7864 if Etype
(E
) = Any_Type
7865 or else Rep_Item_Too_Early
(E
, N
)
7869 elsif Present
(Underlying_Type
(E
)) then
7870 E
:= Underlying_Type
(E
);
7873 if Rep_Item_Too_Late
(E
, N
) then
7877 if Has_Convention_Pragma
(E
) then
7878 Diagnose_Multiple_Pragmas
(E
);
7880 elsif Convention
(E
) = Convention_Protected
7881 or else Ekind
(Scope
(E
)) = E_Protected_Type
7884 ("a protected operation cannot be given a different convention",
7888 -- For Intrinsic, a subprogram is required
7890 if C
= Convention_Intrinsic
7891 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7893 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7895 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7897 ("second argument of pragma% must be a subprogram", Arg2
);
7901 -- Deal with non-subprogram cases
7903 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7904 Set_Convention_From_Pragma
(E
);
7908 -- The pragma must apply to a first subtype, but it can also
7909 -- apply to a generic type in a generic formal part, in which
7910 -- case it will also appear in the corresponding instance.
7912 if Is_Generic_Type
(E
) or else In_Instance
then
7915 Check_First_Subtype
(Arg2
);
7918 Set_Convention_From_Pragma
(Base_Type
(E
));
7920 -- For access subprograms, we must set the convention on the
7921 -- internally generated directly designated type as well.
7923 if Ekind
(E
) = E_Access_Subprogram_Type
then
7924 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7928 -- For the subprogram case, set proper convention for all homonyms
7929 -- in same scope and the same declarative part, i.e. the same
7930 -- compilation unit.
7933 Comp_Unit
:= Get_Source_Unit
(E
);
7934 Set_Convention_From_Pragma
(E
);
7936 -- Treat a pragma Import as an implicit body, and pragma import
7937 -- as implicit reference (for navigation in GPS).
7939 if Prag_Id
= Pragma_Import
then
7940 Generate_Reference
(E
, Id
, 'b');
7942 -- For exported entities we restrict the generation of references
7943 -- to entities exported to foreign languages since entities
7944 -- exported to Ada do not provide further information to GPS and
7945 -- add undesired references to the output of the gnatxref tool.
7947 elsif Prag_Id
= Pragma_Export
7948 and then Convention
(E
) /= Convention_Ada
7950 Generate_Reference
(E
, Id
, 'i');
7953 -- If the pragma comes from an aspect, it only applies to the
7954 -- given entity, not its homonyms.
7956 if From_Aspect_Specification
(N
) then
7957 if C
= Convention_Intrinsic
7958 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
7960 if Is_Fixed_Point_Type
(Etype
(Ent
))
7961 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
7962 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
7965 ("no intrinsic operator available for this fixed-point "
7968 ("\use expression functions with the desired "
7969 & "conversions made explicit", N
);
7976 -- Otherwise Loop through the homonyms of the pragma argument's
7977 -- entity, an apply convention to those in the current scope.
7983 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7985 -- Ignore entry for which convention is already set
7987 if Has_Convention_Pragma
(E1
) then
7991 if Is_Subprogram
(E1
)
7992 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
7994 and then not Relaxed_RM_Semantics
7996 Set_Has_Completion
(E
); -- to prevent cascaded error
7998 ("pragma% requires separate spec and must come before "
8002 -- Do not set the pragma on inherited operations or on formal
8005 if Comes_From_Source
(E1
)
8006 and then Comp_Unit
= Get_Source_Unit
(E1
)
8007 and then not Is_Formal_Subprogram
(E1
)
8008 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8009 N_Full_Type_Declaration
8011 if Present
(Alias
(E1
))
8012 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8015 ("cannot apply pragma% to non-local entity& declared#",
8019 Set_Convention_From_Pragma
(E1
);
8021 if Prag_Id
= Pragma_Import
then
8022 Generate_Reference
(E1
, Id
, 'b');
8030 end Process_Convention
;
8032 ----------------------------------------
8033 -- Process_Disable_Enable_Atomic_Sync --
8034 ----------------------------------------
8036 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8038 Check_No_Identifiers
;
8039 Check_At_Most_N_Arguments
(1);
8041 -- Modeled internally as
8042 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8047 Pragma_Argument_Associations
=> New_List
(
8048 Make_Pragma_Argument_Association
(Loc
,
8050 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8052 if Present
(Arg1
) then
8053 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8057 end Process_Disable_Enable_Atomic_Sync
;
8059 -------------------------------------------------
8060 -- Process_Extended_Import_Export_Internal_Arg --
8061 -------------------------------------------------
8063 procedure Process_Extended_Import_Export_Internal_Arg
8064 (Arg_Internal
: Node_Id
:= Empty
)
8067 if No
(Arg_Internal
) then
8068 Error_Pragma
("Internal parameter required for pragma%");
8071 if Nkind
(Arg_Internal
) = N_Identifier
then
8074 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8075 and then (Prag_Id
= Pragma_Import_Function
8077 Prag_Id
= Pragma_Export_Function
)
8083 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8086 Check_Arg_Is_Local_Name
(Arg_Internal
);
8087 end Process_Extended_Import_Export_Internal_Arg
;
8089 --------------------------------------------------
8090 -- Process_Extended_Import_Export_Object_Pragma --
8091 --------------------------------------------------
8093 procedure Process_Extended_Import_Export_Object_Pragma
8094 (Arg_Internal
: Node_Id
;
8095 Arg_External
: Node_Id
;
8101 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8102 Def_Id
:= Entity
(Arg_Internal
);
8104 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8106 ("pragma% must designate an object", Arg_Internal
);
8109 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8111 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8114 ("previous Common/Psect_Object applies, pragma % not permitted",
8118 if Rep_Item_Too_Late
(Def_Id
, N
) then
8122 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8124 if Present
(Arg_Size
) then
8125 Check_Arg_Is_External_Name
(Arg_Size
);
8128 -- Export_Object case
8130 if Prag_Id
= Pragma_Export_Object
then
8131 if not Is_Library_Level_Entity
(Def_Id
) then
8133 ("argument for pragma% must be library level entity",
8137 if Ekind
(Current_Scope
) = E_Generic_Package
then
8138 Error_Pragma
("pragma& cannot appear in a generic unit");
8141 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8143 ("exported object must have compile time known size",
8147 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8148 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8150 Set_Exported
(Def_Id
, Arg_Internal
);
8153 -- Import_Object case
8156 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8158 ("cannot use pragma% for task/protected object",
8162 if Ekind
(Def_Id
) = E_Constant
then
8164 ("cannot import a constant", Arg_Internal
);
8167 if Warn_On_Export_Import
8168 and then Has_Discriminants
(Etype
(Def_Id
))
8171 ("imported value must be initialized??", Arg_Internal
);
8174 if Warn_On_Export_Import
8175 and then Is_Access_Type
(Etype
(Def_Id
))
8178 ("cannot import object of an access type??", Arg_Internal
);
8181 if Warn_On_Export_Import
8182 and then Is_Imported
(Def_Id
)
8184 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8186 -- Check for explicit initialization present. Note that an
8187 -- initialization generated by the code generator, e.g. for an
8188 -- access type, does not count here.
8190 elsif Present
(Expression
(Parent
(Def_Id
)))
8193 (Original_Node
(Expression
(Parent
(Def_Id
))))
8195 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8197 ("imported entities cannot be initialized (RM B.1(24))",
8198 "\no initialization allowed for & declared#", Arg1
);
8200 Set_Imported
(Def_Id
);
8201 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8204 end Process_Extended_Import_Export_Object_Pragma
;
8206 ------------------------------------------------------
8207 -- Process_Extended_Import_Export_Subprogram_Pragma --
8208 ------------------------------------------------------
8210 procedure Process_Extended_Import_Export_Subprogram_Pragma
8211 (Arg_Internal
: Node_Id
;
8212 Arg_External
: Node_Id
;
8213 Arg_Parameter_Types
: Node_Id
;
8214 Arg_Result_Type
: Node_Id
:= Empty
;
8215 Arg_Mechanism
: Node_Id
;
8216 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8222 Ambiguous
: Boolean;
8225 function Same_Base_Type
8227 Formal
: Entity_Id
) return Boolean;
8228 -- Determines if Ptype references the type of Formal. Note that only
8229 -- the base types need to match according to the spec. Ptype here is
8230 -- the argument from the pragma, which is either a type name, or an
8231 -- access attribute.
8233 --------------------
8234 -- Same_Base_Type --
8235 --------------------
8237 function Same_Base_Type
8239 Formal
: Entity_Id
) return Boolean
8241 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8245 -- Case where pragma argument is typ'Access
8247 if Nkind
(Ptype
) = N_Attribute_Reference
8248 and then Attribute_Name
(Ptype
) = Name_Access
8250 Pref
:= Prefix
(Ptype
);
8253 if not Is_Entity_Name
(Pref
)
8254 or else Entity
(Pref
) = Any_Type
8259 -- We have a match if the corresponding argument is of an
8260 -- anonymous access type, and its designated type matches the
8261 -- type of the prefix of the access attribute
8263 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8264 and then Base_Type
(Entity
(Pref
)) =
8265 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8267 -- Case where pragma argument is a type name
8272 if not Is_Entity_Name
(Ptype
)
8273 or else Entity
(Ptype
) = Any_Type
8278 -- We have a match if the corresponding argument is of the type
8279 -- given in the pragma (comparing base types)
8281 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8285 -- Start of processing for
8286 -- Process_Extended_Import_Export_Subprogram_Pragma
8289 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8293 -- Loop through homonyms (overloadings) of the entity
8295 Hom_Id
:= Entity
(Arg_Internal
);
8296 while Present
(Hom_Id
) loop
8297 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8299 -- We need a subprogram in the current scope
8301 if not Is_Subprogram
(Def_Id
)
8302 or else Scope
(Def_Id
) /= Current_Scope
8309 -- Pragma cannot apply to subprogram body
8311 if Is_Subprogram
(Def_Id
)
8312 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8316 ("pragma% requires separate spec and must come before "
8320 -- Test result type if given, note that the result type
8321 -- parameter can only be present for the function cases.
8323 if Present
(Arg_Result_Type
)
8324 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8328 elsif Etype
(Def_Id
) /= Standard_Void_Type
8329 and then Nam_In
(Pname
, Name_Export_Procedure
,
8330 Name_Import_Procedure
)
8334 -- Test parameter types if given. Note that this parameter has
8335 -- not been analyzed (and must not be, since it is semantic
8336 -- nonsense), so we get it as the parser left it.
8338 elsif Present
(Arg_Parameter_Types
) then
8339 Check_Matching_Types
: declare
8344 Formal
:= First_Formal
(Def_Id
);
8346 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8347 if Present
(Formal
) then
8351 -- A list of one type, e.g. (List) is parsed as a
8352 -- parenthesized expression.
8354 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8355 and then Paren_Count
(Arg_Parameter_Types
) = 1
8358 or else Present
(Next_Formal
(Formal
))
8363 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8366 -- A list of more than one type is parsed as a aggregate
8368 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8369 and then Paren_Count
(Arg_Parameter_Types
) = 0
8371 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8372 while Present
(Ptype
) or else Present
(Formal
) loop
8375 or else not Same_Base_Type
(Ptype
, Formal
)
8380 Next_Formal
(Formal
);
8385 -- Anything else is of the wrong form
8389 ("wrong form for Parameter_Types parameter",
8390 Arg_Parameter_Types
);
8392 end Check_Matching_Types
;
8395 -- Match is now False if the entry we found did not match
8396 -- either a supplied Parameter_Types or Result_Types argument
8402 -- Ambiguous case, the flag Ambiguous shows if we already
8403 -- detected this and output the initial messages.
8406 if not Ambiguous
then
8408 Error_Msg_Name_1
:= Pname
;
8410 ("pragma% does not uniquely identify subprogram!",
8412 Error_Msg_Sloc
:= Sloc
(Ent
);
8413 Error_Msg_N
("matching subprogram #!", N
);
8417 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8418 Error_Msg_N
("matching subprogram #!", N
);
8423 Hom_Id
:= Homonym
(Hom_Id
);
8426 -- See if we found an entry
8429 if not Ambiguous
then
8430 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8432 ("pragma% cannot be given for generic subprogram");
8435 ("pragma% does not identify local subprogram");
8442 -- Import pragmas must be for imported entities
8444 if Prag_Id
= Pragma_Import_Function
8446 Prag_Id
= Pragma_Import_Procedure
8448 Prag_Id
= Pragma_Import_Valued_Procedure
8450 if not Is_Imported
(Ent
) then
8452 ("pragma Import or Interface must precede pragma%");
8455 -- Here we have the Export case which can set the entity as exported
8457 -- But does not do so if the specified external name is null, since
8458 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8459 -- compatible) to request no external name.
8461 elsif Nkind
(Arg_External
) = N_String_Literal
8462 and then String_Length
(Strval
(Arg_External
)) = 0
8466 -- In all other cases, set entity as exported
8469 Set_Exported
(Ent
, Arg_Internal
);
8472 -- Special processing for Valued_Procedure cases
8474 if Prag_Id
= Pragma_Import_Valued_Procedure
8476 Prag_Id
= Pragma_Export_Valued_Procedure
8478 Formal
:= First_Formal
(Ent
);
8481 Error_Pragma
("at least one parameter required for pragma%");
8483 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8484 Error_Pragma
("first parameter must have mode out for pragma%");
8487 Set_Is_Valued_Procedure
(Ent
);
8491 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8493 -- Process Result_Mechanism argument if present. We have already
8494 -- checked that this is only allowed for the function case.
8496 if Present
(Arg_Result_Mechanism
) then
8497 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8500 -- Process Mechanism parameter if present. Note that this parameter
8501 -- is not analyzed, and must not be analyzed since it is semantic
8502 -- nonsense, so we get it in exactly as the parser left it.
8504 if Present
(Arg_Mechanism
) then
8512 -- A single mechanism association without a formal parameter
8513 -- name is parsed as a parenthesized expression. All other
8514 -- cases are parsed as aggregates, so we rewrite the single
8515 -- parameter case as an aggregate for consistency.
8517 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8518 and then Paren_Count
(Arg_Mechanism
) = 1
8520 Rewrite
(Arg_Mechanism
,
8521 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8522 Expressions
=> New_List
(
8523 Relocate_Node
(Arg_Mechanism
))));
8526 -- Case of only mechanism name given, applies to all formals
8528 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8529 Formal
:= First_Formal
(Ent
);
8530 while Present
(Formal
) loop
8531 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8532 Next_Formal
(Formal
);
8535 -- Case of list of mechanism associations given
8538 if Null_Record_Present
(Arg_Mechanism
) then
8540 ("inappropriate form for Mechanism parameter",
8544 -- Deal with positional ones first
8546 Formal
:= First_Formal
(Ent
);
8548 if Present
(Expressions
(Arg_Mechanism
)) then
8549 Mname
:= First
(Expressions
(Arg_Mechanism
));
8550 while Present
(Mname
) loop
8553 ("too many mechanism associations", Mname
);
8556 Set_Mechanism_Value
(Formal
, Mname
);
8557 Next_Formal
(Formal
);
8562 -- Deal with named entries
8564 if Present
(Component_Associations
(Arg_Mechanism
)) then
8565 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8566 while Present
(Massoc
) loop
8567 Choice
:= First
(Choices
(Massoc
));
8569 if Nkind
(Choice
) /= N_Identifier
8570 or else Present
(Next
(Choice
))
8573 ("incorrect form for mechanism association",
8577 Formal
:= First_Formal
(Ent
);
8581 ("parameter name & not present", Choice
);
8584 if Chars
(Choice
) = Chars
(Formal
) then
8586 (Formal
, Expression
(Massoc
));
8588 -- Set entity on identifier (needed by ASIS)
8590 Set_Entity
(Choice
, Formal
);
8595 Next_Formal
(Formal
);
8604 end Process_Extended_Import_Export_Subprogram_Pragma
;
8606 --------------------------
8607 -- Process_Generic_List --
8608 --------------------------
8610 procedure Process_Generic_List
is
8615 Check_No_Identifiers
;
8616 Check_At_Least_N_Arguments
(1);
8618 -- Check all arguments are names of generic units or instances
8621 while Present
(Arg
) loop
8622 Exp
:= Get_Pragma_Arg
(Arg
);
8625 if not Is_Entity_Name
(Exp
)
8627 (not Is_Generic_Instance
(Entity
(Exp
))
8629 not Is_Generic_Unit
(Entity
(Exp
)))
8632 ("pragma% argument must be name of generic unit/instance",
8638 end Process_Generic_List
;
8640 ------------------------------------
8641 -- Process_Import_Predefined_Type --
8642 ------------------------------------
8644 procedure Process_Import_Predefined_Type
is
8645 Loc
: constant Source_Ptr
:= Sloc
(N
);
8647 Ftyp
: Node_Id
:= Empty
;
8653 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8655 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8656 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8660 Ftyp
:= Node
(Elmt
);
8662 if Present
(Ftyp
) then
8664 -- Don't build a derived type declaration, because predefined C
8665 -- types have no declaration anywhere, so cannot really be named.
8666 -- Instead build a full type declaration, starting with an
8667 -- appropriate type definition is built
8669 if Is_Floating_Point_Type
(Ftyp
) then
8670 Def
:= Make_Floating_Point_Definition
(Loc
,
8671 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8672 Make_Real_Range_Specification
(Loc
,
8673 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8674 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8676 -- Should never have a predefined type we cannot handle
8679 raise Program_Error
;
8682 -- Build and insert a Full_Type_Declaration, which will be
8683 -- analyzed as soon as this list entry has been analyzed.
8685 Decl
:= Make_Full_Type_Declaration
(Loc
,
8686 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8687 Type_Definition
=> Def
);
8689 Insert_After
(N
, Decl
);
8690 Mark_Rewrite_Insertion
(Decl
);
8693 Error_Pragma_Arg
("no matching type found for pragma%",
8696 end Process_Import_Predefined_Type
;
8698 ---------------------------------
8699 -- Process_Import_Or_Interface --
8700 ---------------------------------
8702 procedure Process_Import_Or_Interface
is
8708 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8709 -- pragma Import (Entity, "external name");
8711 if Relaxed_RM_Semantics
8712 and then Arg_Count
= 2
8713 and then Prag_Id
= Pragma_Import
8714 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8717 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8720 if not Is_Entity_Name
(Def_Id
) then
8721 Error_Pragma_Arg
("entity name required", Arg1
);
8724 Def_Id
:= Entity
(Def_Id
);
8725 Kill_Size_Check_Code
(Def_Id
);
8726 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8729 Process_Convention
(C
, Def_Id
);
8731 -- A pragma that applies to a Ghost entity becomes Ghost for the
8732 -- purposes of legality checks and removal of ignored Ghost code.
8734 Mark_Ghost_Pragma
(N
, Def_Id
);
8735 Kill_Size_Check_Code
(Def_Id
);
8736 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8739 -- Various error checks
8741 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8743 -- We do not permit Import to apply to a renaming declaration
8745 if Present
(Renamed_Object
(Def_Id
)) then
8747 ("pragma% not allowed for object renaming", Arg2
);
8749 -- User initialization is not allowed for imported object, but
8750 -- the object declaration may contain a default initialization,
8751 -- that will be discarded. Note that an explicit initialization
8752 -- only counts if it comes from source, otherwise it is simply
8753 -- the code generator making an implicit initialization explicit.
8755 elsif Present
(Expression
(Parent
(Def_Id
)))
8756 and then Comes_From_Source
8757 (Original_Node
(Expression
(Parent
(Def_Id
))))
8759 -- Set imported flag to prevent cascaded errors
8761 Set_Is_Imported
(Def_Id
);
8763 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8765 ("no initialization allowed for declaration of& #",
8766 "\imported entities cannot be initialized (RM B.1(24))",
8770 -- If the pragma comes from an aspect specification the
8771 -- Is_Imported flag has already been set.
8773 if not From_Aspect_Specification
(N
) then
8774 Set_Imported
(Def_Id
);
8777 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8779 -- Note that we do not set Is_Public here. That's because we
8780 -- only want to set it if there is no address clause, and we
8781 -- don't know that yet, so we delay that processing till
8784 -- pragma Import completes deferred constants
8786 if Ekind
(Def_Id
) = E_Constant
then
8787 Set_Has_Completion
(Def_Id
);
8790 -- It is not possible to import a constant of an unconstrained
8791 -- array type (e.g. string) because there is no simple way to
8792 -- write a meaningful subtype for it.
8794 if Is_Array_Type
(Etype
(Def_Id
))
8795 and then not Is_Constrained
(Etype
(Def_Id
))
8798 ("imported constant& must have a constrained subtype",
8803 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8805 -- If the name is overloaded, pragma applies to all of the denoted
8806 -- entities in the same declarative part, unless the pragma comes
8807 -- from an aspect specification or was generated by the compiler
8808 -- (such as for pragma Provide_Shift_Operators).
8811 while Present
(Hom_Id
) loop
8813 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8815 -- Ignore inherited subprograms because the pragma will apply
8816 -- to the parent operation, which is the one called.
8818 if Is_Overloadable
(Def_Id
)
8819 and then Present
(Alias
(Def_Id
))
8823 -- If it is not a subprogram, it must be in an outer scope and
8824 -- pragma does not apply.
8826 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8829 -- The pragma does not apply to primitives of interfaces
8831 elsif Is_Dispatching_Operation
(Def_Id
)
8832 and then Present
(Find_Dispatching_Type
(Def_Id
))
8833 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8837 -- Verify that the homonym is in the same declarative part (not
8838 -- just the same scope). If the pragma comes from an aspect
8839 -- specification we know that it is part of the declaration.
8841 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8842 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8843 and then not From_Aspect_Specification
(N
)
8848 -- If the pragma comes from an aspect specification the
8849 -- Is_Imported flag has already been set.
8851 if not From_Aspect_Specification
(N
) then
8852 Set_Imported
(Def_Id
);
8855 -- Reject an Import applied to an abstract subprogram
8857 if Is_Subprogram
(Def_Id
)
8858 and then Is_Abstract_Subprogram
(Def_Id
)
8860 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8862 ("cannot import abstract subprogram& declared#",
8866 -- Special processing for Convention_Intrinsic
8868 if C
= Convention_Intrinsic
then
8870 -- Link_Name argument not allowed for intrinsic
8874 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8876 -- If no external name is present, then check that this
8877 -- is a valid intrinsic subprogram. If an external name
8878 -- is present, then this is handled by the back end.
8881 Check_Intrinsic_Subprogram
8882 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8886 -- Verify that the subprogram does not have a completion
8887 -- through a renaming declaration. For other completions the
8888 -- pragma appears as a too late representation.
8891 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8895 and then Nkind
(Decl
) = N_Subprogram_Declaration
8896 and then Present
(Corresponding_Body
(Decl
))
8897 and then Nkind
(Unit_Declaration_Node
8898 (Corresponding_Body
(Decl
))) =
8899 N_Subprogram_Renaming_Declaration
8901 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8903 ("cannot import&, renaming already provided for "
8904 & "declaration #", N
, Def_Id
);
8908 -- If the pragma comes from an aspect specification, there
8909 -- must be an Import aspect specified as well. In the rare
8910 -- case where Import is set to False, the suprogram needs to
8911 -- have a local completion.
8914 Imp_Aspect
: constant Node_Id
:=
8915 Find_Aspect
(Def_Id
, Aspect_Import
);
8919 if Present
(Imp_Aspect
)
8920 and then Present
(Expression
(Imp_Aspect
))
8922 Expr
:= Expression
(Imp_Aspect
);
8923 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8925 if Is_Entity_Name
(Expr
)
8926 and then Entity
(Expr
) = Standard_True
8928 Set_Has_Completion
(Def_Id
);
8931 -- If there is no expression, the default is True, as for
8932 -- all boolean aspects. Same for the older pragma.
8935 Set_Has_Completion
(Def_Id
);
8939 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8942 if Is_Compilation_Unit
(Hom_Id
) then
8944 -- Its possible homonyms are not affected by the pragma.
8945 -- Such homonyms might be present in the context of other
8946 -- units being compiled.
8950 elsif From_Aspect_Specification
(N
) then
8953 -- If the pragma was created by the compiler, then we don't
8954 -- want it to apply to other homonyms. This kind of case can
8955 -- occur when using pragma Provide_Shift_Operators, which
8956 -- generates implicit shift and rotate operators with Import
8957 -- pragmas that might apply to earlier explicit or implicit
8958 -- declarations marked with Import (for example, coming from
8959 -- an earlier pragma Provide_Shift_Operators for another type),
8960 -- and we don't generally want other homonyms being treated
8961 -- as imported or the pragma flagged as an illegal duplicate.
8963 elsif not Comes_From_Source
(N
) then
8967 Hom_Id
:= Homonym
(Hom_Id
);
8971 -- Import a CPP class
8973 elsif C
= Convention_CPP
8974 and then (Is_Record_Type
(Def_Id
)
8975 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8977 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8978 if Present
(Full_View
(Def_Id
)) then
8979 Def_Id
:= Full_View
(Def_Id
);
8983 ("cannot import 'C'P'P type before full declaration seen",
8984 Get_Pragma_Arg
(Arg2
));
8986 -- Although we have reported the error we decorate it as
8987 -- CPP_Class to avoid reporting spurious errors
8989 Set_Is_CPP_Class
(Def_Id
);
8994 -- Types treated as CPP classes must be declared limited (note:
8995 -- this used to be a warning but there is no real benefit to it
8996 -- since we did effectively intend to treat the type as limited
8999 if not Is_Limited_Type
(Def_Id
) then
9001 ("imported 'C'P'P type must be limited",
9002 Get_Pragma_Arg
(Arg2
));
9005 if Etype
(Def_Id
) /= Def_Id
9006 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9008 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9011 Set_Is_CPP_Class
(Def_Id
);
9013 -- Imported CPP types must not have discriminants (because C++
9014 -- classes do not have discriminants).
9016 if Has_Discriminants
(Def_Id
) then
9018 ("imported 'C'P'P type cannot have discriminants",
9019 First
(Discriminant_Specifications
9020 (Declaration_Node
(Def_Id
))));
9023 -- Check that components of imported CPP types do not have default
9024 -- expressions. For private types this check is performed when the
9025 -- full view is analyzed (see Process_Full_View).
9027 if not Is_Private_Type
(Def_Id
) then
9028 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9031 -- Import a CPP exception
9033 elsif C
= Convention_CPP
9034 and then Ekind
(Def_Id
) = E_Exception
9038 ("'External_'Name arguments is required for 'Cpp exception",
9041 -- As only a string is allowed, Check_Arg_Is_External_Name
9044 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9047 if Present
(Arg4
) then
9049 ("Link_Name argument not allowed for imported Cpp exception",
9053 -- Do not call Set_Interface_Name as the name of the exception
9054 -- shouldn't be modified (and in particular it shouldn't be
9055 -- the External_Name). For exceptions, the External_Name is the
9056 -- name of the RTTI structure.
9058 -- ??? Emit an error if pragma Import/Export_Exception is present
9060 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9062 Check_Arg_Count
(3);
9063 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9065 Process_Import_Predefined_Type
;
9069 ("second argument of pragma% must be object, subprogram "
9070 & "or incomplete type",
9074 -- If this pragma applies to a compilation unit, then the unit, which
9075 -- is a subprogram, does not require (or allow) a body. We also do
9076 -- not need to elaborate imported procedures.
9078 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9080 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9082 Set_Body_Required
(Cunit
, False);
9085 end Process_Import_Or_Interface
;
9087 --------------------
9088 -- Process_Inline --
9089 --------------------
9091 procedure Process_Inline
(Status
: Inline_Status
) is
9098 Ghost_Error_Posted
: Boolean := False;
9099 -- Flag set when an error concerning the illegal mix of Ghost and
9100 -- non-Ghost subprograms is emitted.
9102 Ghost_Id
: Entity_Id
:= Empty
;
9103 -- The entity of the first Ghost subprogram encountered while
9104 -- processing the arguments of the pragma.
9106 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9107 -- Verify the placement of pragma Inline_Always with respect to the
9108 -- initial declaration of subprogram Spec_Id.
9110 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9111 -- Returns True if it can be determined at this stage that inlining
9112 -- is not possible, for example if the body is available and contains
9113 -- exception handlers, we prevent inlining, since otherwise we can
9114 -- get undefined symbols at link time. This function also emits a
9115 -- warning if the pragma appears too late.
9117 -- ??? is business with link symbols still valid, or does it relate
9118 -- to front end ZCX which is being phased out ???
9120 procedure Make_Inline
(Subp
: Entity_Id
);
9121 -- Subp is the defining unit name of the subprogram declaration. If
9122 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9123 -- the corresponding body, if there is one present.
9125 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9126 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9127 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9129 -----------------------------------
9130 -- Check_Inline_Always_Placement --
9131 -----------------------------------
9133 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9134 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9136 function Compilation_Unit_OK
return Boolean;
9137 pragma Inline
(Compilation_Unit_OK
);
9138 -- Determine whether pragma Inline_Always applies to a compatible
9139 -- compilation unit denoted by Spec_Id.
9141 function Declarative_List_OK
return Boolean;
9142 pragma Inline
(Declarative_List_OK
);
9143 -- Determine whether the initial declaration of subprogram Spec_Id
9144 -- and the pragma appear in compatible declarative lists.
9146 function Subprogram_Body_OK
return Boolean;
9147 pragma Inline
(Subprogram_Body_OK
);
9148 -- Determine whether pragma Inline_Always applies to a compatible
9149 -- subprogram body denoted by Spec_Id.
9151 -------------------------
9152 -- Compilation_Unit_OK --
9153 -------------------------
9155 function Compilation_Unit_OK
return Boolean is
9156 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9159 -- The pragma appears after the initial declaration of a
9160 -- compilation unit.
9162 -- procedure Comp_Unit;
9163 -- pragma Inline_Always (Comp_Unit);
9165 -- Note that for compatibility reasons, the following case is
9168 -- procedure Stand_Alone_Body_Comp_Unit is
9170 -- end Stand_Alone_Body_Comp_Unit;
9171 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9174 Nkind
(Comp_Unit
) = N_Compilation_Unit
9175 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9176 and then Is_List_Member
(N
)
9177 and then List_Containing
(N
) =
9178 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9179 end Compilation_Unit_OK
;
9181 -------------------------
9182 -- Declarative_List_OK --
9183 -------------------------
9185 function Declarative_List_OK
return Boolean is
9186 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9188 Init_Decl
: Node_Id
;
9189 Init_List
: List_Id
;
9190 Prag_List
: List_Id
;
9193 -- Determine the proper initial declaration. In general this is
9194 -- the declaration node of the subprogram except when the input
9195 -- denotes a generic instantiation.
9197 -- procedure Inst is new Gen;
9198 -- pragma Inline_Always (Inst);
9200 -- In this case the original subprogram is moved inside an
9201 -- anonymous package while pragma Inline_Always remains at the
9202 -- level of the anonymous package. Use the declaration of the
9203 -- package because it reflects the placement of the original
9206 -- package Anon_Pack is
9207 -- procedure Inst is ... end Inst; -- original
9210 -- procedure Inst renames Anon_Pack.Inst;
9211 -- pragma Inline_Always (Inst);
9213 if Is_Generic_Instance
(Spec_Id
) then
9214 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9215 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9217 Init_Decl
:= Spec_Decl
;
9220 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9221 Init_List
:= List_Containing
(Init_Decl
);
9222 Prag_List
:= List_Containing
(N
);
9224 -- The pragma and then initial declaration appear within the
9225 -- same declarative list.
9227 if Init_List
= Prag_List
then
9230 -- A special case of the above is when both the pragma and
9231 -- the initial declaration appear in different lists of a
9232 -- package spec, protected definition, or a task definition.
9237 -- pragma Inline_Always (Proc);
9240 elsif Nkind_In
(Context
, N_Package_Specification
,
9241 N_Protected_Definition
,
9243 and then Init_List
= Visible_Declarations
(Context
)
9244 and then Prag_List
= Private_Declarations
(Context
)
9251 end Declarative_List_OK
;
9253 ------------------------
9254 -- Subprogram_Body_OK --
9255 ------------------------
9257 function Subprogram_Body_OK
return Boolean is
9258 Body_Decl
: Node_Id
;
9261 -- The pragma appears within the declarative list of a stand-
9262 -- alone subprogram body.
9264 -- procedure Stand_Alone_Body is
9265 -- pragma Inline_Always (Stand_Alone_Body);
9268 -- end Stand_Alone_Body;
9270 -- The compiler creates a dummy spec in this case, however the
9271 -- pragma remains within the declarative list of the body.
9273 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9274 and then not Comes_From_Source
(Spec_Decl
)
9275 and then Present
(Corresponding_Body
(Spec_Decl
))
9278 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9280 if Present
(Declarations
(Body_Decl
))
9281 and then Is_List_Member
(N
)
9282 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9289 end Subprogram_Body_OK
;
9291 -- Start of processing for Check_Inline_Always_Placement
9294 -- This check is relevant only for pragma Inline_Always
9296 if Pname
/= Name_Inline_Always
then
9299 -- Nothing to do when the pragma is internally generated on the
9300 -- assumption that it is properly placed.
9302 elsif not Comes_From_Source
(N
) then
9305 -- Nothing to do for internally generated subprograms that act
9306 -- as accidental homonyms of a source subprogram being inlined.
9308 elsif not Comes_From_Source
(Spec_Id
) then
9311 -- Nothing to do for generic formal subprograms that act as
9312 -- homonyms of another source subprogram being inlined.
9314 elsif Is_Formal_Subprogram
(Spec_Id
) then
9317 elsif Compilation_Unit_OK
9318 or else Declarative_List_OK
9319 or else Subprogram_Body_OK
9324 -- At this point it is known that the pragma applies to or appears
9325 -- within a completing body, a completing stub, or a subunit.
9327 Error_Msg_Name_1
:= Pname
;
9328 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9329 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9332 ("pragma % must appear on initial declaration of subprogram "
9333 & "% defined #", N
);
9334 end Check_Inline_Always_Placement
;
9336 ---------------------------
9337 -- Inlining_Not_Possible --
9338 ---------------------------
9340 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9341 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9345 if Nkind
(Decl
) = N_Subprogram_Body
then
9346 Stats
:= Handled_Statement_Sequence
(Decl
);
9347 return Present
(Exception_Handlers
(Stats
))
9348 or else Present
(At_End_Proc
(Stats
));
9350 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9351 and then Present
(Corresponding_Body
(Decl
))
9353 if Analyzed
(Corresponding_Body
(Decl
)) then
9354 Error_Msg_N
("pragma appears too late, ignored??", N
);
9357 -- If the subprogram is a renaming as body, the body is just a
9358 -- call to the renamed subprogram, and inlining is trivially
9362 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9363 N_Subprogram_Renaming_Declaration
9369 Handled_Statement_Sequence
9370 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9373 Present
(Exception_Handlers
(Stats
))
9374 or else Present
(At_End_Proc
(Stats
));
9378 -- If body is not available, assume the best, the check is
9379 -- performed again when compiling enclosing package bodies.
9383 end Inlining_Not_Possible
;
9389 procedure Make_Inline
(Subp
: Entity_Id
) is
9390 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9391 Inner_Subp
: Entity_Id
:= Subp
;
9394 -- Ignore if bad type, avoid cascaded error
9396 if Etype
(Subp
) = Any_Type
then
9400 -- If inlining is not possible, for now do not treat as an error
9402 elsif Status
/= Suppressed
9403 and then Front_End_Inlining
9404 and then Inlining_Not_Possible
(Subp
)
9409 -- Here we have a candidate for inlining, but we must exclude
9410 -- derived operations. Otherwise we would end up trying to inline
9411 -- a phantom declaration, and the result would be to drag in a
9412 -- body which has no direct inlining associated with it. That
9413 -- would not only be inefficient but would also result in the
9414 -- backend doing cross-unit inlining in cases where it was
9415 -- definitely inappropriate to do so.
9417 -- However, a simple Comes_From_Source test is insufficient, since
9418 -- we do want to allow inlining of generic instances which also do
9419 -- not come from source. We also need to recognize specs generated
9420 -- by the front-end for bodies that carry the pragma. Finally,
9421 -- predefined operators do not come from source but are not
9422 -- inlineable either.
9424 elsif Is_Generic_Instance
(Subp
)
9425 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9429 elsif not Comes_From_Source
(Subp
)
9430 and then Scope
(Subp
) /= Standard_Standard
9436 -- The referenced entity must either be the enclosing entity, or
9437 -- an entity declared within the current open scope.
9439 if Present
(Scope
(Subp
))
9440 and then Scope
(Subp
) /= Current_Scope
9441 and then Subp
/= Current_Scope
9444 ("argument of% must be entity in current scope", Assoc
);
9448 -- Processing for procedure, operator or function. If subprogram
9449 -- is aliased (as for an instance) indicate that the renamed
9450 -- entity (if declared in the same unit) is inlined.
9451 -- If this is the anonymous subprogram created for a subprogram
9452 -- instance, the inlining applies to it directly. Otherwise we
9453 -- retrieve it as the alias of the visible subprogram instance.
9455 if Is_Subprogram
(Subp
) then
9457 -- Ensure that pragma Inline_Always is associated with the
9458 -- initial declaration of the subprogram.
9460 Check_Inline_Always_Placement
(Subp
);
9462 if Is_Wrapper_Package
(Scope
(Subp
)) then
9465 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9468 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9469 Set_Inline_Flags
(Inner_Subp
);
9471 Decl
:= Parent
(Parent
(Inner_Subp
));
9473 if Nkind
(Decl
) = N_Subprogram_Declaration
9474 and then Present
(Corresponding_Body
(Decl
))
9476 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9478 elsif Is_Generic_Instance
(Subp
)
9479 and then Comes_From_Source
(Subp
)
9481 -- Indicate that the body needs to be created for
9482 -- inlining subsequent calls. The instantiation node
9483 -- follows the declaration of the wrapper package
9484 -- created for it. The subprogram that requires the
9485 -- body is the anonymous one in the wrapper package.
9487 if Scope
(Subp
) /= Standard_Standard
9489 Need_Subprogram_Instance_Body
9490 (Next
(Unit_Declaration_Node
9491 (Scope
(Alias
(Subp
)))), Subp
)
9496 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9497 -- appear in a formal part to apply to a formal subprogram.
9498 -- Do not apply check within an instance or a formal package
9499 -- the test will have been applied to the original generic.
9501 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9502 and then List_Containing
(Decl
) = List_Containing
(N
)
9503 and then not In_Instance
9506 ("Inline cannot apply to a formal subprogram", N
);
9508 -- If Subp is a renaming, it is the renamed entity that
9509 -- will appear in any call, and be inlined. However, for
9510 -- ASIS uses it is convenient to indicate that the renaming
9511 -- itself is an inlined subprogram, so that some gnatcheck
9512 -- rules can be applied in the absence of expansion.
9514 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9515 Set_Inline_Flags
(Subp
);
9521 -- For a generic subprogram set flag as well, for use at the point
9522 -- of instantiation, to determine whether the body should be
9525 elsif Is_Generic_Subprogram
(Subp
) then
9526 Set_Inline_Flags
(Subp
);
9529 -- Literals are by definition inlined
9531 elsif Kind
= E_Enumeration_Literal
then
9534 -- Anything else is an error
9538 ("expect subprogram name for pragma%", Assoc
);
9542 ----------------------
9543 -- Set_Inline_Flags --
9544 ----------------------
9546 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9548 -- First set the Has_Pragma_XXX flags and issue the appropriate
9549 -- errors and warnings for suspicious combinations.
9551 if Prag_Id
= Pragma_No_Inline
then
9552 if Has_Pragma_Inline_Always
(Subp
) then
9554 ("Inline_Always and No_Inline are mutually exclusive", N
);
9555 elsif Has_Pragma_Inline
(Subp
) then
9557 ("Inline and No_Inline both specified for& ??",
9558 N
, Entity
(Subp_Id
));
9561 Set_Has_Pragma_No_Inline
(Subp
);
9563 if Prag_Id
= Pragma_Inline_Always
then
9564 if Has_Pragma_No_Inline
(Subp
) then
9566 ("Inline_Always and No_Inline are mutually exclusive",
9570 Set_Has_Pragma_Inline_Always
(Subp
);
9572 if Has_Pragma_No_Inline
(Subp
) then
9574 ("Inline and No_Inline both specified for& ??",
9575 N
, Entity
(Subp_Id
));
9579 Set_Has_Pragma_Inline
(Subp
);
9582 -- Then adjust the Is_Inlined flag. It can never be set if the
9583 -- subprogram is subject to pragma No_Inline.
9587 Set_Is_Inlined
(Subp
, False);
9593 if not Has_Pragma_No_Inline
(Subp
) then
9594 Set_Is_Inlined
(Subp
, True);
9598 -- A pragma that applies to a Ghost entity becomes Ghost for the
9599 -- purposes of legality checks and removal of ignored Ghost code.
9601 Mark_Ghost_Pragma
(N
, Subp
);
9603 -- Capture the entity of the first Ghost subprogram being
9604 -- processed for error detection purposes.
9606 if Is_Ghost_Entity
(Subp
) then
9607 if No
(Ghost_Id
) then
9611 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9612 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9614 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9615 Ghost_Error_Posted
:= True;
9617 Error_Msg_Name_1
:= Pname
;
9619 ("pragma % cannot mention ghost and non-ghost subprograms",
9622 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9623 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9625 Error_Msg_Sloc
:= Sloc
(Subp
);
9626 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9628 end Set_Inline_Flags
;
9630 -- Start of processing for Process_Inline
9633 Check_No_Identifiers
;
9634 Check_At_Least_N_Arguments
(1);
9636 if Status
= Enabled
then
9637 Inline_Processing_Required
:= True;
9641 while Present
(Assoc
) loop
9642 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9646 if Is_Entity_Name
(Subp_Id
) then
9647 Subp
:= Entity
(Subp_Id
);
9649 if Subp
= Any_Id
then
9651 -- If previous error, avoid cascaded errors
9653 Check_Error_Detected
;
9659 -- For the pragma case, climb homonym chain. This is
9660 -- what implements allowing the pragma in the renaming
9661 -- case, with the result applying to the ancestors, and
9662 -- also allows Inline to apply to all previous homonyms.
9664 if not From_Aspect_Specification
(N
) then
9665 while Present
(Homonym
(Subp
))
9666 and then Scope
(Homonym
(Subp
)) = Current_Scope
9668 Make_Inline
(Homonym
(Subp
));
9669 Subp
:= Homonym
(Subp
);
9676 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9682 -- If the context is a package declaration, the pragma indicates
9683 -- that inlining will require the presence of the corresponding
9684 -- body. (this may be further refined).
9687 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9688 N_Package_Declaration
9690 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9694 ----------------------------
9695 -- Process_Interface_Name --
9696 ----------------------------
9698 procedure Process_Interface_Name
9699 (Subprogram_Def
: Entity_Id
;
9706 String_Val
: String_Id
;
9708 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9709 -- SN is a string literal node for an interface name. This routine
9710 -- performs some minimal checks that the name is reasonable. In
9711 -- particular that no spaces or other obviously incorrect characters
9712 -- appear. This is only a warning, since any characters are allowed.
9714 ----------------------------------
9715 -- Check_Form_Of_Interface_Name --
9716 ----------------------------------
9718 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9719 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9720 SL
: constant Nat
:= String_Length
(S
);
9725 Error_Msg_N
("interface name cannot be null string", SN
);
9728 for J
in 1 .. SL
loop
9729 C
:= Get_String_Char
(S
, J
);
9731 -- Look for dubious character and issue unconditional warning.
9732 -- Definitely dubious if not in character range.
9734 if not In_Character_Range
(C
)
9736 -- Commas, spaces and (back)slashes are dubious
9738 or else Get_Character
(C
) = ','
9739 or else Get_Character
(C
) = '\'
9740 or else Get_Character
(C
) = ' '
9741 or else Get_Character
(C
) = '/'
9744 ("??interface name contains illegal character",
9745 Sloc
(SN
) + Source_Ptr
(J
));
9748 end Check_Form_Of_Interface_Name
;
9750 -- Start of processing for Process_Interface_Name
9753 -- If we are looking at a pragma that comes from an aspect then it
9754 -- needs to have its corresponding aspect argument expressions
9755 -- analyzed in addition to the generated pragma so that aspects
9756 -- within generic units get properly resolved.
9758 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9760 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9768 -- Obtain all interfacing aspects used to construct the pragma
9770 Get_Interfacing_Aspects
9771 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9773 -- Analyze the expression of aspect External_Name
9775 if Present
(EN
) then
9776 Analyze
(Expression
(EN
));
9779 -- Analyze the expressio of aspect Link_Name
9781 if Present
(LN
) then
9782 Analyze
(Expression
(LN
));
9787 if No
(Link_Arg
) then
9788 if No
(Ext_Arg
) then
9791 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9793 Link_Nam
:= Expression
(Ext_Arg
);
9796 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9797 Ext_Nam
:= Expression
(Ext_Arg
);
9802 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9803 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9804 Ext_Nam
:= Expression
(Ext_Arg
);
9805 Link_Nam
:= Expression
(Link_Arg
);
9808 -- Check expressions for external name and link name are static
9810 if Present
(Ext_Nam
) then
9811 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9812 Check_Form_Of_Interface_Name
(Ext_Nam
);
9814 -- Verify that external name is not the name of a local entity,
9815 -- which would hide the imported one and could lead to run-time
9816 -- surprises. The problem can only arise for entities declared in
9817 -- a package body (otherwise the external name is fully qualified
9818 -- and will not conflict).
9826 if Prag_Id
= Pragma_Import
then
9827 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
9828 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9830 if Nam
/= Chars
(Subprogram_Def
)
9831 and then Present
(E
)
9832 and then not Is_Overloadable
(E
)
9833 and then Is_Immediately_Visible
(E
)
9834 and then not Is_Imported
(E
)
9835 and then Ekind
(Scope
(E
)) = E_Package
9838 while Present
(Par
) loop
9839 if Nkind
(Par
) = N_Package_Body
then
9840 Error_Msg_Sloc
:= Sloc
(E
);
9842 ("imported entity is hidden by & declared#",
9847 Par
:= Parent
(Par
);
9854 if Present
(Link_Nam
) then
9855 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9856 Check_Form_Of_Interface_Name
(Link_Nam
);
9859 -- If there is no link name, just set the external name
9861 if No
(Link_Nam
) then
9862 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9864 -- For the Link_Name case, the given literal is preceded by an
9865 -- asterisk, which indicates to GCC that the given name should be
9866 -- taken literally, and in particular that no prepending of
9867 -- underlines should occur, even in systems where this is the
9872 Store_String_Char
(Get_Char_Code
('*'));
9873 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9874 Store_String_Chars
(String_Val
);
9876 Make_String_Literal
(Sloc
(Link_Nam
),
9877 Strval
=> End_String
);
9880 -- Set the interface name. If the entity is a generic instance, use
9881 -- its alias, which is the callable entity.
9883 if Is_Generic_Instance
(Subprogram_Def
) then
9884 Set_Encoded_Interface_Name
9885 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9887 Set_Encoded_Interface_Name
9888 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9891 Check_Duplicated_Export_Name
(Link_Nam
);
9892 end Process_Interface_Name
;
9894 -----------------------------------------
9895 -- Process_Interrupt_Or_Attach_Handler --
9896 -----------------------------------------
9898 procedure Process_Interrupt_Or_Attach_Handler
is
9899 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9900 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9903 -- A pragma that applies to a Ghost entity becomes Ghost for the
9904 -- purposes of legality checks and removal of ignored Ghost code.
9906 Mark_Ghost_Pragma
(N
, Handler
);
9907 Set_Is_Interrupt_Handler
(Handler
);
9909 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
9911 Record_Rep_Item
(Prot_Typ
, N
);
9913 -- Chain the pragma on the contract for completeness
9915 Add_Contract_Item
(N
, Handler
);
9916 end Process_Interrupt_Or_Attach_Handler
;
9918 --------------------------------------------------
9919 -- Process_Restrictions_Or_Restriction_Warnings --
9920 --------------------------------------------------
9922 -- Note: some of the simple identifier cases were handled in par-prag,
9923 -- but it is harmless (and more straightforward) to simply handle all
9924 -- cases here, even if it means we repeat a bit of work in some cases.
9926 procedure Process_Restrictions_Or_Restriction_Warnings
9930 R_Id
: Restriction_Id
;
9936 -- Ignore all Restrictions pragmas in CodePeer mode
9938 if CodePeer_Mode
then
9942 Check_Ada_83_Warning
;
9943 Check_At_Least_N_Arguments
(1);
9944 Check_Valid_Configuration_Pragma
;
9947 while Present
(Arg
) loop
9949 Expr
:= Get_Pragma_Arg
(Arg
);
9951 -- Case of no restriction identifier present
9953 if Id
= No_Name
then
9954 if Nkind
(Expr
) /= N_Identifier
then
9956 ("invalid form for restriction", Arg
);
9961 (Process_Restriction_Synonyms
(Expr
));
9963 if R_Id
not in All_Boolean_Restrictions
then
9964 Error_Msg_Name_1
:= Pname
;
9966 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9968 -- Check for possible misspelling
9970 for J
in Restriction_Id
loop
9972 Rnm
: constant String := Restriction_Id
'Image (J
);
9975 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9976 Name_Len
:= Rnm
'Length;
9977 Set_Casing
(All_Lower_Case
);
9979 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9982 (Source_Index
(Current_Sem_Unit
)));
9983 Error_Msg_String
(1 .. Rnm
'Length) :=
9984 Name_Buffer
(1 .. Name_Len
);
9985 Error_Msg_Strlen
:= Rnm
'Length;
9986 Error_Msg_N
-- CODEFIX
9987 ("\possible misspelling of ""~""",
9988 Get_Pragma_Arg
(Arg
));
9997 if Implementation_Restriction
(R_Id
) then
9998 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10001 -- Special processing for No_Elaboration_Code restriction
10003 if R_Id
= No_Elaboration_Code
then
10005 -- Restriction is only recognized within a configuration
10006 -- pragma file, or within a unit of the main extended
10007 -- program. Note: the test for Main_Unit is needed to
10008 -- properly include the case of configuration pragma files.
10010 if not (Current_Sem_Unit
= Main_Unit
10011 or else In_Extended_Main_Source_Unit
(N
))
10015 -- Don't allow in a subunit unless already specified in
10018 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10019 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10020 and then not Restriction_Active
(No_Elaboration_Code
)
10023 ("invalid specification of ""No_Elaboration_Code""",
10026 ("\restriction cannot be specified in a subunit", N
);
10028 ("\unless also specified in body or spec", N
);
10031 -- If we accept a No_Elaboration_Code restriction, then it
10032 -- needs to be added to the configuration restriction set so
10033 -- that we get proper application to other units in the main
10034 -- extended source as required.
10037 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10041 -- If this is a warning, then set the warning unless we already
10042 -- have a real restriction active (we never want a warning to
10043 -- override a real restriction).
10046 if not Restriction_Active
(R_Id
) then
10047 Set_Restriction
(R_Id
, N
);
10048 Restriction_Warnings
(R_Id
) := True;
10051 -- If real restriction case, then set it and make sure that the
10052 -- restriction warning flag is off, since a real restriction
10053 -- always overrides a warning.
10056 Set_Restriction
(R_Id
, N
);
10057 Restriction_Warnings
(R_Id
) := False;
10060 -- Check for obsolescent restrictions in Ada 2005 mode
10063 and then Ada_Version
>= Ada_2005
10064 and then (R_Id
= No_Asynchronous_Control
10066 R_Id
= No_Unchecked_Deallocation
10068 R_Id
= No_Unchecked_Conversion
)
10070 Check_Restriction
(No_Obsolescent_Features
, N
);
10073 -- A very special case that must be processed here: pragma
10074 -- Restrictions (No_Exceptions) turns off all run-time
10075 -- checking. This is a bit dubious in terms of the formal
10076 -- language definition, but it is what is intended by RM
10077 -- H.4(12). Restriction_Warnings never affects generated code
10078 -- so this is done only in the real restriction case.
10080 -- Atomic_Synchronization is not a real check, so it is not
10081 -- affected by this processing).
10083 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10084 -- run-time checks in CodePeer and GNATprove modes: we want to
10085 -- generate checks for analysis purposes, as set respectively
10086 -- by -gnatC and -gnatd.F
10089 and then not (CodePeer_Mode
or GNATprove_Mode
)
10090 and then R_Id
= No_Exceptions
10092 for J
in Scope_Suppress
.Suppress
'Range loop
10093 if J
/= Atomic_Synchronization
then
10094 Scope_Suppress
.Suppress
(J
) := True;
10099 -- Case of No_Dependence => unit-name. Note that the parser
10100 -- already made the necessary entry in the No_Dependence table.
10102 elsif Id
= Name_No_Dependence
then
10103 if not OK_No_Dependence_Unit_Name
(Expr
) then
10107 -- Case of No_Specification_Of_Aspect => aspect-identifier
10109 elsif Id
= Name_No_Specification_Of_Aspect
then
10114 if Nkind
(Expr
) /= N_Identifier
then
10117 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10120 if A_Id
= No_Aspect
then
10121 Error_Pragma_Arg
("invalid restriction name", Arg
);
10123 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10127 -- Case of No_Use_Of_Attribute => attribute-identifier
10129 elsif Id
= Name_No_Use_Of_Attribute
then
10130 if Nkind
(Expr
) /= N_Identifier
10131 or else not Is_Attribute_Name
(Chars
(Expr
))
10133 Error_Msg_N
("unknown attribute name??", Expr
);
10136 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10139 -- Case of No_Use_Of_Entity => fully-qualified-name
10141 elsif Id
= Name_No_Use_Of_Entity
then
10143 -- Restriction is only recognized within a configuration
10144 -- pragma file, or within a unit of the main extended
10145 -- program. Note: the test for Main_Unit is needed to
10146 -- properly include the case of configuration pragma files.
10148 if Current_Sem_Unit
= Main_Unit
10149 or else In_Extended_Main_Source_Unit
(N
)
10151 if not OK_No_Dependence_Unit_Name
(Expr
) then
10152 Error_Msg_N
("wrong form for entity name", Expr
);
10154 Set_Restriction_No_Use_Of_Entity
10155 (Expr
, Warn
, No_Profile
);
10159 -- Case of No_Use_Of_Pragma => pragma-identifier
10161 elsif Id
= Name_No_Use_Of_Pragma
then
10162 if Nkind
(Expr
) /= N_Identifier
10163 or else not Is_Pragma_Name
(Chars
(Expr
))
10165 Error_Msg_N
("unknown pragma name??", Expr
);
10167 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10170 -- All other cases of restriction identifier present
10173 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10174 Analyze_And_Resolve
(Expr
, Any_Integer
);
10176 if R_Id
not in All_Parameter_Restrictions
then
10178 ("invalid restriction parameter identifier", Arg
);
10180 elsif not Is_OK_Static_Expression
(Expr
) then
10181 Flag_Non_Static_Expr
10182 ("value must be static expression!", Expr
);
10185 elsif not Is_Integer_Type
(Etype
(Expr
))
10186 or else Expr_Value
(Expr
) < 0
10189 ("value must be non-negative integer", Arg
);
10192 -- Restriction pragma is active
10194 Val
:= Expr_Value
(Expr
);
10196 if not UI_Is_In_Int_Range
(Val
) then
10198 ("pragma ignored, value too large??", Arg
);
10201 -- Warning case. If the real restriction is active, then we
10202 -- ignore the request, since warning never overrides a real
10203 -- restriction. Otherwise we set the proper warning. Note that
10204 -- this circuit sets the warning again if it is already set,
10205 -- which is what we want, since the constant may have changed.
10208 if not Restriction_Active
(R_Id
) then
10210 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10211 Restriction_Warnings
(R_Id
) := True;
10214 -- Real restriction case, set restriction and make sure warning
10215 -- flag is off since real restriction always overrides warning.
10218 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10219 Restriction_Warnings
(R_Id
) := False;
10225 end Process_Restrictions_Or_Restriction_Warnings
;
10227 ---------------------------------
10228 -- Process_Suppress_Unsuppress --
10229 ---------------------------------
10231 -- Note: this procedure makes entries in the check suppress data
10232 -- structures managed by Sem. See spec of package Sem for full
10233 -- details on how we handle recording of check suppression.
10235 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10240 In_Package_Spec
: constant Boolean :=
10241 Is_Package_Or_Generic_Package
(Current_Scope
)
10242 and then not In_Package_Body
(Current_Scope
);
10244 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10245 -- Used to suppress a single check on the given entity
10247 --------------------------------
10248 -- Suppress_Unsuppress_Echeck --
10249 --------------------------------
10251 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10253 -- Check for error of trying to set atomic synchronization for
10254 -- a non-atomic variable.
10256 if C
= Atomic_Synchronization
10257 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10260 ("pragma & requires atomic type or variable",
10261 Pragma_Identifier
(Original_Node
(N
)));
10264 Set_Checks_May_Be_Suppressed
(E
);
10266 if In_Package_Spec
then
10267 Push_Global_Suppress_Stack_Entry
10270 Suppress
=> Suppress_Case
);
10272 Push_Local_Suppress_Stack_Entry
10275 Suppress
=> Suppress_Case
);
10278 -- If this is a first subtype, and the base type is distinct,
10279 -- then also set the suppress flags on the base type.
10281 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10282 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10284 end Suppress_Unsuppress_Echeck
;
10286 -- Start of processing for Process_Suppress_Unsuppress
10289 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10290 -- on user code: we want to generate checks for analysis purposes, as
10291 -- set respectively by -gnatC and -gnatd.F
10293 if Comes_From_Source
(N
)
10294 and then (CodePeer_Mode
or GNATprove_Mode
)
10299 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10300 -- declarative part or a package spec (RM 11.5(5)).
10302 if not Is_Configuration_Pragma
then
10303 Check_Is_In_Decl_Part_Or_Package_Spec
;
10306 Check_At_Least_N_Arguments
(1);
10307 Check_At_Most_N_Arguments
(2);
10308 Check_No_Identifier
(Arg1
);
10309 Check_Arg_Is_Identifier
(Arg1
);
10311 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10313 if C
= No_Check_Id
then
10315 ("argument of pragma% is not valid check name", Arg1
);
10318 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10320 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10322 ("Suppress of Elaboration_Check ignored in SPARK??",
10323 "\elaboration checking rules are statically enforced "
10324 & "(SPARK RM 7.7)", Arg1
);
10327 -- One-argument case
10329 if Arg_Count
= 1 then
10331 -- Make an entry in the local scope suppress table. This is the
10332 -- table that directly shows the current value of the scope
10333 -- suppress check for any check id value.
10335 if C
= All_Checks
then
10337 -- For All_Checks, we set all specific predefined checks with
10338 -- the exception of Elaboration_Check, which is handled
10339 -- specially because of not wanting All_Checks to have the
10340 -- effect of deactivating static elaboration order processing.
10341 -- Atomic_Synchronization is also not affected, since this is
10342 -- not a real check.
10344 for J
in Scope_Suppress
.Suppress
'Range loop
10345 if J
/= Elaboration_Check
10347 J
/= Atomic_Synchronization
10349 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10353 -- If not All_Checks, and predefined check, then set appropriate
10354 -- scope entry. Note that we will set Elaboration_Check if this
10355 -- is explicitly specified. Atomic_Synchronization is allowed
10356 -- only if internally generated and entity is atomic.
10358 elsif C
in Predefined_Check_Id
10359 and then (not Comes_From_Source
(N
)
10360 or else C
/= Atomic_Synchronization
)
10362 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10365 -- Also make an entry in the Local_Entity_Suppress table
10367 Push_Local_Suppress_Stack_Entry
10370 Suppress
=> Suppress_Case
);
10372 -- Case of two arguments present, where the check is suppressed for
10373 -- a specified entity (given as the second argument of the pragma)
10376 -- This is obsolescent in Ada 2005 mode
10378 if Ada_Version
>= Ada_2005
then
10379 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10382 Check_Optional_Identifier
(Arg2
, Name_On
);
10383 E_Id
:= Get_Pragma_Arg
(Arg2
);
10386 if not Is_Entity_Name
(E_Id
) then
10388 ("second argument of pragma% must be entity name", Arg2
);
10391 E
:= Entity
(E_Id
);
10397 -- A pragma that applies to a Ghost entity becomes Ghost for the
10398 -- purposes of legality checks and removal of ignored Ghost code.
10400 Mark_Ghost_Pragma
(N
, E
);
10402 -- Enforce RM 11.5(7) which requires that for a pragma that
10403 -- appears within a package spec, the named entity must be
10404 -- within the package spec. We allow the package name itself
10405 -- to be mentioned since that makes sense, although it is not
10406 -- strictly allowed by 11.5(7).
10409 and then E
/= Current_Scope
10410 and then Scope
(E
) /= Current_Scope
10413 ("entity in pragma% is not in package spec (RM 11.5(7))",
10417 -- Loop through homonyms. As noted below, in the case of a package
10418 -- spec, only homonyms within the package spec are considered.
10421 Suppress_Unsuppress_Echeck
(E
, C
);
10423 if Is_Generic_Instance
(E
)
10424 and then Is_Subprogram
(E
)
10425 and then Present
(Alias
(E
))
10427 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10430 -- Move to next homonym if not aspect spec case
10432 exit when From_Aspect_Specification
(N
);
10436 -- If we are within a package specification, the pragma only
10437 -- applies to homonyms in the same scope.
10439 exit when In_Package_Spec
10440 and then Scope
(E
) /= Current_Scope
;
10443 end Process_Suppress_Unsuppress
;
10445 -------------------------------
10446 -- Record_Independence_Check --
10447 -------------------------------
10449 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10450 pragma Unreferenced
(N
, E
);
10452 -- For GCC back ends the validation is done a priori
10453 -- ??? This code is dead, might be useful in the future
10455 -- if not AAMP_On_Target then
10459 -- Independence_Checks.Append ((N, E));
10462 end Record_Independence_Check
;
10468 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10470 if Is_Imported
(E
) then
10472 ("cannot export entity& that was previously imported", Arg
);
10474 elsif Present
(Address_Clause
(E
))
10475 and then not Relaxed_RM_Semantics
10478 ("cannot export entity& that has an address clause", Arg
);
10481 Set_Is_Exported
(E
);
10483 -- Generate a reference for entity explicitly, because the
10484 -- identifier may be overloaded and name resolution will not
10487 Generate_Reference
(E
, Arg
);
10489 -- Deal with exporting non-library level entity
10491 if not Is_Library_Level_Entity
(E
) then
10493 -- Not allowed at all for subprograms
10495 if Is_Subprogram
(E
) then
10496 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10498 -- Otherwise set public and statically allocated
10502 Set_Is_Statically_Allocated
(E
);
10504 -- Warn if the corresponding W flag is set
10506 if Warn_On_Export_Import
10508 -- Only do this for something that was in the source. Not
10509 -- clear if this can be False now (there used for sure to be
10510 -- cases on some systems where it was False), but anyway the
10511 -- test is harmless if not needed, so it is retained.
10513 and then Comes_From_Source
(Arg
)
10516 ("?x?& has been made static as a result of Export",
10519 ("\?x?this usage is non-standard and non-portable",
10525 if Warn_On_Export_Import
and then Is_Type
(E
) then
10526 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10529 if Warn_On_Export_Import
and Inside_A_Generic
then
10531 ("all instances of& will have the same external name?x?",
10536 ----------------------------------------------
10537 -- Set_Extended_Import_Export_External_Name --
10538 ----------------------------------------------
10540 procedure Set_Extended_Import_Export_External_Name
10541 (Internal_Ent
: Entity_Id
;
10542 Arg_External
: Node_Id
)
10544 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10545 New_Name
: Node_Id
;
10548 if No
(Arg_External
) then
10552 Check_Arg_Is_External_Name
(Arg_External
);
10554 if Nkind
(Arg_External
) = N_String_Literal
then
10555 if String_Length
(Strval
(Arg_External
)) = 0 then
10558 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10561 elsif Nkind
(Arg_External
) = N_Identifier
then
10562 New_Name
:= Get_Default_External_Name
(Arg_External
);
10564 -- Check_Arg_Is_External_Name should let through only identifiers and
10565 -- string literals or static string expressions (which are folded to
10566 -- string literals).
10569 raise Program_Error
;
10572 -- If we already have an external name set (by a prior normal Import
10573 -- or Export pragma), then the external names must match
10575 if Present
(Interface_Name
(Internal_Ent
)) then
10577 -- Ignore mismatching names in CodePeer mode, to support some
10578 -- old compilers which would export the same procedure under
10579 -- different names, e.g:
10581 -- pragma Export_Procedure (P, "a");
10582 -- pragma Export_Procedure (P, "b");
10584 if CodePeer_Mode
then
10588 Check_Matching_Internal_Names
: declare
10589 S1
: constant String_Id
:= Strval
(Old_Name
);
10590 S2
: constant String_Id
:= Strval
(New_Name
);
10592 procedure Mismatch
;
10593 pragma No_Return
(Mismatch
);
10594 -- Called if names do not match
10600 procedure Mismatch
is
10602 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10604 ("external name does not match that given #",
10608 -- Start of processing for Check_Matching_Internal_Names
10611 if String_Length
(S1
) /= String_Length
(S2
) then
10615 for J
in 1 .. String_Length
(S1
) loop
10616 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10621 end Check_Matching_Internal_Names
;
10623 -- Otherwise set the given name
10626 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10627 Check_Duplicated_Export_Name
(New_Name
);
10629 end Set_Extended_Import_Export_External_Name
;
10635 procedure Set_Imported
(E
: Entity_Id
) is
10637 -- Error message if already imported or exported
10639 if Is_Exported
(E
) or else Is_Imported
(E
) then
10641 -- Error if being set Exported twice
10643 if Is_Exported
(E
) then
10644 Error_Msg_NE
("entity& was previously exported", N
, E
);
10646 -- Ignore error in CodePeer mode where we treat all imported
10647 -- subprograms as unknown.
10649 elsif CodePeer_Mode
then
10652 -- OK if Import/Interface case
10654 elsif Import_Interface_Present
(N
) then
10657 -- Error if being set Imported twice
10660 Error_Msg_NE
("entity& was previously imported", N
, E
);
10663 Error_Msg_Name_1
:= Pname
;
10665 ("\(pragma% applies to all previous entities)", N
);
10667 Error_Msg_Sloc
:= Sloc
(E
);
10668 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10670 -- Here if not previously imported or exported, OK to import
10673 Set_Is_Imported
(E
);
10675 -- For subprogram, set Import_Pragma field
10677 if Is_Subprogram
(E
) then
10678 Set_Import_Pragma
(E
, N
);
10681 -- If the entity is an object that is not at the library level,
10682 -- then it is statically allocated. We do not worry about objects
10683 -- with address clauses in this context since they are not really
10684 -- imported in the linker sense.
10687 and then not Is_Library_Level_Entity
(E
)
10688 and then No
(Address_Clause
(E
))
10690 Set_Is_Statically_Allocated
(E
);
10697 -------------------------
10698 -- Set_Mechanism_Value --
10699 -------------------------
10701 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10702 -- analyzed, since it is semantic nonsense), so we get it in the exact
10703 -- form created by the parser.
10705 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10706 procedure Bad_Mechanism
;
10707 pragma No_Return
(Bad_Mechanism
);
10708 -- Signal bad mechanism name
10710 -------------------------
10711 -- Bad_Mechanism_Value --
10712 -------------------------
10714 procedure Bad_Mechanism
is
10716 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10719 -- Start of processing for Set_Mechanism_Value
10722 if Mechanism
(Ent
) /= Default_Mechanism
then
10724 ("mechanism for & has already been set", Mech_Name
, Ent
);
10727 -- MECHANISM_NAME ::= value | reference
10729 if Nkind
(Mech_Name
) = N_Identifier
then
10730 if Chars
(Mech_Name
) = Name_Value
then
10731 Set_Mechanism
(Ent
, By_Copy
);
10734 elsif Chars
(Mech_Name
) = Name_Reference
then
10735 Set_Mechanism
(Ent
, By_Reference
);
10738 elsif Chars
(Mech_Name
) = Name_Copy
then
10740 ("bad mechanism name, Value assumed", Mech_Name
);
10749 end Set_Mechanism_Value
;
10751 --------------------------
10752 -- Set_Rational_Profile --
10753 --------------------------
10755 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10756 -- extension to the semantics of renaming declarations.
10758 procedure Set_Rational_Profile
is
10760 Implicit_Packing
:= True;
10761 Overriding_Renamings
:= True;
10762 Use_VADS_Size
:= True;
10763 end Set_Rational_Profile
;
10765 ---------------------------
10766 -- Set_Ravenscar_Profile --
10767 ---------------------------
10769 -- The tasks to be done here are
10771 -- Set required policies
10773 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10774 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10775 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10776 -- (For GNAT_Ravenscar_EDF profile)
10777 -- pragma Locking_Policy (Ceiling_Locking)
10779 -- Set Detect_Blocking mode
10781 -- Set required restrictions (see System.Rident for detailed list)
10783 -- Set the No_Dependence rules
10784 -- No_Dependence => Ada.Asynchronous_Task_Control
10785 -- No_Dependence => Ada.Calendar
10786 -- No_Dependence => Ada.Execution_Time.Group_Budget
10787 -- No_Dependence => Ada.Execution_Time.Timers
10788 -- No_Dependence => Ada.Task_Attributes
10789 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10791 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10792 procedure Set_Error_Msg_To_Profile_Name
;
10793 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10796 -----------------------------------
10797 -- Set_Error_Msg_To_Profile_Name --
10798 -----------------------------------
10800 procedure Set_Error_Msg_To_Profile_Name
is
10801 Prof_Nam
: constant Node_Id
:=
10803 (First
(Pragma_Argument_Associations
(N
)));
10806 Get_Name_String
(Chars
(Prof_Nam
));
10807 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10808 Error_Msg_Strlen
:= Name_Len
;
10809 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10810 end Set_Error_Msg_To_Profile_Name
;
10819 Profile_Dispatching_Policy
: Character;
10821 -- Start of processing for Set_Ravenscar_Profile
10824 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10826 if Profile
= GNAT_Ravenscar_EDF
then
10827 Profile_Dispatching_Policy
:= 'E';
10829 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10832 Profile_Dispatching_Policy
:= 'F';
10835 if Task_Dispatching_Policy
/= ' '
10836 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
10838 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10839 Set_Error_Msg_To_Profile_Name
;
10840 Error_Pragma
("Profile (~) incompatible with policy#");
10842 -- Set the FIFO_Within_Priorities policy, but always preserve
10843 -- System_Location since we like the error message with the run time
10847 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
10849 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10850 Task_Dispatching_Policy_Sloc
:= Loc
;
10854 -- pragma Locking_Policy (Ceiling_Locking)
10856 if Locking_Policy
/= ' '
10857 and then Locking_Policy
/= 'C'
10859 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10860 Set_Error_Msg_To_Profile_Name
;
10861 Error_Pragma
("Profile (~) incompatible with policy#");
10863 -- Set the Ceiling_Locking policy, but preserve System_Location since
10864 -- we like the error message with the run time name.
10867 Locking_Policy
:= 'C';
10869 if Locking_Policy_Sloc
/= System_Location
then
10870 Locking_Policy_Sloc
:= Loc
;
10874 -- pragma Detect_Blocking
10876 Detect_Blocking
:= True;
10878 -- Set the corresponding restrictions
10880 Set_Profile_Restrictions
10881 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10883 -- Set the No_Dependence restrictions
10885 -- The following No_Dependence restrictions:
10886 -- No_Dependence => Ada.Asynchronous_Task_Control
10887 -- No_Dependence => Ada.Calendar
10888 -- No_Dependence => Ada.Task_Attributes
10889 -- are already set by previous call to Set_Profile_Restrictions.
10891 -- Set the following restrictions which were added to Ada 2005:
10892 -- No_Dependence => Ada.Execution_Time.Group_Budget
10893 -- No_Dependence => Ada.Execution_Time.Timers
10895 if Ada_Version
>= Ada_2005
then
10896 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
10897 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
10900 Make_Selected_Component
10903 Selector_Name
=> Sel_Id
);
10905 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
10908 Make_Selected_Component
10911 Selector_Name
=> Sel_Id
);
10913 Set_Restriction_No_Dependence
10915 Warn
=> Treat_Restrictions_As_Warnings
,
10916 Profile
=> Ravenscar
);
10918 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
10921 Make_Selected_Component
10924 Selector_Name
=> Sel_Id
);
10926 Set_Restriction_No_Dependence
10928 Warn
=> Treat_Restrictions_As_Warnings
,
10929 Profile
=> Ravenscar
);
10932 -- Set the following restriction which was added to Ada 2012 (see
10934 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10936 if Ada_Version
>= Ada_2012
then
10937 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
10938 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
10941 Make_Selected_Component
10944 Selector_Name
=> Sel_Id
);
10946 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
10949 Make_Selected_Component
10952 Selector_Name
=> Sel_Id
);
10954 Set_Restriction_No_Dependence
10956 Warn
=> Treat_Restrictions_As_Warnings
,
10957 Profile
=> Ravenscar
);
10959 end Set_Ravenscar_Profile
;
10961 -- Start of processing for Analyze_Pragma
10964 -- The following code is a defense against recursion. Not clear that
10965 -- this can happen legitimately, but perhaps some error situations can
10966 -- cause it, and we did see this recursion during testing.
10968 if Analyzed
(N
) then
10974 Check_Restriction_No_Use_Of_Pragma
(N
);
10976 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10977 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10979 if Should_Ignore_Pragma_Sem
(N
)
10980 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
10981 and then Ignore_Rep_Clauses
)
10986 -- Deal with unrecognized pragma
10988 if not Is_Pragma_Name
(Pname
) then
10989 if Warn_On_Unrecognized_Pragma
then
10990 Error_Msg_Name_1
:= Pname
;
10991 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10993 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10994 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10995 Error_Msg_Name_1
:= PN
;
10996 Error_Msg_N
-- CODEFIX
10997 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11006 -- Here to start processing for recognized pragma
11008 Pname
:= Original_Aspect_Pragma_Name
(N
);
11010 -- Capture setting of Opt.Uneval_Old
11012 case Opt
.Uneval_Old
is
11014 Set_Uneval_Old_Accept
(N
);
11020 Set_Uneval_Old_Warn
(N
);
11023 raise Program_Error
;
11026 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11027 -- is already set, indicating that we have already checked the policy
11028 -- at the right point. This happens for example in the case of a pragma
11029 -- that is derived from an Aspect.
11031 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11034 -- For a pragma that is a rewriting of another pragma, copy the
11035 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11037 elsif Is_Rewrite_Substitution
(N
)
11038 and then Nkind
(Original_Node
(N
)) = N_Pragma
11039 and then Original_Node
(N
) /= N
11041 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11042 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11044 -- Otherwise query the applicable policy at this point
11047 Check_Applicable_Policy
(N
);
11049 -- If pragma is disabled, rewrite as NULL and skip analysis
11051 if Is_Disabled
(N
) then
11052 Rewrite
(N
, Make_Null_Statement
(Loc
));
11058 -- Preset arguments
11066 if Present
(Pragma_Argument_Associations
(N
)) then
11067 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11068 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11070 if Present
(Arg1
) then
11071 Arg2
:= Next
(Arg1
);
11073 if Present
(Arg2
) then
11074 Arg3
:= Next
(Arg2
);
11076 if Present
(Arg3
) then
11077 Arg4
:= Next
(Arg3
);
11083 -- An enumeration type defines the pragmas that are supported by the
11084 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11085 -- into the corresponding enumeration value for the following case.
11093 -- pragma Abort_Defer;
11095 when Pragma_Abort_Defer
=>
11097 Check_Arg_Count
(0);
11099 -- The only required semantic processing is to check the
11100 -- placement. This pragma must appear at the start of the
11101 -- statement sequence of a handled sequence of statements.
11103 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11104 or else N
/= First
(Statements
(Parent
(N
)))
11109 --------------------
11110 -- Abstract_State --
11111 --------------------
11113 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11115 -- ABSTRACT_STATE_LIST ::=
11117 -- | STATE_NAME_WITH_OPTIONS
11118 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11120 -- STATE_NAME_WITH_OPTIONS ::=
11122 -- | (STATE_NAME with OPTION_LIST)
11124 -- OPTION_LIST ::= OPTION {, OPTION}
11128 -- | NAME_VALUE_OPTION
11130 -- SIMPLE_OPTION ::= Ghost | Synchronous
11132 -- NAME_VALUE_OPTION ::=
11133 -- Part_Of => ABSTRACT_STATE
11134 -- | External [=> EXTERNAL_PROPERTY_LIST]
11136 -- EXTERNAL_PROPERTY_LIST ::=
11137 -- EXTERNAL_PROPERTY
11138 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11140 -- EXTERNAL_PROPERTY ::=
11141 -- Async_Readers [=> boolean_EXPRESSION]
11142 -- | Async_Writers [=> boolean_EXPRESSION]
11143 -- | Effective_Reads [=> boolean_EXPRESSION]
11144 -- | Effective_Writes [=> boolean_EXPRESSION]
11145 -- others => boolean_EXPRESSION
11147 -- STATE_NAME ::= defining_identifier
11149 -- ABSTRACT_STATE ::= name
11151 -- Characteristics:
11153 -- * Analysis - The annotation is fully analyzed immediately upon
11154 -- elaboration as it cannot forward reference entities.
11156 -- * Expansion - None.
11158 -- * Template - The annotation utilizes the generic template of the
11159 -- related package declaration.
11161 -- * Globals - The annotation cannot reference global entities.
11163 -- * Instance - The annotation is instantiated automatically when
11164 -- the related generic package is instantiated.
11166 when Pragma_Abstract_State
=> Abstract_State
: declare
11167 Missing_Parentheses
: Boolean := False;
11168 -- Flag set when a state declaration with options is not properly
11171 -- Flags used to verify the consistency of states
11173 Non_Null_Seen
: Boolean := False;
11174 Null_Seen
: Boolean := False;
11176 procedure Analyze_Abstract_State
11178 Pack_Id
: Entity_Id
);
11179 -- Verify the legality of a single state declaration. Create and
11180 -- decorate a state abstraction entity and introduce it into the
11181 -- visibility chain. Pack_Id denotes the entity or the related
11182 -- package where pragma Abstract_State appears.
11184 procedure Malformed_State_Error
(State
: Node_Id
);
11185 -- Emit an error concerning the illegal declaration of abstract
11186 -- state State. This routine diagnoses syntax errors that lead to
11187 -- a different parse tree. The error is issued regardless of the
11188 -- SPARK mode in effect.
11190 ----------------------------
11191 -- Analyze_Abstract_State --
11192 ----------------------------
11194 procedure Analyze_Abstract_State
11196 Pack_Id
: Entity_Id
)
11198 -- Flags used to verify the consistency of options
11200 AR_Seen
: Boolean := False;
11201 AW_Seen
: Boolean := False;
11202 ER_Seen
: Boolean := False;
11203 EW_Seen
: Boolean := False;
11204 External_Seen
: Boolean := False;
11205 Ghost_Seen
: Boolean := False;
11206 Others_Seen
: Boolean := False;
11207 Part_Of_Seen
: Boolean := False;
11208 Synchronous_Seen
: Boolean := False;
11210 -- Flags used to store the static value of all external states'
11213 AR_Val
: Boolean := False;
11214 AW_Val
: Boolean := False;
11215 ER_Val
: Boolean := False;
11216 EW_Val
: Boolean := False;
11218 State_Id
: Entity_Id
:= Empty
;
11219 -- The entity to be generated for the current state declaration
11221 procedure Analyze_External_Option
(Opt
: Node_Id
);
11222 -- Verify the legality of option External
11224 procedure Analyze_External_Property
11226 Expr
: Node_Id
:= Empty
);
11227 -- Verify the legailty of a single external property. Prop
11228 -- denotes the external property. Expr is the expression used
11229 -- to set the property.
11231 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11232 -- Verify the legality of option Part_Of
11234 procedure Check_Duplicate_Option
11236 Status
: in out Boolean);
11237 -- Flag Status denotes whether a particular option has been
11238 -- seen while processing a state. This routine verifies that
11239 -- Opt is not a duplicate option and sets the flag Status
11240 -- (SPARK RM 7.1.4(1)).
11242 procedure Check_Duplicate_Property
11244 Status
: in out Boolean);
11245 -- Flag Status denotes whether a particular property has been
11246 -- seen while processing option External. This routine verifies
11247 -- that Prop is not a duplicate property and sets flag Status.
11248 -- Opt is not a duplicate property and sets the flag Status.
11249 -- (SPARK RM 7.1.4(2))
11251 procedure Check_Ghost_Synchronous
;
11252 -- Ensure that the abstract state is not subject to both Ghost
11253 -- and Synchronous simple options. Emit an error if this is the
11256 procedure Create_Abstract_State
11260 Is_Null
: Boolean);
11261 -- Generate an abstract state entity with name Nam and enter it
11262 -- into visibility. Decl is the "declaration" of the state as
11263 -- it appears in pragma Abstract_State. Loc is the location of
11264 -- the related state "declaration". Flag Is_Null should be set
11265 -- when the associated Abstract_State pragma defines a null
11268 -----------------------------
11269 -- Analyze_External_Option --
11270 -----------------------------
11272 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11273 Errors
: constant Nat
:= Serious_Errors_Detected
;
11275 Props
: Node_Id
:= Empty
;
11278 if Nkind
(Opt
) = N_Component_Association
then
11279 Props
:= Expression
(Opt
);
11282 -- External state with properties
11284 if Present
(Props
) then
11286 -- Multiple properties appear as an aggregate
11288 if Nkind
(Props
) = N_Aggregate
then
11290 -- Simple property form
11292 Prop
:= First
(Expressions
(Props
));
11293 while Present
(Prop
) loop
11294 Analyze_External_Property
(Prop
);
11298 -- Property with expression form
11300 Prop
:= First
(Component_Associations
(Props
));
11301 while Present
(Prop
) loop
11302 Analyze_External_Property
11303 (Prop
=> First
(Choices
(Prop
)),
11304 Expr
=> Expression
(Prop
));
11312 Analyze_External_Property
(Props
);
11315 -- An external state defined without any properties defaults
11316 -- all properties to True.
11325 -- Once all external properties have been processed, verify
11326 -- their mutual interaction. Do not perform the check when
11327 -- at least one of the properties is illegal as this will
11328 -- produce a bogus error.
11330 if Errors
= Serious_Errors_Detected
then
11331 Check_External_Properties
11332 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11334 end Analyze_External_Option
;
11336 -------------------------------
11337 -- Analyze_External_Property --
11338 -------------------------------
11340 procedure Analyze_External_Property
11342 Expr
: Node_Id
:= Empty
)
11344 Expr_Val
: Boolean;
11347 -- Check the placement of "others" (if available)
11349 if Nkind
(Prop
) = N_Others_Choice
then
11350 if Others_Seen
then
11352 ("only one others choice allowed in option External",
11355 Others_Seen
:= True;
11358 elsif Others_Seen
then
11360 ("others must be the last property in option External",
11363 -- The only remaining legal options are the four predefined
11364 -- external properties.
11366 elsif Nkind
(Prop
) = N_Identifier
11367 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11368 Name_Async_Writers
,
11369 Name_Effective_Reads
,
11370 Name_Effective_Writes
)
11374 -- Otherwise the construct is not a valid property
11377 SPARK_Msg_N
("invalid external state property", Prop
);
11381 -- Ensure that the expression of the external state property
11382 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11384 if Present
(Expr
) then
11385 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11387 if Is_OK_Static_Expression
(Expr
) then
11388 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11391 ("expression of external state property must be "
11396 -- The lack of expression defaults the property to True
11402 -- Named properties
11404 if Nkind
(Prop
) = N_Identifier
then
11405 if Chars
(Prop
) = Name_Async_Readers
then
11406 Check_Duplicate_Property
(Prop
, AR_Seen
);
11407 AR_Val
:= Expr_Val
;
11409 elsif Chars
(Prop
) = Name_Async_Writers
then
11410 Check_Duplicate_Property
(Prop
, AW_Seen
);
11411 AW_Val
:= Expr_Val
;
11413 elsif Chars
(Prop
) = Name_Effective_Reads
then
11414 Check_Duplicate_Property
(Prop
, ER_Seen
);
11415 ER_Val
:= Expr_Val
;
11418 Check_Duplicate_Property
(Prop
, EW_Seen
);
11419 EW_Val
:= Expr_Val
;
11422 -- The handling of property "others" must take into account
11423 -- all other named properties that have been encountered so
11424 -- far. Only those that have not been seen are affected by
11428 if not AR_Seen
then
11429 AR_Val
:= Expr_Val
;
11432 if not AW_Seen
then
11433 AW_Val
:= Expr_Val
;
11436 if not ER_Seen
then
11437 ER_Val
:= Expr_Val
;
11440 if not EW_Seen
then
11441 EW_Val
:= Expr_Val
;
11444 end Analyze_External_Property
;
11446 ----------------------------
11447 -- Analyze_Part_Of_Option --
11448 ----------------------------
11450 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11451 Encap
: constant Node_Id
:= Expression
(Opt
);
11452 Constits
: Elist_Id
;
11453 Encap_Id
: Entity_Id
;
11457 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11460 (Indic
=> First
(Choices
(Opt
)),
11461 Item_Id
=> State_Id
,
11463 Encap_Id
=> Encap_Id
,
11466 -- The Part_Of indicator transforms the abstract state into
11467 -- a constituent of the encapsulating state or single
11468 -- concurrent type.
11471 pragma Assert
(Present
(Encap_Id
));
11472 Constits
:= Part_Of_Constituents
(Encap_Id
);
11474 if No
(Constits
) then
11475 Constits
:= New_Elmt_List
;
11476 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
11479 Append_Elmt
(State_Id
, Constits
);
11480 Set_Encapsulating_State
(State_Id
, Encap_Id
);
11482 end Analyze_Part_Of_Option
;
11484 ----------------------------
11485 -- Check_Duplicate_Option --
11486 ----------------------------
11488 procedure Check_Duplicate_Option
11490 Status
: in out Boolean)
11494 SPARK_Msg_N
("duplicate state option", Opt
);
11498 end Check_Duplicate_Option
;
11500 ------------------------------
11501 -- Check_Duplicate_Property --
11502 ------------------------------
11504 procedure Check_Duplicate_Property
11506 Status
: in out Boolean)
11510 SPARK_Msg_N
("duplicate external property", Prop
);
11514 end Check_Duplicate_Property
;
11516 -----------------------------
11517 -- Check_Ghost_Synchronous --
11518 -----------------------------
11520 procedure Check_Ghost_Synchronous
is
11522 -- A synchronized abstract state cannot be Ghost and vice
11523 -- versa (SPARK RM 6.9(19)).
11525 if Ghost_Seen
and Synchronous_Seen
then
11526 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
11528 end Check_Ghost_Synchronous
;
11530 ---------------------------
11531 -- Create_Abstract_State --
11532 ---------------------------
11534 procedure Create_Abstract_State
11541 -- The abstract state may be semi-declared when the related
11542 -- package was withed through a limited with clause. In that
11543 -- case reuse the entity to fully declare the state.
11545 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
11546 State_Id
:= Entity
(Decl
);
11548 -- Otherwise the elaboration of pragma Abstract_State
11549 -- declares the state.
11552 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
11554 if Present
(Decl
) then
11555 Set_Entity
(Decl
, State_Id
);
11559 -- Null states never come from source
11561 Set_Comes_From_Source
(State_Id
, not Is_Null
);
11562 Set_Parent
(State_Id
, State
);
11563 Set_Ekind
(State_Id
, E_Abstract_State
);
11564 Set_Etype
(State_Id
, Standard_Void_Type
);
11565 Set_Encapsulating_State
(State_Id
, Empty
);
11567 -- Set the SPARK mode from the current context
11569 Set_SPARK_Pragma
(State_Id
, SPARK_Mode_Pragma
);
11570 Set_SPARK_Pragma_Inherited
(State_Id
);
11572 -- An abstract state declared within a Ghost region becomes
11573 -- Ghost (SPARK RM 6.9(2)).
11575 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
11576 Set_Is_Ghost_Entity
(State_Id
);
11579 -- Establish a link between the state declaration and the
11580 -- abstract state entity. Note that a null state remains as
11581 -- N_Null and does not carry any linkages.
11583 if not Is_Null
then
11584 if Present
(Decl
) then
11585 Set_Entity
(Decl
, State_Id
);
11586 Set_Etype
(Decl
, Standard_Void_Type
);
11589 -- Every non-null state must be defined, nameable and
11592 Push_Scope
(Pack_Id
);
11593 Generate_Definition
(State_Id
);
11594 Enter_Name
(State_Id
);
11597 end Create_Abstract_State
;
11604 -- Start of processing for Analyze_Abstract_State
11607 -- A package with a null abstract state is not allowed to
11608 -- declare additional states.
11612 ("package & has null abstract state", State
, Pack_Id
);
11614 -- Null states appear as internally generated entities
11616 elsif Nkind
(State
) = N_Null
then
11617 Create_Abstract_State
11618 (Nam
=> New_Internal_Name
('S'),
11620 Loc
=> Sloc
(State
),
11624 -- Catch a case where a null state appears in a list of
11625 -- non-null states.
11627 if Non_Null_Seen
then
11629 ("package & has non-null abstract state",
11633 -- Simple state declaration
11635 elsif Nkind
(State
) = N_Identifier
then
11636 Create_Abstract_State
11637 (Nam
=> Chars
(State
),
11639 Loc
=> Sloc
(State
),
11641 Non_Null_Seen
:= True;
11643 -- State declaration with various options. This construct
11644 -- appears as an extension aggregate in the tree.
11646 elsif Nkind
(State
) = N_Extension_Aggregate
then
11647 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11648 Create_Abstract_State
11649 (Nam
=> Chars
(Ancestor_Part
(State
)),
11650 Decl
=> Ancestor_Part
(State
),
11651 Loc
=> Sloc
(Ancestor_Part
(State
)),
11653 Non_Null_Seen
:= True;
11656 ("state name must be an identifier",
11657 Ancestor_Part
(State
));
11660 -- Options External, Ghost and Synchronous appear as
11663 Opt
:= First
(Expressions
(State
));
11664 while Present
(Opt
) loop
11665 if Nkind
(Opt
) = N_Identifier
then
11669 if Chars
(Opt
) = Name_External
then
11670 Check_Duplicate_Option
(Opt
, External_Seen
);
11671 Analyze_External_Option
(Opt
);
11675 elsif Chars
(Opt
) = Name_Ghost
then
11676 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11677 Check_Ghost_Synchronous
;
11679 if Present
(State_Id
) then
11680 Set_Is_Ghost_Entity
(State_Id
);
11685 elsif Chars
(Opt
) = Name_Synchronous
then
11686 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11687 Check_Ghost_Synchronous
;
11689 -- Option Part_Of without an encapsulating state is
11690 -- illegal (SPARK RM 7.1.4(9)).
11692 elsif Chars
(Opt
) = Name_Part_Of
then
11694 ("indicator Part_Of must denote abstract state, "
11695 & "single protected type or single task type",
11698 -- Do not emit an error message when a previous state
11699 -- declaration with options was not parenthesized as
11700 -- the option is actually another state declaration.
11702 -- with Abstract_State
11703 -- (State_1 with ..., -- missing parentheses
11704 -- (State_2 with ...),
11705 -- State_3) -- ok state declaration
11707 elsif Missing_Parentheses
then
11710 -- Otherwise the option is not allowed. Note that it
11711 -- is not possible to distinguish between an option
11712 -- and a state declaration when a previous state with
11713 -- options not properly parentheses.
11715 -- with Abstract_State
11716 -- (State_1 with ..., -- missing parentheses
11717 -- State_2); -- could be an option
11721 ("simple option not allowed in state declaration",
11725 -- Catch a case where missing parentheses around a state
11726 -- declaration with options cause a subsequent state
11727 -- declaration with options to be treated as an option.
11729 -- with Abstract_State
11730 -- (State_1 with ..., -- missing parentheses
11731 -- (State_2 with ...))
11733 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11734 Missing_Parentheses
:= True;
11736 ("state declaration must be parenthesized",
11737 Ancestor_Part
(State
));
11739 -- Otherwise the option is malformed
11742 SPARK_Msg_N
("malformed option", Opt
);
11748 -- Options External and Part_Of appear as component
11751 Opt
:= First
(Component_Associations
(State
));
11752 while Present
(Opt
) loop
11753 Opt_Nam
:= First
(Choices
(Opt
));
11755 if Nkind
(Opt_Nam
) = N_Identifier
then
11756 if Chars
(Opt_Nam
) = Name_External
then
11757 Analyze_External_Option
(Opt
);
11759 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11760 Analyze_Part_Of_Option
(Opt
);
11763 SPARK_Msg_N
("invalid state option", Opt
);
11766 SPARK_Msg_N
("invalid state option", Opt
);
11772 -- Any other attempt to declare a state is illegal
11775 Malformed_State_Error
(State
);
11779 -- Guard against a junk state. In such cases no entity is
11780 -- generated and the subsequent checks cannot be applied.
11782 if Present
(State_Id
) then
11784 -- Verify whether the state does not introduce an illegal
11785 -- hidden state within a package subject to a null abstract
11788 Check_No_Hidden_State
(State_Id
);
11790 -- Check whether the lack of option Part_Of agrees with the
11791 -- placement of the abstract state with respect to the state
11794 if not Part_Of_Seen
then
11795 Check_Missing_Part_Of
(State_Id
);
11798 -- Associate the state with its related package
11800 if No
(Abstract_States
(Pack_Id
)) then
11801 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11804 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11806 end Analyze_Abstract_State
;
11808 ---------------------------
11809 -- Malformed_State_Error --
11810 ---------------------------
11812 procedure Malformed_State_Error
(State
: Node_Id
) is
11814 Error_Msg_N
("malformed abstract state declaration", State
);
11816 -- An abstract state with a simple option is being declared
11817 -- with "=>" rather than the legal "with". The state appears
11818 -- as a component association.
11820 if Nkind
(State
) = N_Component_Association
then
11821 Error_Msg_N
("\use WITH to specify simple option", State
);
11823 end Malformed_State_Error
;
11827 Pack_Decl
: Node_Id
;
11828 Pack_Id
: Entity_Id
;
11832 -- Start of processing for Abstract_State
11836 Check_No_Identifiers
;
11837 Check_Arg_Count
(1);
11839 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11841 -- Ensure the proper placement of the pragma. Abstract states must
11842 -- be associated with a package declaration.
11844 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11845 N_Package_Declaration
)
11849 -- Otherwise the pragma is associated with an illegal construct
11856 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11858 -- A pragma that applies to a Ghost entity becomes Ghost for the
11859 -- purposes of legality checks and removal of ignored Ghost code.
11861 Mark_Ghost_Pragma
(N
, Pack_Id
);
11862 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11864 -- Chain the pragma on the contract for completeness
11866 Add_Contract_Item
(N
, Pack_Id
);
11868 -- The legality checks of pragmas Abstract_State, Initializes, and
11869 -- Initial_Condition are affected by the SPARK mode in effect. In
11870 -- addition, these three pragmas are subject to an inherent order:
11872 -- 1) Abstract_State
11874 -- 3) Initial_Condition
11876 -- Analyze all these pragmas in the order outlined above
11878 Analyze_If_Present
(Pragma_SPARK_Mode
);
11879 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11881 -- Multiple non-null abstract states appear as an aggregate
11883 if Nkind
(States
) = N_Aggregate
then
11884 State
:= First
(Expressions
(States
));
11885 while Present
(State
) loop
11886 Analyze_Abstract_State
(State
, Pack_Id
);
11890 -- An abstract state with a simple option is being illegaly
11891 -- declared with "=>" rather than "with". In this case the
11892 -- state declaration appears as a component association.
11894 if Present
(Component_Associations
(States
)) then
11895 State
:= First
(Component_Associations
(States
));
11896 while Present
(State
) loop
11897 Malformed_State_Error
(State
);
11902 -- Various forms of a single abstract state. Note that these may
11903 -- include malformed state declarations.
11906 Analyze_Abstract_State
(States
, Pack_Id
);
11909 Analyze_If_Present
(Pragma_Initializes
);
11910 Analyze_If_Present
(Pragma_Initial_Condition
);
11911 end Abstract_State
;
11919 -- Note: this pragma also has some specific processing in Par.Prag
11920 -- because we want to set the Ada version mode during parsing.
11922 when Pragma_Ada_83
=>
11924 Check_Arg_Count
(0);
11926 -- We really should check unconditionally for proper configuration
11927 -- pragma placement, since we really don't want mixed Ada modes
11928 -- within a single unit, and the GNAT reference manual has always
11929 -- said this was a configuration pragma, but we did not check and
11930 -- are hesitant to add the check now.
11932 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11933 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11934 -- or Ada 2012 mode.
11936 if Ada_Version
>= Ada_2005
then
11937 Check_Valid_Configuration_Pragma
;
11940 -- Now set Ada 83 mode
11942 if Latest_Ada_Only
then
11943 Error_Pragma
("??pragma% ignored");
11945 Ada_Version
:= Ada_83
;
11946 Ada_Version_Explicit
:= Ada_83
;
11947 Ada_Version_Pragma
:= N
;
11956 -- Note: this pragma also has some specific processing in Par.Prag
11957 -- because we want to set the Ada 83 version mode during parsing.
11959 when Pragma_Ada_95
=>
11961 Check_Arg_Count
(0);
11963 -- We really should check unconditionally for proper configuration
11964 -- pragma placement, since we really don't want mixed Ada modes
11965 -- within a single unit, and the GNAT reference manual has always
11966 -- said this was a configuration pragma, but we did not check and
11967 -- are hesitant to add the check now.
11969 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11970 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11972 if Ada_Version
>= Ada_2005
then
11973 Check_Valid_Configuration_Pragma
;
11976 -- Now set Ada 95 mode
11978 if Latest_Ada_Only
then
11979 Error_Pragma
("??pragma% ignored");
11981 Ada_Version
:= Ada_95
;
11982 Ada_Version_Explicit
:= Ada_95
;
11983 Ada_Version_Pragma
:= N
;
11986 ---------------------
11987 -- Ada_05/Ada_2005 --
11988 ---------------------
11991 -- pragma Ada_05 (LOCAL_NAME);
11993 -- pragma Ada_2005;
11994 -- pragma Ada_2005 (LOCAL_NAME):
11996 -- Note: these pragmas also have some specific processing in Par.Prag
11997 -- because we want to set the Ada 2005 version mode during parsing.
11999 -- The one argument form is used for managing the transition from
12000 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
12001 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
12002 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
12003 -- mode, a preference rule is established which does not choose
12004 -- such an entity unless it is unambiguously specified. This avoids
12005 -- extra subprograms marked this way from generating ambiguities in
12006 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12007 -- intended for exclusive use in the GNAT run-time library.
12018 if Arg_Count
= 1 then
12019 Check_Arg_Is_Local_Name
(Arg1
);
12020 E_Id
:= Get_Pragma_Arg
(Arg1
);
12022 if Etype
(E_Id
) = Any_Type
then
12026 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12027 Record_Rep_Item
(Entity
(E_Id
), N
);
12030 Check_Arg_Count
(0);
12032 -- For Ada_2005 we unconditionally enforce the documented
12033 -- configuration pragma placement, since we do not want to
12034 -- tolerate mixed modes in a unit involving Ada 2005. That
12035 -- would cause real difficulties for those cases where there
12036 -- are incompatibilities between Ada 95 and Ada 2005.
12038 Check_Valid_Configuration_Pragma
;
12040 -- Now set appropriate Ada mode
12042 if Latest_Ada_Only
then
12043 Error_Pragma
("??pragma% ignored");
12045 Ada_Version
:= Ada_2005
;
12046 Ada_Version_Explicit
:= Ada_2005
;
12047 Ada_Version_Pragma
:= N
;
12052 ---------------------
12053 -- Ada_12/Ada_2012 --
12054 ---------------------
12057 -- pragma Ada_12 (LOCAL_NAME);
12059 -- pragma Ada_2012;
12060 -- pragma Ada_2012 (LOCAL_NAME):
12062 -- Note: these pragmas also have some specific processing in Par.Prag
12063 -- because we want to set the Ada 2012 version mode during parsing.
12065 -- The one argument form is used for managing the transition from Ada
12066 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12067 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12068 -- mode will generate a warning. In addition, in any pre-Ada_2012
12069 -- mode, a preference rule is established which does not choose
12070 -- such an entity unless it is unambiguously specified. This avoids
12071 -- extra subprograms marked this way from generating ambiguities in
12072 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12073 -- intended for exclusive use in the GNAT run-time library.
12084 if Arg_Count
= 1 then
12085 Check_Arg_Is_Local_Name
(Arg1
);
12086 E_Id
:= Get_Pragma_Arg
(Arg1
);
12088 if Etype
(E_Id
) = Any_Type
then
12092 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12093 Record_Rep_Item
(Entity
(E_Id
), N
);
12096 Check_Arg_Count
(0);
12098 -- For Ada_2012 we unconditionally enforce the documented
12099 -- configuration pragma placement, since we do not want to
12100 -- tolerate mixed modes in a unit involving Ada 2012. That
12101 -- would cause real difficulties for those cases where there
12102 -- are incompatibilities between Ada 95 and Ada 2012. We could
12103 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12105 Check_Valid_Configuration_Pragma
;
12107 -- Now set appropriate Ada mode
12109 Ada_Version
:= Ada_2012
;
12110 Ada_Version_Explicit
:= Ada_2012
;
12111 Ada_Version_Pragma
:= N
;
12119 -- pragma Ada_2020;
12121 -- Note: this pragma also has some specific processing in Par.Prag
12122 -- because we want to set the Ada 2020 version mode during parsing.
12124 when Pragma_Ada_2020
=>
12127 Check_Arg_Count
(0);
12129 Check_Valid_Configuration_Pragma
;
12131 -- Now set appropriate Ada mode
12133 Ada_Version
:= Ada_2020
;
12134 Ada_Version_Explicit
:= Ada_2020
;
12135 Ada_Version_Pragma
:= N
;
12137 ----------------------
12138 -- All_Calls_Remote --
12139 ----------------------
12141 -- pragma All_Calls_Remote [(library_package_NAME)];
12143 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12144 Lib_Entity
: Entity_Id
;
12147 Check_Ada_83_Warning
;
12148 Check_Valid_Library_Unit_Pragma
;
12150 if Nkind
(N
) = N_Null_Statement
then
12154 Lib_Entity
:= Find_Lib_Unit_Name
;
12156 -- A pragma that applies to a Ghost entity becomes Ghost for the
12157 -- purposes of legality checks and removal of ignored Ghost code.
12159 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12161 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12163 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12164 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12165 Error_Pragma
("pragma% only apply to rci unit");
12167 -- Set flag for entity of the library unit
12170 Set_Has_All_Calls_Remote
(Lib_Entity
);
12173 end All_Calls_Remote
;
12175 ---------------------------
12176 -- Allow_Integer_Address --
12177 ---------------------------
12179 -- pragma Allow_Integer_Address;
12181 when Pragma_Allow_Integer_Address
=>
12183 Check_Valid_Configuration_Pragma
;
12184 Check_Arg_Count
(0);
12186 -- If Address is a private type, then set the flag to allow
12187 -- integer address values. If Address is not private, then this
12188 -- pragma has no purpose, so it is simply ignored. Not clear if
12189 -- there are any such targets now.
12191 if Opt
.Address_Is_Private
then
12192 Opt
.Allow_Integer_Address
:= True;
12200 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12201 -- ARG ::= NAME | EXPRESSION
12203 -- The first two arguments are by convention intended to refer to an
12204 -- external tool and a tool-specific function. These arguments are
12207 when Pragma_Annotate
=> Annotate
: declare
12214 Check_At_Least_N_Arguments
(1);
12216 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
12218 -- Determine whether the last argument is "Entity => local_NAME"
12219 -- and if it is, perform the required semantic checks. Remove the
12220 -- argument from further processing.
12222 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
12223 and then Chars
(Nam_Arg
) = Name_Entity
12225 Check_Arg_Is_Local_Name
(Nam_Arg
);
12226 Arg_Count
:= Arg_Count
- 1;
12228 -- A pragma that applies to a Ghost entity becomes Ghost for
12229 -- the purposes of legality checks and removal of ignored Ghost
12232 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12233 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12235 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12238 -- Not allowed in compiler units (bootstrap issues)
12240 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
12243 -- Continue the processing with last argument removed for now
12245 Check_Arg_Is_Identifier
(Arg1
);
12246 Check_No_Identifiers
;
12249 -- The second parameter is optional, it is never analyzed
12254 -- Otherwise there is a second parameter
12257 -- The second parameter must be an identifier
12259 Check_Arg_Is_Identifier
(Arg2
);
12261 -- Process the remaining parameters (if any)
12263 Arg
:= Next
(Arg2
);
12264 while Present
(Arg
) loop
12265 Expr
:= Get_Pragma_Arg
(Arg
);
12268 if Is_Entity_Name
(Expr
) then
12271 -- For string literals, we assume Standard_String as the
12272 -- type, unless the string contains wide or wide_wide
12275 elsif Nkind
(Expr
) = N_String_Literal
then
12276 if Has_Wide_Wide_Character
(Expr
) then
12277 Resolve
(Expr
, Standard_Wide_Wide_String
);
12278 elsif Has_Wide_Character
(Expr
) then
12279 Resolve
(Expr
, Standard_Wide_String
);
12281 Resolve
(Expr
, Standard_String
);
12284 elsif Is_Overloaded
(Expr
) then
12285 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
12296 -------------------------------------------------
12297 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12298 -------------------------------------------------
12301 -- ( [Check => ] Boolean_EXPRESSION
12302 -- [, [Message =>] Static_String_EXPRESSION]);
12304 -- pragma Assert_And_Cut
12305 -- ( [Check => ] Boolean_EXPRESSION
12306 -- [, [Message =>] Static_String_EXPRESSION]);
12309 -- ( [Check => ] Boolean_EXPRESSION
12310 -- [, [Message =>] Static_String_EXPRESSION]);
12312 -- pragma Loop_Invariant
12313 -- ( [Check => ] Boolean_EXPRESSION
12314 -- [, [Message =>] Static_String_EXPRESSION]);
12317 | Pragma_Assert_And_Cut
12319 | Pragma_Loop_Invariant
12322 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
12323 -- Determine whether expression Expr contains a Loop_Entry
12324 -- attribute reference.
12326 -------------------------
12327 -- Contains_Loop_Entry --
12328 -------------------------
12330 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
12331 Has_Loop_Entry
: Boolean := False;
12333 function Process
(N
: Node_Id
) return Traverse_Result
;
12334 -- Process function for traversal to look for Loop_Entry
12340 function Process
(N
: Node_Id
) return Traverse_Result
is
12342 if Nkind
(N
) = N_Attribute_Reference
12343 and then Attribute_Name
(N
) = Name_Loop_Entry
12345 Has_Loop_Entry
:= True;
12352 procedure Traverse
is new Traverse_Proc
(Process
);
12354 -- Start of processing for Contains_Loop_Entry
12358 return Has_Loop_Entry
;
12359 end Contains_Loop_Entry
;
12364 New_Args
: List_Id
;
12366 -- Start of processing for Assert
12369 -- Assert is an Ada 2005 RM-defined pragma
12371 if Prag_Id
= Pragma_Assert
then
12374 -- The remaining ones are GNAT pragmas
12380 Check_At_Least_N_Arguments
(1);
12381 Check_At_Most_N_Arguments
(2);
12382 Check_Arg_Order
((Name_Check
, Name_Message
));
12383 Check_Optional_Identifier
(Arg1
, Name_Check
);
12384 Expr
:= Get_Pragma_Arg
(Arg1
);
12386 -- Special processing for Loop_Invariant, Loop_Variant or for
12387 -- other cases where a Loop_Entry attribute is present. If the
12388 -- assertion pragma contains attribute Loop_Entry, ensure that
12389 -- the related pragma is within a loop.
12391 if Prag_Id
= Pragma_Loop_Invariant
12392 or else Prag_Id
= Pragma_Loop_Variant
12393 or else Contains_Loop_Entry
(Expr
)
12395 Check_Loop_Pragma_Placement
;
12397 -- Perform preanalysis to deal with embedded Loop_Entry
12400 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
12403 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12404 -- a corresponding Check pragma:
12406 -- pragma Check (name, condition [, msg]);
12408 -- Where name is the identifier matching the pragma name. So
12409 -- rewrite pragma in this manner, transfer the message argument
12410 -- if present, and analyze the result
12412 -- Note: When dealing with a semantically analyzed tree, the
12413 -- information that a Check node N corresponds to a source Assert,
12414 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12415 -- pragma kind of Original_Node(N).
12417 New_Args
:= New_List
(
12418 Make_Pragma_Argument_Association
(Loc
,
12419 Expression
=> Make_Identifier
(Loc
, Pname
)),
12420 Make_Pragma_Argument_Association
(Sloc
(Expr
),
12421 Expression
=> Expr
));
12423 if Arg_Count
> 1 then
12424 Check_Optional_Identifier
(Arg2
, Name_Message
);
12426 -- Provide semantic annnotations for optional argument, for
12427 -- ASIS use, before rewriting.
12429 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
12430 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
12433 -- Rewrite as Check pragma
12437 Chars
=> Name_Check
,
12438 Pragma_Argument_Associations
=> New_Args
));
12443 ----------------------
12444 -- Assertion_Policy --
12445 ----------------------
12447 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12449 -- The following form is Ada 2012 only, but we allow it in all modes
12451 -- Pragma Assertion_Policy (
12452 -- ASSERTION_KIND => POLICY_IDENTIFIER
12453 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12455 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12457 -- RM_ASSERTION_KIND ::= Assert |
12458 -- Static_Predicate |
12459 -- Dynamic_Predicate |
12464 -- Type_Invariant |
12465 -- Type_Invariant'Class
12467 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12469 -- Contract_Cases |
12471 -- Default_Initial_Condition |
12473 -- Initial_Condition |
12474 -- Loop_Invariant |
12480 -- Statement_Assertions
12482 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12483 -- ID_ASSERTION_KIND list contains implementation-defined additions
12484 -- recognized by GNAT. The effect is to control the behavior of
12485 -- identically named aspects and pragmas, depending on the specified
12486 -- policy identifier:
12488 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12490 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12491 -- implementation-defined addition that results in totally ignoring
12492 -- the corresponding assertion. If Disable is specified, then the
12493 -- argument of the assertion is not even analyzed. This is useful
12494 -- when the aspect/pragma argument references entities in a with'ed
12495 -- package that is replaced by a dummy package in the final build.
12497 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12498 -- and Type_Invariant'Class were recognized by the parser and
12499 -- transformed into references to the special internal identifiers
12500 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12501 -- processing is required here.
12503 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
12504 procedure Resolve_Suppressible
(Policy
: Node_Id
);
12505 -- Converts the assertion policy 'Suppressible' to either Check or
12506 -- Ignore based on whether checks are suppressed via -gnatp.
12508 --------------------------
12509 -- Resolve_Suppressible --
12510 --------------------------
12512 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
12513 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
12517 -- Transform policy argument Suppressible into either Ignore or
12518 -- Check depending on whether checks are enabled or suppressed.
12520 if Chars
(Arg
) = Name_Suppressible
then
12521 if Suppress_Checks
then
12522 Nam
:= Name_Ignore
;
12527 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
12529 end Resolve_Suppressible
;
12541 -- This can always appear as a configuration pragma
12543 if Is_Configuration_Pragma
then
12546 -- It can also appear in a declarative part or package spec in Ada
12547 -- 2012 mode. We allow this in other modes, but in that case we
12548 -- consider that we have an Ada 2012 pragma on our hands.
12551 Check_Is_In_Decl_Part_Or_Package_Spec
;
12555 -- One argument case with no identifier (first form above)
12558 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
12559 or else Chars
(Arg1
) = No_Name
)
12561 Check_Arg_Is_One_Of
(Arg1
,
12562 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12564 Resolve_Suppressible
(Arg1
);
12566 -- Treat one argument Assertion_Policy as equivalent to:
12568 -- pragma Check_Policy (Assertion, policy)
12570 -- So rewrite pragma in that manner and link on to the chain
12571 -- of Check_Policy pragmas, marking the pragma as analyzed.
12573 Policy
:= Get_Pragma_Arg
(Arg1
);
12577 Chars
=> Name_Check_Policy
,
12578 Pragma_Argument_Associations
=> New_List
(
12579 Make_Pragma_Argument_Association
(Loc
,
12580 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
12582 Make_Pragma_Argument_Association
(Loc
,
12584 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
12587 -- Here if we have two or more arguments
12590 Check_At_Least_N_Arguments
(1);
12593 -- Loop through arguments
12596 while Present
(Arg
) loop
12597 LocP
:= Sloc
(Arg
);
12599 -- Kind must be specified
12601 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12602 or else Chars
(Arg
) = No_Name
12605 ("missing assertion kind for pragma%", Arg
);
12608 -- Check Kind and Policy have allowed forms
12610 Kind
:= Chars
(Arg
);
12611 Policy
:= Get_Pragma_Arg
(Arg
);
12613 if not Is_Valid_Assertion_Kind
(Kind
) then
12615 ("invalid assertion kind for pragma%", Arg
);
12618 Check_Arg_Is_One_Of
(Arg
,
12619 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12621 Resolve_Suppressible
(Arg
);
12623 if Kind
= Name_Ghost
then
12625 -- The Ghost policy must be either Check or Ignore
12626 -- (SPARK RM 6.9(6)).
12628 if not Nam_In
(Chars
(Policy
), Name_Check
,
12632 ("argument of pragma % Ghost must be Check or "
12633 & "Ignore", Policy
);
12636 -- Pragma Assertion_Policy specifying a Ghost policy
12637 -- cannot occur within a Ghost subprogram or package
12638 -- (SPARK RM 6.9(14)).
12640 if Ghost_Mode
> None
then
12642 ("pragma % cannot appear within ghost subprogram or "
12647 -- Rewrite the Assertion_Policy pragma as a series of
12648 -- Check_Policy pragmas of the form:
12650 -- Check_Policy (Kind, Policy);
12652 -- Note: the insertion of the pragmas cannot be done with
12653 -- Insert_Action because in the configuration case, there
12654 -- are no scopes on the scope stack and the mechanism will
12657 Insert_Before_And_Analyze
(N
,
12659 Chars
=> Name_Check_Policy
,
12660 Pragma_Argument_Associations
=> New_List
(
12661 Make_Pragma_Argument_Association
(LocP
,
12662 Expression
=> Make_Identifier
(LocP
, Kind
)),
12663 Make_Pragma_Argument_Association
(LocP
,
12664 Expression
=> Policy
))));
12669 -- Rewrite the Assertion_Policy pragma as null since we have
12670 -- now inserted all the equivalent Check pragmas.
12672 Rewrite
(N
, Make_Null_Statement
(Loc
));
12675 end Assertion_Policy
;
12677 ------------------------------
12678 -- Assume_No_Invalid_Values --
12679 ------------------------------
12681 -- pragma Assume_No_Invalid_Values (On | Off);
12683 when Pragma_Assume_No_Invalid_Values
=>
12685 Check_Valid_Configuration_Pragma
;
12686 Check_Arg_Count
(1);
12687 Check_No_Identifiers
;
12688 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12690 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12691 Assume_No_Invalid_Values
:= True;
12693 Assume_No_Invalid_Values
:= False;
12696 --------------------------
12697 -- Attribute_Definition --
12698 --------------------------
12700 -- pragma Attribute_Definition
12701 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12702 -- [Entity =>] LOCAL_NAME,
12703 -- [Expression =>] EXPRESSION | NAME);
12705 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12706 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12711 Check_Arg_Count
(3);
12712 Check_Optional_Identifier
(Arg1
, "attribute");
12713 Check_Optional_Identifier
(Arg2
, "entity");
12714 Check_Optional_Identifier
(Arg3
, "expression");
12716 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12717 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12721 Check_Arg_Is_Local_Name
(Arg2
);
12723 -- If the attribute is not recognized, then issue a warning (not
12724 -- an error), and ignore the pragma.
12726 Aname
:= Chars
(Attribute_Designator
);
12728 if not Is_Attribute_Name
(Aname
) then
12729 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12733 -- Otherwise, rewrite the pragma as an attribute definition clause
12736 Make_Attribute_Definition_Clause
(Loc
,
12737 Name
=> Get_Pragma_Arg
(Arg2
),
12739 Expression
=> Get_Pragma_Arg
(Arg3
)));
12741 end Attribute_Definition
;
12743 ------------------------------------------------------------------
12744 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12745 ------------------------------------------------------------------
12747 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12748 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12749 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12750 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12752 when Pragma_Async_Readers
12753 | Pragma_Async_Writers
12754 | Pragma_Effective_Reads
12755 | Pragma_Effective_Writes
12757 Async_Effective
: declare
12758 Obj_Decl
: Node_Id
;
12759 Obj_Id
: Entity_Id
;
12763 Check_No_Identifiers
;
12764 Check_At_Most_N_Arguments
(1);
12766 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12768 -- Object declaration
12770 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12773 -- Otherwise the pragma is associated with an illegal construact
12780 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12782 -- Perform minimal verification to ensure that the argument is at
12783 -- least a variable. Subsequent finer grained checks will be done
12784 -- at the end of the declarative region the contains the pragma.
12786 if Ekind
(Obj_Id
) = E_Variable
then
12788 -- A pragma that applies to a Ghost entity becomes Ghost for
12789 -- the purposes of legality checks and removal of ignored Ghost
12792 Mark_Ghost_Pragma
(N
, Obj_Id
);
12794 -- Chain the pragma on the contract for further processing by
12795 -- Analyze_External_Property_In_Decl_Part.
12797 Add_Contract_Item
(N
, Obj_Id
);
12799 -- Analyze the Boolean expression (if any)
12801 if Present
(Arg1
) then
12802 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12805 -- Otherwise the external property applies to a constant
12808 Error_Pragma
("pragma % must apply to a volatile object");
12810 end Async_Effective
;
12816 -- pragma Asynchronous (LOCAL_NAME);
12818 when Pragma_Asynchronous
=> Asynchronous
: declare
12821 Formal
: Entity_Id
;
12826 procedure Process_Async_Pragma
;
12827 -- Common processing for procedure and access-to-procedure case
12829 --------------------------
12830 -- Process_Async_Pragma --
12831 --------------------------
12833 procedure Process_Async_Pragma
is
12836 Set_Is_Asynchronous
(Nm
);
12840 -- The formals should be of mode IN (RM E.4.1(6))
12843 while Present
(S
) loop
12844 Formal
:= Defining_Identifier
(S
);
12846 if Nkind
(Formal
) = N_Defining_Identifier
12847 and then Ekind
(Formal
) /= E_In_Parameter
12850 ("pragma% procedure can only have IN parameter",
12857 Set_Is_Asynchronous
(Nm
);
12858 end Process_Async_Pragma
;
12860 -- Start of processing for pragma Asynchronous
12863 Check_Ada_83_Warning
;
12864 Check_No_Identifiers
;
12865 Check_Arg_Count
(1);
12866 Check_Arg_Is_Local_Name
(Arg1
);
12868 if Debug_Flag_U
then
12872 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12873 Analyze
(Get_Pragma_Arg
(Arg1
));
12874 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12876 -- A pragma that applies to a Ghost entity becomes Ghost for the
12877 -- purposes of legality checks and removal of ignored Ghost code.
12879 Mark_Ghost_Pragma
(N
, Nm
);
12881 if not Is_Remote_Call_Interface
(C_Ent
)
12882 and then not Is_Remote_Types
(C_Ent
)
12884 -- This pragma should only appear in an RCI or Remote Types
12885 -- unit (RM E.4.1(4)).
12888 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12891 if Ekind
(Nm
) = E_Procedure
12892 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12894 if not Is_Remote_Call_Interface
(Nm
) then
12896 ("pragma% cannot be applied on non-remote procedure",
12900 L
:= Parameter_Specifications
(Parent
(Nm
));
12901 Process_Async_Pragma
;
12904 elsif Ekind
(Nm
) = E_Function
then
12906 ("pragma% cannot be applied to function", Arg1
);
12908 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12909 if Is_Record_Type
(Nm
) then
12911 -- A record type that is the Equivalent_Type for a remote
12912 -- access-to-subprogram type.
12914 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
12917 -- A non-expanded RAS type (distribution is not enabled)
12919 Decl
:= Declaration_Node
(Nm
);
12922 if Nkind
(Decl
) = N_Full_Type_Declaration
12923 and then Nkind
(Type_Definition
(Decl
)) =
12924 N_Access_Procedure_Definition
12926 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
12927 Process_Async_Pragma
;
12929 if Is_Asynchronous
(Nm
)
12930 and then Expander_Active
12931 and then Get_PCS_Name
/= Name_No_DSA
12933 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
12938 ("pragma% cannot reference access-to-function type",
12942 -- Only other possibility is Access-to-class-wide type
12944 elsif Is_Access_Type
(Nm
)
12945 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
12947 Check_First_Subtype
(Arg1
);
12948 Set_Is_Asynchronous
(Nm
);
12949 if Expander_Active
then
12950 RACW_Type_Is_Asynchronous
(Nm
);
12954 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12962 -- pragma Atomic (LOCAL_NAME);
12964 when Pragma_Atomic
=>
12965 Process_Atomic_Independent_Shared_Volatile
;
12967 -----------------------
12968 -- Atomic_Components --
12969 -----------------------
12971 -- pragma Atomic_Components (array_LOCAL_NAME);
12973 -- This processing is shared by Volatile_Components
12975 when Pragma_Atomic_Components
12976 | Pragma_Volatile_Components
12978 Atomic_Components
: declare
12985 Check_Ada_83_Warning
;
12986 Check_No_Identifiers
;
12987 Check_Arg_Count
(1);
12988 Check_Arg_Is_Local_Name
(Arg1
);
12989 E_Id
:= Get_Pragma_Arg
(Arg1
);
12991 if Etype
(E_Id
) = Any_Type
then
12995 E
:= Entity
(E_Id
);
12997 -- A pragma that applies to a Ghost entity becomes Ghost for the
12998 -- purposes of legality checks and removal of ignored Ghost code.
13000 Mark_Ghost_Pragma
(N
, E
);
13001 Check_Duplicate_Pragma
(E
);
13003 if Rep_Item_Too_Early
(E
, N
)
13005 Rep_Item_Too_Late
(E
, N
)
13010 D
:= Declaration_Node
(E
);
13013 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13015 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13016 and then Nkind
(D
) = N_Object_Declaration
13017 and then Nkind
(Object_Definition
(D
)) =
13018 N_Constrained_Array_Definition
)
13020 -- The flag is set on the object, or on the base type
13022 if Nkind
(D
) /= N_Object_Declaration
then
13023 E
:= Base_Type
(E
);
13026 -- Atomic implies both Independent and Volatile
13028 if Prag_Id
= Pragma_Atomic_Components
then
13029 Set_Has_Atomic_Components
(E
);
13030 Set_Has_Independent_Components
(E
);
13033 Set_Has_Volatile_Components
(E
);
13036 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13038 end Atomic_Components
;
13040 --------------------
13041 -- Attach_Handler --
13042 --------------------
13044 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13046 when Pragma_Attach_Handler
=>
13047 Check_Ada_83_Warning
;
13048 Check_No_Identifiers
;
13049 Check_Arg_Count
(2);
13051 if No_Run_Time_Mode
then
13052 Error_Msg_CRT
("Attach_Handler pragma", N
);
13054 Check_Interrupt_Or_Attach_Handler
;
13056 -- The expression that designates the attribute may depend on a
13057 -- discriminant, and is therefore a per-object expression, to
13058 -- be expanded in the init proc. If expansion is enabled, then
13059 -- perform semantic checks on a copy only.
13064 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13067 -- In Relaxed_RM_Semantics mode, we allow any static
13068 -- integer value, for compatibility with other compilers.
13070 if Relaxed_RM_Semantics
13071 and then Nkind
(Parg2
) = N_Integer_Literal
13073 Typ
:= Standard_Integer
;
13075 Typ
:= RTE
(RE_Interrupt_ID
);
13078 if Expander_Active
then
13079 Temp
:= New_Copy_Tree
(Parg2
);
13080 Set_Parent
(Temp
, N
);
13081 Preanalyze_And_Resolve
(Temp
, Typ
);
13084 Resolve
(Parg2
, Typ
);
13088 Process_Interrupt_Or_Attach_Handler
;
13091 --------------------
13092 -- C_Pass_By_Copy --
13093 --------------------
13095 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13097 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13103 Check_Valid_Configuration_Pragma
;
13104 Check_Arg_Count
(1);
13105 Check_Optional_Identifier
(Arg1
, "max_size");
13107 Arg
:= Get_Pragma_Arg
(Arg1
);
13108 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13110 Val
:= Expr_Value
(Arg
);
13114 ("maximum size for pragma% must be positive", Arg1
);
13116 elsif UI_Is_In_Int_Range
(Val
) then
13117 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13119 -- If a giant value is given, Int'Last will do well enough.
13120 -- If sometime someone complains that a record larger than
13121 -- two gigabytes is not copied, we will worry about it then.
13124 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13126 end C_Pass_By_Copy
;
13132 -- pragma Check ([Name =>] CHECK_KIND,
13133 -- [Check =>] Boolean_EXPRESSION
13134 -- [,[Message =>] String_EXPRESSION]);
13136 -- CHECK_KIND ::= IDENTIFIER |
13139 -- Invariant'Class |
13140 -- Type_Invariant'Class
13142 -- The identifiers Assertions and Statement_Assertions are not
13143 -- allowed, since they have special meaning for Check_Policy.
13145 -- WARNING: The code below manages Ghost regions. Return statements
13146 -- must be replaced by gotos which jump to the end of the code and
13147 -- restore the Ghost mode.
13149 when Pragma_Check
=> Check
: declare
13150 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13151 -- Save the Ghost mode to restore on exit
13157 pragma Warnings
(Off
, Str
);
13160 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13161 -- the mode now to ensure that any nodes generated during analysis
13162 -- and expansion are marked as Ghost.
13164 Set_Ghost_Mode
(N
);
13167 Check_At_Least_N_Arguments
(2);
13168 Check_At_Most_N_Arguments
(3);
13169 Check_Optional_Identifier
(Arg1
, Name_Name
);
13170 Check_Optional_Identifier
(Arg2
, Name_Check
);
13172 if Arg_Count
= 3 then
13173 Check_Optional_Identifier
(Arg3
, Name_Message
);
13174 Str
:= Get_Pragma_Arg
(Arg3
);
13177 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13178 Check_Arg_Is_Identifier
(Arg1
);
13179 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13181 -- Check forbidden name Assertions or Statement_Assertions
13184 when Name_Assertions
=>
13186 ("""Assertions"" is not allowed as a check kind for "
13187 & "pragma%", Arg1
);
13189 when Name_Statement_Assertions
=>
13191 ("""Statement_Assertions"" is not allowed as a check kind "
13192 & "for pragma%", Arg1
);
13198 -- Check applicable policy. We skip this if Checked/Ignored status
13199 -- is already set (e.g. in the case of a pragma from an aspect).
13201 if Is_Checked
(N
) or else Is_Ignored
(N
) then
13204 -- For a non-source pragma that is a rewriting of another pragma,
13205 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13207 elsif Is_Rewrite_Substitution
(N
)
13208 and then Nkind
(Original_Node
(N
)) = N_Pragma
13209 and then Original_Node
(N
) /= N
13211 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
13212 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
13214 -- Otherwise query the applicable policy at this point
13217 case Check_Kind
(Cname
) is
13218 when Name_Ignore
=>
13219 Set_Is_Ignored
(N
, True);
13220 Set_Is_Checked
(N
, False);
13223 Set_Is_Ignored
(N
, False);
13224 Set_Is_Checked
(N
, True);
13226 -- For disable, rewrite pragma as null statement and skip
13227 -- rest of the analysis of the pragma.
13229 when Name_Disable
=>
13230 Rewrite
(N
, Make_Null_Statement
(Loc
));
13234 -- No other possibilities
13237 raise Program_Error
;
13241 -- If check kind was not Disable, then continue pragma analysis
13243 Expr
:= Get_Pragma_Arg
(Arg2
);
13245 -- Deal with SCO generation
13247 if Is_Checked
(N
) and then not Split_PPC
(N
) then
13248 Set_SCO_Pragma_Enabled
(Loc
);
13251 -- Deal with analyzing the string argument. If checks are not
13252 -- on we don't want any expansion (since such expansion would
13253 -- not get properly deleted) but we do want to analyze (to get
13254 -- proper references). The Preanalyze_And_Resolve routine does
13255 -- just what we want. Ditto if pragma is active, because it will
13256 -- be rewritten as an if-statement whose analysis will complete
13257 -- analysis and expansion of the string message. This makes a
13258 -- difference in the unusual case where the expression for the
13259 -- string may have a side effect, such as raising an exception.
13260 -- This is mandated by RM 11.4.2, which specifies that the string
13261 -- expression is only evaluated if the check fails and
13262 -- Assertion_Error is to be raised.
13264 if Arg_Count
= 3 then
13265 Preanalyze_And_Resolve
(Str
, Standard_String
);
13268 -- Now you might think we could just do the same with the Boolean
13269 -- expression if checks are off (and expansion is on) and then
13270 -- rewrite the check as a null statement. This would work but we
13271 -- would lose the useful warnings about an assertion being bound
13272 -- to fail even if assertions are turned off.
13274 -- So instead we wrap the boolean expression in an if statement
13275 -- that looks like:
13277 -- if False and then condition then
13281 -- The reason we do this rewriting during semantic analysis rather
13282 -- than as part of normal expansion is that we cannot analyze and
13283 -- expand the code for the boolean expression directly, or it may
13284 -- cause insertion of actions that would escape the attempt to
13285 -- suppress the check code.
13287 -- Note that the Sloc for the if statement corresponds to the
13288 -- argument condition, not the pragma itself. The reason for
13289 -- this is that we may generate a warning if the condition is
13290 -- False at compile time, and we do not want to delete this
13291 -- warning when we delete the if statement.
13293 if Expander_Active
and Is_Ignored
(N
) then
13294 Eloc
:= Sloc
(Expr
);
13297 Make_If_Statement
(Eloc
,
13299 Make_And_Then
(Eloc
,
13300 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
13301 Right_Opnd
=> Expr
),
13302 Then_Statements
=> New_List
(
13303 Make_Null_Statement
(Eloc
))));
13305 -- Now go ahead and analyze the if statement
13307 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13309 -- One rather special treatment. If we are now in Eliminated
13310 -- overflow mode, then suppress overflow checking since we do
13311 -- not want to drag in the bignum stuff if we are in Ignore
13312 -- mode anyway. This is particularly important if we are using
13313 -- a configurable run time that does not support bignum ops.
13315 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
13317 Svo
: constant Boolean :=
13318 Scope_Suppress
.Suppress
(Overflow_Check
);
13320 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
13321 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
13323 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
13324 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
13327 -- Not that special case
13333 -- All done with this check
13335 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13337 -- Check is active or expansion not active. In these cases we can
13338 -- just go ahead and analyze the boolean with no worries.
13341 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13342 Analyze_And_Resolve
(Expr
, Any_Boolean
);
13343 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13346 Restore_Ghost_Mode
(Saved_GM
);
13349 --------------------------
13350 -- Check_Float_Overflow --
13351 --------------------------
13353 -- pragma Check_Float_Overflow;
13355 when Pragma_Check_Float_Overflow
=>
13357 Check_Valid_Configuration_Pragma
;
13358 Check_Arg_Count
(0);
13359 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
13365 -- pragma Check_Name (check_IDENTIFIER);
13367 when Pragma_Check_Name
=>
13369 Check_No_Identifiers
;
13370 Check_Valid_Configuration_Pragma
;
13371 Check_Arg_Count
(1);
13372 Check_Arg_Is_Identifier
(Arg1
);
13375 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
13378 for J
in Check_Names
.First
.. Check_Names
.Last
loop
13379 if Check_Names
.Table
(J
) = Nam
then
13384 Check_Names
.Append
(Nam
);
13391 -- This is the old style syntax, which is still allowed in all modes:
13393 -- pragma Check_Policy ([Name =>] CHECK_KIND
13394 -- [Policy =>] POLICY_IDENTIFIER);
13396 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13398 -- CHECK_KIND ::= IDENTIFIER |
13401 -- Type_Invariant'Class |
13404 -- This is the new style syntax, compatible with Assertion_Policy
13405 -- and also allowed in all modes.
13407 -- Pragma Check_Policy (
13408 -- CHECK_KIND => POLICY_IDENTIFIER
13409 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13411 -- Note: the identifiers Name and Policy are not allowed as
13412 -- Check_Kind values. This avoids ambiguities between the old and
13413 -- new form syntax.
13415 when Pragma_Check_Policy
=> Check_Policy
: declare
13420 Check_At_Least_N_Arguments
(1);
13422 -- A Check_Policy pragma can appear either as a configuration
13423 -- pragma, or in a declarative part or a package spec (see RM
13424 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13425 -- followed for Check_Policy).
13427 if not Is_Configuration_Pragma
then
13428 Check_Is_In_Decl_Part_Or_Package_Spec
;
13431 -- Figure out if we have the old or new syntax. We have the
13432 -- old syntax if the first argument has no identifier, or the
13433 -- identifier is Name.
13435 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
13436 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
13440 Check_Arg_Count
(2);
13441 Check_Optional_Identifier
(Arg1
, Name_Name
);
13442 Kind
:= Get_Pragma_Arg
(Arg1
);
13443 Rewrite_Assertion_Kind
(Kind
,
13444 From_Policy
=> Comes_From_Source
(N
));
13445 Check_Arg_Is_Identifier
(Arg1
);
13447 -- Check forbidden check kind
13449 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
13450 Error_Msg_Name_2
:= Chars
(Kind
);
13452 ("pragma% does not allow% as check name", Arg1
);
13457 Check_Optional_Identifier
(Arg2
, Name_Policy
);
13458 Check_Arg_Is_One_Of
13460 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
13462 -- And chain pragma on the Check_Policy_List for search
13464 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
13465 Opt
.Check_Policy_List
:= N
;
13467 -- For the new syntax, what we do is to convert each argument to
13468 -- an old syntax equivalent. We do that because we want to chain
13469 -- old style Check_Policy pragmas for the search (we don't want
13470 -- to have to deal with multiple arguments in the search).
13481 while Present
(Arg
) loop
13482 LocP
:= Sloc
(Arg
);
13483 Argx
:= Get_Pragma_Arg
(Arg
);
13485 -- Kind must be specified
13487 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13488 or else Chars
(Arg
) = No_Name
13491 ("missing assertion kind for pragma%", Arg
);
13494 -- Construct equivalent old form syntax Check_Policy
13495 -- pragma and insert it to get remaining checks.
13499 Chars
=> Name_Check_Policy
,
13500 Pragma_Argument_Associations
=> New_List
(
13501 Make_Pragma_Argument_Association
(LocP
,
13503 Make_Identifier
(LocP
, Chars
(Arg
))),
13504 Make_Pragma_Argument_Association
(Sloc
(Argx
),
13505 Expression
=> Argx
)));
13509 -- For a configuration pragma, insert old form in
13510 -- the corresponding file.
13512 if Is_Configuration_Pragma
then
13513 Insert_After
(N
, New_P
);
13517 Insert_Action
(N
, New_P
);
13521 -- Rewrite original Check_Policy pragma to null, since we
13522 -- have converted it into a series of old syntax pragmas.
13524 Rewrite
(N
, Make_Null_Statement
(Loc
));
13534 -- pragma Comment (static_string_EXPRESSION)
13536 -- Processing for pragma Comment shares the circuitry for pragma
13537 -- Ident. The only differences are that Ident enforces a limit of 31
13538 -- characters on its argument, and also enforces limitations on
13539 -- placement for DEC compatibility. Pragma Comment shares neither of
13540 -- these restrictions.
13542 -------------------
13543 -- Common_Object --
13544 -------------------
13546 -- pragma Common_Object (
13547 -- [Internal =>] LOCAL_NAME
13548 -- [, [External =>] EXTERNAL_SYMBOL]
13549 -- [, [Size =>] EXTERNAL_SYMBOL]);
13551 -- Processing for this pragma is shared with Psect_Object
13553 ------------------------
13554 -- Compile_Time_Error --
13555 ------------------------
13557 -- pragma Compile_Time_Error
13558 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13560 when Pragma_Compile_Time_Error
=>
13562 Process_Compile_Time_Warning_Or_Error
;
13564 --------------------------
13565 -- Compile_Time_Warning --
13566 --------------------------
13568 -- pragma Compile_Time_Warning
13569 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13571 when Pragma_Compile_Time_Warning
=>
13573 Process_Compile_Time_Warning_Or_Error
;
13575 ---------------------------
13576 -- Compiler_Unit_Warning --
13577 ---------------------------
13579 -- pragma Compiler_Unit_Warning;
13583 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13584 -- errors not warnings. This means that we had introduced a big extra
13585 -- inertia to compiler changes, since even if we implemented a new
13586 -- feature, and even if all versions to be used for bootstrapping
13587 -- implemented this new feature, we could not use it, since old
13588 -- compilers would give errors for using this feature in units
13589 -- having Compiler_Unit pragmas.
13591 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13592 -- problem. We no longer have any units mentioning Compiler_Unit,
13593 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13594 -- and thus generates a warning which can be ignored. So that deals
13595 -- with the problem of old compilers not implementing the newer form
13598 -- Newer compilers recognize the new pragma, but generate warning
13599 -- messages instead of errors, which again can be ignored in the
13600 -- case of an old compiler which implements a wanted new feature
13601 -- but at the time felt like warning about it for older compilers.
13603 -- We retain Compiler_Unit so that new compilers can be used to build
13604 -- older run-times that use this pragma. That's an unusual case, but
13605 -- it's easy enough to handle, so why not?
13607 when Pragma_Compiler_Unit
13608 | Pragma_Compiler_Unit_Warning
13611 Check_Arg_Count
(0);
13613 -- Only recognized in main unit
13615 if Current_Sem_Unit
= Main_Unit
then
13616 Compiler_Unit
:= True;
13619 -----------------------------
13620 -- Complete_Representation --
13621 -----------------------------
13623 -- pragma Complete_Representation;
13625 when Pragma_Complete_Representation
=>
13627 Check_Arg_Count
(0);
13629 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13631 ("pragma & must appear within record representation clause");
13634 ----------------------------
13635 -- Complex_Representation --
13636 ----------------------------
13638 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13640 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13647 Check_Arg_Count
(1);
13648 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13649 Check_Arg_Is_Local_Name
(Arg1
);
13650 E_Id
:= Get_Pragma_Arg
(Arg1
);
13652 if Etype
(E_Id
) = Any_Type
then
13656 E
:= Entity
(E_Id
);
13658 if not Is_Record_Type
(E
) then
13660 ("argument for pragma% must be record type", Arg1
);
13663 Ent
:= First_Entity
(E
);
13666 or else No
(Next_Entity
(Ent
))
13667 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13668 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13669 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13672 ("record for pragma% must have two fields of the same "
13673 & "floating-point type", Arg1
);
13676 Set_Has_Complex_Representation
(Base_Type
(E
));
13678 -- We need to treat the type has having a non-standard
13679 -- representation, for back-end purposes, even though in
13680 -- general a complex will have the default representation
13681 -- of a record with two real components.
13683 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13685 end Complex_Representation
;
13687 -------------------------
13688 -- Component_Alignment --
13689 -------------------------
13691 -- pragma Component_Alignment (
13692 -- [Form =>] ALIGNMENT_CHOICE
13693 -- [, [Name =>] type_LOCAL_NAME]);
13695 -- ALIGNMENT_CHOICE ::=
13697 -- | Component_Size_4
13701 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13702 Args
: Args_List
(1 .. 2);
13703 Names
: constant Name_List
(1 .. 2) := (
13707 Form
: Node_Id
renames Args
(1);
13708 Name
: Node_Id
renames Args
(2);
13710 Atype
: Component_Alignment_Kind
;
13715 Gather_Associations
(Names
, Args
);
13718 Error_Pragma
("missing Form argument for pragma%");
13721 Check_Arg_Is_Identifier
(Form
);
13723 -- Get proper alignment, note that Default = Component_Size on all
13724 -- machines we have so far, and we want to set this value rather
13725 -- than the default value to indicate that it has been explicitly
13726 -- set (and thus will not get overridden by the default component
13727 -- alignment for the current scope)
13729 if Chars
(Form
) = Name_Component_Size
then
13730 Atype
:= Calign_Component_Size
;
13732 elsif Chars
(Form
) = Name_Component_Size_4
then
13733 Atype
:= Calign_Component_Size_4
;
13735 elsif Chars
(Form
) = Name_Default
then
13736 Atype
:= Calign_Component_Size
;
13738 elsif Chars
(Form
) = Name_Storage_Unit
then
13739 Atype
:= Calign_Storage_Unit
;
13743 ("invalid Form parameter for pragma%", Form
);
13746 -- The pragma appears in a configuration file
13748 if No
(Parent
(N
)) then
13749 Check_Valid_Configuration_Pragma
;
13751 -- Capture the component alignment in a global variable when
13752 -- the pragma appears in a configuration file. Note that the
13753 -- scope stack is empty at this point and cannot be used to
13754 -- store the alignment value.
13756 Configuration_Component_Alignment
:= Atype
;
13758 -- Case with no name, supplied, affects scope table entry
13760 elsif No
(Name
) then
13762 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13764 -- Case of name supplied
13767 Check_Arg_Is_Local_Name
(Name
);
13769 Typ
:= Entity
(Name
);
13772 or else Rep_Item_Too_Early
(Typ
, N
)
13776 Typ
:= Underlying_Type
(Typ
);
13779 if not Is_Record_Type
(Typ
)
13780 and then not Is_Array_Type
(Typ
)
13783 ("Name parameter of pragma% must identify record or "
13784 & "array type", Name
);
13787 -- An explicit Component_Alignment pragma overrides an
13788 -- implicit pragma Pack, but not an explicit one.
13790 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13791 Set_Is_Packed
(Base_Type
(Typ
), False);
13792 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13795 end Component_AlignmentP
;
13797 --------------------------------
13798 -- Constant_After_Elaboration --
13799 --------------------------------
13801 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13803 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13805 Obj_Decl
: Node_Id
;
13806 Obj_Id
: Entity_Id
;
13810 Check_No_Identifiers
;
13811 Check_At_Most_N_Arguments
(1);
13813 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13815 -- Object declaration
13817 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
13820 -- Otherwise the pragma is associated with an illegal construct
13827 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13829 -- The object declaration must be a library-level variable which
13830 -- is either explicitly initialized or obtains a value during the
13831 -- elaboration of a package body (SPARK RM 3.3.1).
13833 if Ekind
(Obj_Id
) = E_Variable
then
13834 if not Is_Library_Level_Entity
(Obj_Id
) then
13836 ("pragma % must apply to a library level variable");
13840 -- Otherwise the pragma applies to a constant, which is illegal
13843 Error_Pragma
("pragma % must apply to a variable declaration");
13847 -- A pragma that applies to a Ghost entity becomes Ghost for the
13848 -- purposes of legality checks and removal of ignored Ghost code.
13850 Mark_Ghost_Pragma
(N
, Obj_Id
);
13852 -- Chain the pragma on the contract for completeness
13854 Add_Contract_Item
(N
, Obj_Id
);
13856 -- Analyze the Boolean expression (if any)
13858 if Present
(Arg1
) then
13859 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13861 end Constant_After_Elaboration
;
13863 --------------------
13864 -- Contract_Cases --
13865 --------------------
13867 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13869 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13871 -- CASE_GUARD ::= boolean_EXPRESSION | others
13873 -- CONSEQUENCE ::= boolean_EXPRESSION
13875 -- Characteristics:
13877 -- * Analysis - The annotation undergoes initial checks to verify
13878 -- the legal placement and context. Secondary checks preanalyze the
13881 -- Analyze_Contract_Cases_In_Decl_Part
13883 -- * Expansion - The annotation is expanded during the expansion of
13884 -- the related subprogram [body] contract as performed in:
13886 -- Expand_Subprogram_Contract
13888 -- * Template - The annotation utilizes the generic template of the
13889 -- related subprogram [body] when it is:
13891 -- aspect on subprogram declaration
13892 -- aspect on stand-alone subprogram body
13893 -- pragma on stand-alone subprogram body
13895 -- The annotation must prepare its own template when it is:
13897 -- pragma on subprogram declaration
13899 -- * Globals - Capture of global references must occur after full
13902 -- * Instance - The annotation is instantiated automatically when
13903 -- the related generic subprogram [body] is instantiated except for
13904 -- the "pragma on subprogram declaration" case. In that scenario
13905 -- the annotation must instantiate itself.
13907 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13908 Spec_Id
: Entity_Id
;
13909 Subp_Decl
: Node_Id
;
13910 Subp_Spec
: Node_Id
;
13914 Check_No_Identifiers
;
13915 Check_Arg_Count
(1);
13917 -- Ensure the proper placement of the pragma. Contract_Cases must
13918 -- be associated with a subprogram declaration or a body that acts
13922 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13926 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13929 -- Generic subprogram
13931 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13934 -- Body acts as spec
13936 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13937 and then No
(Corresponding_Spec
(Subp_Decl
))
13941 -- Body stub acts as spec
13943 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13944 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13950 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13951 Subp_Spec
:= Specification
(Subp_Decl
);
13953 -- Pragma Contract_Cases is forbidden on null procedures, as
13954 -- this may lead to potential ambiguities in behavior when
13955 -- interface null procedures are involved.
13957 if Nkind
(Subp_Spec
) = N_Procedure_Specification
13958 and then Null_Present
(Subp_Spec
)
13960 Error_Msg_N
(Fix_Error
13961 ("pragma % cannot apply to null procedure"), N
);
13970 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13972 -- A pragma that applies to a Ghost entity becomes Ghost for the
13973 -- purposes of legality checks and removal of ignored Ghost code.
13975 Mark_Ghost_Pragma
(N
, Spec_Id
);
13976 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13978 -- Chain the pragma on the contract for further processing by
13979 -- Analyze_Contract_Cases_In_Decl_Part.
13981 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13983 -- Fully analyze the pragma when it appears inside an entry
13984 -- or subprogram body because it cannot benefit from forward
13987 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13989 N_Subprogram_Body_Stub
)
13991 -- The legality checks of pragma Contract_Cases are affected by
13992 -- the SPARK mode in effect and the volatility of the context.
13993 -- Analyze all pragmas in a specific order.
13995 Analyze_If_Present
(Pragma_SPARK_Mode
);
13996 Analyze_If_Present
(Pragma_Volatile_Function
);
13997 Analyze_Contract_Cases_In_Decl_Part
(N
);
13999 end Contract_Cases
;
14005 -- pragma Controlled (first_subtype_LOCAL_NAME);
14007 when Pragma_Controlled
=> Controlled
: declare
14011 Check_No_Identifiers
;
14012 Check_Arg_Count
(1);
14013 Check_Arg_Is_Local_Name
(Arg1
);
14014 Arg
:= Get_Pragma_Arg
(Arg1
);
14016 if not Is_Entity_Name
(Arg
)
14017 or else not Is_Access_Type
(Entity
(Arg
))
14019 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14021 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14029 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14030 -- [Entity =>] LOCAL_NAME);
14032 when Pragma_Convention
=> Convention
: declare
14035 pragma Warnings
(Off
, C
);
14036 pragma Warnings
(Off
, E
);
14039 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14040 Check_Ada_83_Warning
;
14041 Check_Arg_Count
(2);
14042 Process_Convention
(C
, E
);
14044 -- A pragma that applies to a Ghost entity becomes Ghost for the
14045 -- purposes of legality checks and removal of ignored Ghost code.
14047 Mark_Ghost_Pragma
(N
, E
);
14050 ---------------------------
14051 -- Convention_Identifier --
14052 ---------------------------
14054 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14055 -- [Convention =>] convention_IDENTIFIER);
14057 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14063 Check_Arg_Order
((Name_Name
, Name_Convention
));
14064 Check_Arg_Count
(2);
14065 Check_Optional_Identifier
(Arg1
, Name_Name
);
14066 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14067 Check_Arg_Is_Identifier
(Arg1
);
14068 Check_Arg_Is_Identifier
(Arg2
);
14069 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14070 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14072 if Is_Convention_Name
(Cname
) then
14073 Record_Convention_Identifier
14074 (Idnam
, Get_Convention_Id
(Cname
));
14077 ("second arg for % pragma must be convention", Arg2
);
14079 end Convention_Identifier
;
14085 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14087 when Pragma_CPP_Class
=>
14090 if Warn_On_Obsolescent_Feature
then
14092 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14093 & "effect; replace it by pragma import?j?", N
);
14096 Check_Arg_Count
(1);
14100 Chars
=> Name_Import
,
14101 Pragma_Argument_Associations
=> New_List
(
14102 Make_Pragma_Argument_Association
(Loc
,
14103 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14104 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14107 ---------------------
14108 -- CPP_Constructor --
14109 ---------------------
14111 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14112 -- [, [External_Name =>] static_string_EXPRESSION ]
14113 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14115 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14118 Def_Id
: Entity_Id
;
14119 Tag_Typ
: Entity_Id
;
14123 Check_At_Least_N_Arguments
(1);
14124 Check_At_Most_N_Arguments
(3);
14125 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14126 Check_Arg_Is_Local_Name
(Arg1
);
14128 Id
:= Get_Pragma_Arg
(Arg1
);
14129 Find_Program_Unit_Name
(Id
);
14131 -- If we did not find the name, we are done
14133 if Etype
(Id
) = Any_Type
then
14137 Def_Id
:= Entity
(Id
);
14139 -- Check if already defined as constructor
14141 if Is_Constructor
(Def_Id
) then
14143 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14147 if Ekind
(Def_Id
) = E_Function
14148 and then (Is_CPP_Class
(Etype
(Def_Id
))
14149 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14151 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14153 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14155 ("'C'P'P constructor must be defined in the scope of "
14156 & "its returned type", Arg1
);
14159 if Arg_Count
>= 2 then
14160 Set_Imported
(Def_Id
);
14161 Set_Is_Public
(Def_Id
);
14162 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14165 Set_Has_Completion
(Def_Id
);
14166 Set_Is_Constructor
(Def_Id
);
14167 Set_Convention
(Def_Id
, Convention_CPP
);
14169 -- Imported C++ constructors are not dispatching primitives
14170 -- because in C++ they don't have a dispatch table slot.
14171 -- However, in Ada the constructor has the profile of a
14172 -- function that returns a tagged type and therefore it has
14173 -- been treated as a primitive operation during semantic
14174 -- analysis. We now remove it from the list of primitive
14175 -- operations of the type.
14177 if Is_Tagged_Type
(Etype
(Def_Id
))
14178 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14179 and then Is_Dispatching_Operation
(Def_Id
)
14181 Tag_Typ
:= Etype
(Def_Id
);
14183 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14184 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
14188 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
14189 Set_Is_Dispatching_Operation
(Def_Id
, False);
14192 -- For backward compatibility, if the constructor returns a
14193 -- class wide type, and we internally change the return type to
14194 -- the corresponding root type.
14196 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
14197 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
14201 ("pragma% requires function returning a 'C'P'P_Class type",
14204 end CPP_Constructor
;
14210 when Pragma_CPP_Virtual
=>
14213 if Warn_On_Obsolescent_Feature
then
14215 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14223 when Pragma_CPP_Vtable
=>
14226 if Warn_On_Obsolescent_Feature
then
14228 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14236 -- pragma CPU (EXPRESSION);
14238 when Pragma_CPU
=> CPU
: declare
14239 P
: constant Node_Id
:= Parent
(N
);
14245 Check_No_Identifiers
;
14246 Check_Arg_Count
(1);
14250 if Nkind
(P
) = N_Subprogram_Body
then
14251 Check_In_Main_Program
;
14253 Arg
:= Get_Pragma_Arg
(Arg1
);
14254 Analyze_And_Resolve
(Arg
, Any_Integer
);
14256 Ent
:= Defining_Unit_Name
(Specification
(P
));
14258 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
14259 Ent
:= Defining_Identifier
(Ent
);
14264 if not Is_OK_Static_Expression
(Arg
) then
14265 Flag_Non_Static_Expr
14266 ("main subprogram affinity is not static!", Arg
);
14269 -- If constraint error, then we already signalled an error
14271 elsif Raises_Constraint_Error
(Arg
) then
14274 -- Otherwise check in range
14278 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
14279 -- This is the entity System.Multiprocessors.CPU_Range;
14281 Val
: constant Uint
:= Expr_Value
(Arg
);
14284 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
14286 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
14289 ("main subprogram CPU is out of range", Arg1
);
14295 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
14299 elsif Nkind
(P
) = N_Task_Definition
then
14300 Arg
:= Get_Pragma_Arg
(Arg1
);
14301 Ent
:= Defining_Identifier
(Parent
(P
));
14303 -- The expression must be analyzed in the special manner
14304 -- described in "Handling of Default and Per-Object
14305 -- Expressions" in sem.ads.
14307 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
14309 -- Anything else is incorrect
14315 -- Check duplicate pragma before we chain the pragma in the Rep
14316 -- Item chain of Ent.
14318 Check_Duplicate_Pragma
(Ent
);
14319 Record_Rep_Item
(Ent
, N
);
14322 --------------------
14323 -- Deadline_Floor --
14324 --------------------
14326 -- pragma Deadline_Floor (time_span_EXPRESSION);
14328 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
14329 P
: constant Node_Id
:= Parent
(N
);
14335 Check_No_Identifiers
;
14336 Check_Arg_Count
(1);
14338 Arg
:= Get_Pragma_Arg
(Arg1
);
14340 -- The expression must be analyzed in the special manner described
14341 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14343 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
14345 -- Only protected types allowed
14347 if Nkind
(P
) /= N_Protected_Definition
then
14351 Ent
:= Defining_Identifier
(Parent
(P
));
14353 -- Check duplicate pragma before we chain the pragma in the Rep
14354 -- Item chain of Ent.
14356 Check_Duplicate_Pragma
(Ent
);
14357 Record_Rep_Item
(Ent
, N
);
14359 end Deadline_Floor
;
14365 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14367 when Pragma_Debug
=> Debug
: declare
14374 -- The condition for executing the call is that the expander
14375 -- is active and that we are not ignoring this debug pragma.
14380 (Expander_Active
and then not Is_Ignored
(N
)),
14383 if not Is_Ignored
(N
) then
14384 Set_SCO_Pragma_Enabled
(Loc
);
14387 if Arg_Count
= 2 then
14389 Make_And_Then
(Loc
,
14390 Left_Opnd
=> Relocate_Node
(Cond
),
14391 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
14392 Call
:= Get_Pragma_Arg
(Arg2
);
14394 Call
:= Get_Pragma_Arg
(Arg1
);
14397 if Nkind_In
(Call
, N_Expanded_Name
,
14400 N_Indexed_Component
,
14401 N_Selected_Component
)
14403 -- If this pragma Debug comes from source, its argument was
14404 -- parsed as a name form (which is syntactically identical).
14405 -- In a generic context a parameterless call will be left as
14406 -- an expanded name (if global) or selected_component if local.
14407 -- Change it to a procedure call statement now.
14409 Change_Name_To_Procedure_Call_Statement
(Call
);
14411 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
14413 -- Already in the form of a procedure call statement: nothing
14414 -- to do (could happen in case of an internally generated
14420 -- All other cases: diagnose error
14423 ("argument of pragma ""Debug"" is not procedure call",
14428 -- Rewrite into a conditional with an appropriate condition. We
14429 -- wrap the procedure call in a block so that overhead from e.g.
14430 -- use of the secondary stack does not generate execution overhead
14431 -- for suppressed conditions.
14433 -- Normally the analysis that follows will freeze the subprogram
14434 -- being called. However, if the call is to a null procedure,
14435 -- we want to freeze it before creating the block, because the
14436 -- analysis that follows may be done with expansion disabled, in
14437 -- which case the body will not be generated, leading to spurious
14440 if Nkind
(Call
) = N_Procedure_Call_Statement
14441 and then Is_Entity_Name
(Name
(Call
))
14443 Analyze
(Name
(Call
));
14444 Freeze_Before
(N
, Entity
(Name
(Call
)));
14448 Make_Implicit_If_Statement
(N
,
14450 Then_Statements
=> New_List
(
14451 Make_Block_Statement
(Loc
,
14452 Handled_Statement_Sequence
=>
14453 Make_Handled_Sequence_Of_Statements
(Loc
,
14454 Statements
=> New_List
(Relocate_Node
(Call
)))))));
14457 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14458 -- after analysis of the normally rewritten node, to capture all
14459 -- references to entities, which avoids issuing wrong warnings
14460 -- about unused entities.
14462 if GNATprove_Mode
then
14463 Rewrite
(N
, Make_Null_Statement
(Loc
));
14471 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14473 when Pragma_Debug_Policy
=>
14475 Check_Arg_Count
(1);
14476 Check_No_Identifiers
;
14477 Check_Arg_Is_Identifier
(Arg1
);
14479 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14480 -- rewrite it that way, and let the rest of the checking come
14481 -- from analyzing the rewritten pragma.
14485 Chars
=> Name_Check_Policy
,
14486 Pragma_Argument_Associations
=> New_List
(
14487 Make_Pragma_Argument_Association
(Loc
,
14488 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
14490 Make_Pragma_Argument_Association
(Loc
,
14491 Expression
=> Get_Pragma_Arg
(Arg1
)))));
14494 -------------------------------
14495 -- Default_Initial_Condition --
14496 -------------------------------
14498 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14500 when Pragma_Default_Initial_Condition
=> DIC
: declare
14507 Check_No_Identifiers
;
14508 Check_At_Most_N_Arguments
(1);
14512 while Present
(Stmt
) loop
14514 -- Skip prior pragmas, but check for duplicates
14516 if Nkind
(Stmt
) = N_Pragma
then
14517 if Pragma_Name
(Stmt
) = Pname
then
14524 -- Skip internally generated code. Note that derived type
14525 -- declarations of untagged types with discriminants are
14526 -- rewritten as private type declarations.
14528 elsif not Comes_From_Source
(Stmt
)
14529 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
14533 -- The associated private type [extension] has been found, stop
14536 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
14537 N_Private_Type_Declaration
)
14539 Typ
:= Defining_Entity
(Stmt
);
14542 -- The pragma does not apply to a legal construct, issue an
14543 -- error and stop the analysis.
14550 Stmt
:= Prev
(Stmt
);
14553 -- The pragma does not apply to a legal construct, issue an error
14554 -- and stop the analysis.
14561 -- A pragma that applies to a Ghost entity becomes Ghost for the
14562 -- purposes of legality checks and removal of ignored Ghost code.
14564 Mark_Ghost_Pragma
(N
, Typ
);
14566 -- The pragma signals that the type defines its own DIC assertion
14569 Set_Has_Own_DIC
(Typ
);
14571 -- Chain the pragma on the rep item chain for further processing
14573 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
14575 -- Create the declaration of the procedure which verifies the
14576 -- assertion expression of pragma DIC at runtime.
14578 Build_DIC_Procedure_Declaration
(Typ
);
14581 ----------------------------------
14582 -- Default_Scalar_Storage_Order --
14583 ----------------------------------
14585 -- pragma Default_Scalar_Storage_Order
14586 -- (High_Order_First | Low_Order_First);
14588 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
14589 Default
: Character;
14593 Check_Arg_Count
(1);
14595 -- Default_Scalar_Storage_Order can appear as a configuration
14596 -- pragma, or in a declarative part of a package spec.
14598 if not Is_Configuration_Pragma
then
14599 Check_Is_In_Decl_Part_Or_Package_Spec
;
14602 Check_No_Identifiers
;
14603 Check_Arg_Is_One_Of
14604 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
14605 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14606 Default
:= Fold_Upper
(Name_Buffer
(1));
14608 if not Support_Nondefault_SSO_On_Target
14609 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
14611 if Warn_On_Unrecognized_Pragma
then
14613 ("non-default Scalar_Storage_Order not supported "
14614 & "on target?g?", N
);
14616 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
14619 -- Here set the specified default
14622 Opt
.Default_SSO
:= Default
;
14626 --------------------------
14627 -- Default_Storage_Pool --
14628 --------------------------
14630 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14632 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
14637 Check_Arg_Count
(1);
14639 -- Default_Storage_Pool can appear as a configuration pragma, or
14640 -- in a declarative part of a package spec.
14642 if not Is_Configuration_Pragma
then
14643 Check_Is_In_Decl_Part_Or_Package_Spec
;
14646 if From_Aspect_Specification
(N
) then
14648 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
14650 if not In_Open_Scopes
(E
) then
14652 ("aspect must apply to package or subprogram", N
);
14657 if Present
(Arg1
) then
14658 Pool
:= Get_Pragma_Arg
(Arg1
);
14660 -- Case of Default_Storage_Pool (null);
14662 if Nkind
(Pool
) = N_Null
then
14665 -- This is an odd case, this is not really an expression,
14666 -- so we don't have a type for it. So just set the type to
14669 Set_Etype
(Pool
, Empty
);
14671 -- Case of Default_Storage_Pool (storage_pool_NAME);
14674 -- If it's a configuration pragma, then the only allowed
14675 -- argument is "null".
14677 if Is_Configuration_Pragma
then
14678 Error_Pragma_Arg
("NULL expected", Arg1
);
14681 -- The expected type for a non-"null" argument is
14682 -- Root_Storage_Pool'Class, and the pool must be a variable.
14684 Analyze_And_Resolve
14685 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
14687 if Is_Variable
(Pool
) then
14689 -- A pragma that applies to a Ghost entity becomes Ghost
14690 -- for the purposes of legality checks and removal of
14691 -- ignored Ghost code.
14693 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14697 ("default storage pool must be a variable", Arg1
);
14701 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14702 -- access type will use this information to set the appropriate
14703 -- attributes of the access type. If the pragma appears in a
14704 -- generic unit it is ignored, given that it may refer to a
14707 if not Inside_A_Generic
then
14708 Default_Pool
:= Pool
;
14711 end Default_Storage_Pool
;
14717 -- pragma Depends (DEPENDENCY_RELATION);
14719 -- DEPENDENCY_RELATION ::=
14721 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14723 -- DEPENDENCY_CLAUSE ::=
14724 -- OUTPUT_LIST =>[+] INPUT_LIST
14725 -- | NULL_DEPENDENCY_CLAUSE
14727 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14729 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14731 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14733 -- OUTPUT ::= NAME | FUNCTION_RESULT
14736 -- where FUNCTION_RESULT is a function Result attribute_reference
14738 -- Characteristics:
14740 -- * Analysis - The annotation undergoes initial checks to verify
14741 -- the legal placement and context. Secondary checks fully analyze
14742 -- the dependency clauses in:
14744 -- Analyze_Depends_In_Decl_Part
14746 -- * Expansion - None.
14748 -- * Template - The annotation utilizes the generic template of the
14749 -- related subprogram [body] when it is:
14751 -- aspect on subprogram declaration
14752 -- aspect on stand-alone subprogram body
14753 -- pragma on stand-alone subprogram body
14755 -- The annotation must prepare its own template when it is:
14757 -- pragma on subprogram declaration
14759 -- * Globals - Capture of global references must occur after full
14762 -- * Instance - The annotation is instantiated automatically when
14763 -- the related generic subprogram [body] is instantiated except for
14764 -- the "pragma on subprogram declaration" case. In that scenario
14765 -- the annotation must instantiate itself.
14767 when Pragma_Depends
=> Depends
: declare
14769 Spec_Id
: Entity_Id
;
14770 Subp_Decl
: Node_Id
;
14773 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14777 -- Chain the pragma on the contract for further processing by
14778 -- Analyze_Depends_In_Decl_Part.
14780 Add_Contract_Item
(N
, Spec_Id
);
14782 -- Fully analyze the pragma when it appears inside an entry
14783 -- or subprogram body because it cannot benefit from forward
14786 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14788 N_Subprogram_Body_Stub
)
14790 -- The legality checks of pragmas Depends and Global are
14791 -- affected by the SPARK mode in effect and the volatility
14792 -- of the context. In addition these two pragmas are subject
14793 -- to an inherent order:
14798 -- Analyze all these pragmas in the order outlined above
14800 Analyze_If_Present
(Pragma_SPARK_Mode
);
14801 Analyze_If_Present
(Pragma_Volatile_Function
);
14802 Analyze_If_Present
(Pragma_Global
);
14803 Analyze_Depends_In_Decl_Part
(N
);
14808 ---------------------
14809 -- Detect_Blocking --
14810 ---------------------
14812 -- pragma Detect_Blocking;
14814 when Pragma_Detect_Blocking
=>
14816 Check_Arg_Count
(0);
14817 Check_Valid_Configuration_Pragma
;
14818 Detect_Blocking
:= True;
14820 ------------------------------------
14821 -- Disable_Atomic_Synchronization --
14822 ------------------------------------
14824 -- pragma Disable_Atomic_Synchronization [(Entity)];
14826 when Pragma_Disable_Atomic_Synchronization
=>
14828 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14830 -------------------
14831 -- Discard_Names --
14832 -------------------
14834 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14836 when Pragma_Discard_Names
=> Discard_Names
: declare
14841 Check_Ada_83_Warning
;
14843 -- Deal with configuration pragma case
14845 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14846 Global_Discard_Names
:= True;
14849 -- Otherwise, check correct appropriate context
14852 Check_Is_In_Decl_Part_Or_Package_Spec
;
14854 if Arg_Count
= 0 then
14856 -- If there is no parameter, then from now on this pragma
14857 -- applies to any enumeration, exception or tagged type
14858 -- defined in the current declarative part, and recursively
14859 -- to any nested scope.
14861 Set_Discard_Names
(Current_Scope
);
14865 Check_Arg_Count
(1);
14866 Check_Optional_Identifier
(Arg1
, Name_On
);
14867 Check_Arg_Is_Local_Name
(Arg1
);
14869 E_Id
:= Get_Pragma_Arg
(Arg1
);
14871 if Etype
(E_Id
) = Any_Type
then
14875 E
:= Entity
(E_Id
);
14877 -- A pragma that applies to a Ghost entity becomes Ghost for
14878 -- the purposes of legality checks and removal of ignored
14881 Mark_Ghost_Pragma
(N
, E
);
14883 if (Is_First_Subtype
(E
)
14885 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14886 or else Ekind
(E
) = E_Exception
14888 Set_Discard_Names
(E
);
14889 Record_Rep_Item
(E
, N
);
14893 ("inappropriate entity for pragma%", Arg1
);
14899 ------------------------
14900 -- Dispatching_Domain --
14901 ------------------------
14903 -- pragma Dispatching_Domain (EXPRESSION);
14905 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14906 P
: constant Node_Id
:= Parent
(N
);
14912 Check_No_Identifiers
;
14913 Check_Arg_Count
(1);
14915 -- This pragma is born obsolete, but not the aspect
14917 if not From_Aspect_Specification
(N
) then
14919 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14922 if Nkind
(P
) = N_Task_Definition
then
14923 Arg
:= Get_Pragma_Arg
(Arg1
);
14924 Ent
:= Defining_Identifier
(Parent
(P
));
14926 -- A pragma that applies to a Ghost entity becomes Ghost for
14927 -- the purposes of legality checks and removal of ignored Ghost
14930 Mark_Ghost_Pragma
(N
, Ent
);
14932 -- The expression must be analyzed in the special manner
14933 -- described in "Handling of Default and Per-Object
14934 -- Expressions" in sem.ads.
14936 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14938 -- Check duplicate pragma before we chain the pragma in the Rep
14939 -- Item chain of Ent.
14941 Check_Duplicate_Pragma
(Ent
);
14942 Record_Rep_Item
(Ent
, N
);
14944 -- Anything else is incorrect
14949 end Dispatching_Domain
;
14955 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14957 when Pragma_Elaborate
=> Elaborate
: declare
14962 -- Pragma must be in context items list of a compilation unit
14964 if not Is_In_Context_Clause
then
14968 -- Must be at least one argument
14970 if Arg_Count
= 0 then
14971 Error_Pragma
("pragma% requires at least one argument");
14974 -- In Ada 83 mode, there can be no items following it in the
14975 -- context list except other pragmas and implicit with clauses
14976 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14977 -- placement rule does not apply.
14979 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14981 while Present
(Citem
) loop
14982 if Nkind
(Citem
) = N_Pragma
14983 or else (Nkind
(Citem
) = N_With_Clause
14984 and then Implicit_With
(Citem
))
14989 ("(Ada 83) pragma% must be at end of context clause");
14996 -- Finally, the arguments must all be units mentioned in a with
14997 -- clause in the same context clause. Note we already checked (in
14998 -- Par.Prag) that the arguments are all identifiers or selected
15002 Outer
: while Present
(Arg
) loop
15003 Citem
:= First
(List_Containing
(N
));
15004 Inner
: while Citem
/= N
loop
15005 if Nkind
(Citem
) = N_With_Clause
15006 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15008 Set_Elaborate_Present
(Citem
, True);
15009 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15011 -- With the pragma present, elaboration calls on
15012 -- subprograms from the named unit need no further
15013 -- checks, as long as the pragma appears in the current
15014 -- compilation unit. If the pragma appears in some unit
15015 -- in the context, there might still be a need for an
15016 -- Elaborate_All_Desirable from the current compilation
15017 -- to the named unit, so we keep the check enabled. This
15018 -- does not apply in SPARK mode, where we allow pragma
15019 -- Elaborate, but we don't trust it to be right so we
15020 -- will still insist on the Elaborate_All.
15022 if Legacy_Elaboration_Checks
15023 and then In_Extended_Main_Source_Unit
(N
)
15024 and then SPARK_Mode
/= On
15026 Set_Suppress_Elaboration_Warnings
15027 (Entity
(Name
(Citem
)));
15038 ("argument of pragma% is not withed unit", Arg
);
15045 -------------------
15046 -- Elaborate_All --
15047 -------------------
15049 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15051 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15056 Check_Ada_83_Warning
;
15058 -- Pragma must be in context items list of a compilation unit
15060 if not Is_In_Context_Clause
then
15064 -- Must be at least one argument
15066 if Arg_Count
= 0 then
15067 Error_Pragma
("pragma% requires at least one argument");
15070 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15071 -- have to appear at the end of the context clause, but may
15072 -- appear mixed in with other items, even in Ada 83 mode.
15074 -- Final check: the arguments must all be units mentioned in
15075 -- a with clause in the same context clause. Note that we
15076 -- already checked (in Par.Prag) that all the arguments are
15077 -- either identifiers or selected components.
15080 Outr
: while Present
(Arg
) loop
15081 Citem
:= First
(List_Containing
(N
));
15082 Innr
: while Citem
/= N
loop
15083 if Nkind
(Citem
) = N_With_Clause
15084 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15086 Set_Elaborate_All_Present
(Citem
, True);
15087 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15089 -- Suppress warnings and elaboration checks on the named
15090 -- unit if the pragma is in the current compilation, as
15091 -- for pragma Elaborate.
15093 if Legacy_Elaboration_Checks
15094 and then In_Extended_Main_Source_Unit
(N
)
15096 Set_Suppress_Elaboration_Warnings
15097 (Entity
(Name
(Citem
)));
15107 Set_Error_Posted
(N
);
15109 ("argument of pragma% is not withed unit", Arg
);
15116 --------------------
15117 -- Elaborate_Body --
15118 --------------------
15120 -- pragma Elaborate_Body [( library_unit_NAME )];
15122 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15123 Cunit_Node
: Node_Id
;
15124 Cunit_Ent
: Entity_Id
;
15127 Check_Ada_83_Warning
;
15128 Check_Valid_Library_Unit_Pragma
;
15130 if Nkind
(N
) = N_Null_Statement
then
15134 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15135 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15137 -- A pragma that applies to a Ghost entity becomes Ghost for the
15138 -- purposes of legality checks and removal of ignored Ghost code.
15140 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15142 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15145 Error_Pragma
("pragma% must refer to a spec, not a body");
15147 Set_Body_Required
(Cunit_Node
);
15148 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15150 -- If we are in dynamic elaboration mode, then we suppress
15151 -- elaboration warnings for the unit, since it is definitely
15152 -- fine NOT to do dynamic checks at the first level (and such
15153 -- checks will be suppressed because no elaboration boolean
15154 -- is created for Elaborate_Body packages).
15156 -- But in the static model of elaboration, Elaborate_Body is
15157 -- definitely NOT good enough to ensure elaboration safety on
15158 -- its own, since the body may WITH other units that are not
15159 -- safe from an elaboration point of view, so a client must
15160 -- still do an Elaborate_All on such units.
15162 -- Debug flag -gnatdD restores the old behavior of 3.13, where
15163 -- Elaborate_Body always suppressed elab warnings.
15165 if Legacy_Elaboration_Checks
15166 and then (Dynamic_Elaboration_Checks
or Debug_Flag_DD
)
15168 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
15171 end Elaborate_Body
;
15173 ------------------------
15174 -- Elaboration_Checks --
15175 ------------------------
15177 -- pragma Elaboration_Checks (Static | Dynamic);
15179 when Pragma_Elaboration_Checks
=>
15181 Check_Arg_Count
(1);
15182 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
15184 -- Set flag accordingly (ignore attempt at dynamic elaboration
15185 -- checks in SPARK mode).
15187 Dynamic_Elaboration_Checks
:=
15188 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
15194 -- pragma Eliminate (
15195 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15196 -- [Entity =>] IDENTIFIER |
15197 -- SELECTED_COMPONENT |
15199 -- [, Source_Location => SOURCE_TRACE]);
15201 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15202 -- SOURCE_TRACE ::= STRING_LITERAL
15204 when Pragma_Eliminate
=> Eliminate
: declare
15205 Args
: Args_List
(1 .. 5);
15206 Names
: constant Name_List
(1 .. 5) := (
15209 Name_Parameter_Types
,
15211 Name_Source_Location
);
15213 -- Note : Parameter_Types and Result_Type are leftovers from
15214 -- prior implementations of the pragma. They are not generated
15215 -- by the gnatelim tool, and play no role in selecting which
15216 -- of a set of overloaded names is chosen for elimination.
15218 Unit_Name
: Node_Id
renames Args
(1);
15219 Entity
: Node_Id
renames Args
(2);
15220 Parameter_Types
: Node_Id
renames Args
(3);
15221 Result_Type
: Node_Id
renames Args
(4);
15222 Source_Location
: Node_Id
renames Args
(5);
15226 Check_Valid_Configuration_Pragma
;
15227 Gather_Associations
(Names
, Args
);
15229 if No
(Unit_Name
) then
15230 Error_Pragma
("missing Unit_Name argument for pragma%");
15234 and then (Present
(Parameter_Types
)
15236 Present
(Result_Type
)
15238 Present
(Source_Location
))
15240 Error_Pragma
("missing Entity argument for pragma%");
15243 if (Present
(Parameter_Types
)
15245 Present
(Result_Type
))
15247 Present
(Source_Location
)
15250 ("parameter profile and source location cannot be used "
15251 & "together in pragma%");
15254 Process_Eliminate_Pragma
15263 -----------------------------------
15264 -- Enable_Atomic_Synchronization --
15265 -----------------------------------
15267 -- pragma Enable_Atomic_Synchronization [(Entity)];
15269 when Pragma_Enable_Atomic_Synchronization
=>
15271 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
15278 -- [ Convention =>] convention_IDENTIFIER,
15279 -- [ Entity =>] LOCAL_NAME
15280 -- [, [External_Name =>] static_string_EXPRESSION ]
15281 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15283 when Pragma_Export
=> Export
: declare
15285 Def_Id
: Entity_Id
;
15287 pragma Warnings
(Off
, C
);
15290 Check_Ada_83_Warning
;
15294 Name_External_Name
,
15297 Check_At_Least_N_Arguments
(2);
15298 Check_At_Most_N_Arguments
(4);
15300 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15301 -- pragma Export (Entity, "external name");
15303 if Relaxed_RM_Semantics
15304 and then Arg_Count
= 2
15305 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
15308 Def_Id
:= Get_Pragma_Arg
(Arg1
);
15311 if not Is_Entity_Name
(Def_Id
) then
15312 Error_Pragma_Arg
("entity name required", Arg1
);
15315 Def_Id
:= Entity
(Def_Id
);
15316 Set_Exported
(Def_Id
, Arg1
);
15319 Process_Convention
(C
, Def_Id
);
15321 -- A pragma that applies to a Ghost entity becomes Ghost for
15322 -- the purposes of legality checks and removal of ignored Ghost
15325 Mark_Ghost_Pragma
(N
, Def_Id
);
15327 if Ekind
(Def_Id
) /= E_Constant
then
15328 Note_Possible_Modification
15329 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15332 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
15333 Set_Exported
(Def_Id
, Arg2
);
15336 -- If the entity is a deferred constant, propagate the information
15337 -- to the full view, because gigi elaborates the full view only.
15339 if Ekind
(Def_Id
) = E_Constant
15340 and then Present
(Full_View
(Def_Id
))
15343 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
15345 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
15346 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
15347 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
15352 ---------------------
15353 -- Export_Function --
15354 ---------------------
15356 -- pragma Export_Function (
15357 -- [Internal =>] LOCAL_NAME
15358 -- [, [External =>] EXTERNAL_SYMBOL]
15359 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15360 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15361 -- [, [Mechanism =>] MECHANISM]
15362 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15364 -- EXTERNAL_SYMBOL ::=
15366 -- | static_string_EXPRESSION
15368 -- PARAMETER_TYPES ::=
15370 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15372 -- TYPE_DESIGNATOR ::=
15374 -- | subtype_Name ' Access
15378 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15380 -- MECHANISM_ASSOCIATION ::=
15381 -- [formal_parameter_NAME =>] MECHANISM_NAME
15383 -- MECHANISM_NAME ::=
15387 when Pragma_Export_Function
=> Export_Function
: declare
15388 Args
: Args_List
(1 .. 6);
15389 Names
: constant Name_List
(1 .. 6) := (
15392 Name_Parameter_Types
,
15395 Name_Result_Mechanism
);
15397 Internal
: Node_Id
renames Args
(1);
15398 External
: Node_Id
renames Args
(2);
15399 Parameter_Types
: Node_Id
renames Args
(3);
15400 Result_Type
: Node_Id
renames Args
(4);
15401 Mechanism
: Node_Id
renames Args
(5);
15402 Result_Mechanism
: Node_Id
renames Args
(6);
15406 Gather_Associations
(Names
, Args
);
15407 Process_Extended_Import_Export_Subprogram_Pragma
(
15408 Arg_Internal
=> Internal
,
15409 Arg_External
=> External
,
15410 Arg_Parameter_Types
=> Parameter_Types
,
15411 Arg_Result_Type
=> Result_Type
,
15412 Arg_Mechanism
=> Mechanism
,
15413 Arg_Result_Mechanism
=> Result_Mechanism
);
15414 end Export_Function
;
15416 -------------------
15417 -- Export_Object --
15418 -------------------
15420 -- pragma Export_Object (
15421 -- [Internal =>] LOCAL_NAME
15422 -- [, [External =>] EXTERNAL_SYMBOL]
15423 -- [, [Size =>] EXTERNAL_SYMBOL]);
15425 -- EXTERNAL_SYMBOL ::=
15427 -- | static_string_EXPRESSION
15429 -- PARAMETER_TYPES ::=
15431 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15433 -- TYPE_DESIGNATOR ::=
15435 -- | subtype_Name ' Access
15439 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15441 -- MECHANISM_ASSOCIATION ::=
15442 -- [formal_parameter_NAME =>] MECHANISM_NAME
15444 -- MECHANISM_NAME ::=
15448 when Pragma_Export_Object
=> Export_Object
: declare
15449 Args
: Args_List
(1 .. 3);
15450 Names
: constant Name_List
(1 .. 3) := (
15455 Internal
: Node_Id
renames Args
(1);
15456 External
: Node_Id
renames Args
(2);
15457 Size
: Node_Id
renames Args
(3);
15461 Gather_Associations
(Names
, Args
);
15462 Process_Extended_Import_Export_Object_Pragma
(
15463 Arg_Internal
=> Internal
,
15464 Arg_External
=> External
,
15468 ----------------------
15469 -- Export_Procedure --
15470 ----------------------
15472 -- pragma Export_Procedure (
15473 -- [Internal =>] LOCAL_NAME
15474 -- [, [External =>] EXTERNAL_SYMBOL]
15475 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15476 -- [, [Mechanism =>] MECHANISM]);
15478 -- EXTERNAL_SYMBOL ::=
15480 -- | static_string_EXPRESSION
15482 -- PARAMETER_TYPES ::=
15484 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15486 -- TYPE_DESIGNATOR ::=
15488 -- | subtype_Name ' Access
15492 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15494 -- MECHANISM_ASSOCIATION ::=
15495 -- [formal_parameter_NAME =>] MECHANISM_NAME
15497 -- MECHANISM_NAME ::=
15501 when Pragma_Export_Procedure
=> Export_Procedure
: declare
15502 Args
: Args_List
(1 .. 4);
15503 Names
: constant Name_List
(1 .. 4) := (
15506 Name_Parameter_Types
,
15509 Internal
: Node_Id
renames Args
(1);
15510 External
: Node_Id
renames Args
(2);
15511 Parameter_Types
: Node_Id
renames Args
(3);
15512 Mechanism
: Node_Id
renames Args
(4);
15516 Gather_Associations
(Names
, Args
);
15517 Process_Extended_Import_Export_Subprogram_Pragma
(
15518 Arg_Internal
=> Internal
,
15519 Arg_External
=> External
,
15520 Arg_Parameter_Types
=> Parameter_Types
,
15521 Arg_Mechanism
=> Mechanism
);
15522 end Export_Procedure
;
15528 -- pragma Export_Value (
15529 -- [Value =>] static_integer_EXPRESSION,
15530 -- [Link_Name =>] static_string_EXPRESSION);
15532 when Pragma_Export_Value
=>
15534 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
15535 Check_Arg_Count
(2);
15537 Check_Optional_Identifier
(Arg1
, Name_Value
);
15538 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15540 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
15541 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15543 -----------------------------
15544 -- Export_Valued_Procedure --
15545 -----------------------------
15547 -- pragma Export_Valued_Procedure (
15548 -- [Internal =>] LOCAL_NAME
15549 -- [, [External =>] EXTERNAL_SYMBOL,]
15550 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15551 -- [, [Mechanism =>] MECHANISM]);
15553 -- EXTERNAL_SYMBOL ::=
15555 -- | static_string_EXPRESSION
15557 -- PARAMETER_TYPES ::=
15559 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15561 -- TYPE_DESIGNATOR ::=
15563 -- | subtype_Name ' Access
15567 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15569 -- MECHANISM_ASSOCIATION ::=
15570 -- [formal_parameter_NAME =>] MECHANISM_NAME
15572 -- MECHANISM_NAME ::=
15576 when Pragma_Export_Valued_Procedure
=>
15577 Export_Valued_Procedure
: declare
15578 Args
: Args_List
(1 .. 4);
15579 Names
: constant Name_List
(1 .. 4) := (
15582 Name_Parameter_Types
,
15585 Internal
: Node_Id
renames Args
(1);
15586 External
: Node_Id
renames Args
(2);
15587 Parameter_Types
: Node_Id
renames Args
(3);
15588 Mechanism
: Node_Id
renames Args
(4);
15592 Gather_Associations
(Names
, Args
);
15593 Process_Extended_Import_Export_Subprogram_Pragma
(
15594 Arg_Internal
=> Internal
,
15595 Arg_External
=> External
,
15596 Arg_Parameter_Types
=> Parameter_Types
,
15597 Arg_Mechanism
=> Mechanism
);
15598 end Export_Valued_Procedure
;
15600 -------------------
15601 -- Extend_System --
15602 -------------------
15604 -- pragma Extend_System ([Name =>] Identifier);
15606 when Pragma_Extend_System
=>
15608 Check_Valid_Configuration_Pragma
;
15609 Check_Arg_Count
(1);
15610 Check_Optional_Identifier
(Arg1
, Name_Name
);
15611 Check_Arg_Is_Identifier
(Arg1
);
15613 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15616 and then Name_Buffer
(1 .. 4) = "aux_"
15618 if Present
(System_Extend_Pragma_Arg
) then
15619 if Chars
(Get_Pragma_Arg
(Arg1
)) =
15620 Chars
(Expression
(System_Extend_Pragma_Arg
))
15624 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
15625 Error_Pragma
("pragma% conflicts with that #");
15629 System_Extend_Pragma_Arg
:= Arg1
;
15631 if not GNAT_Mode
then
15632 System_Extend_Unit
:= Arg1
;
15636 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
15639 ------------------------
15640 -- Extensions_Allowed --
15641 ------------------------
15643 -- pragma Extensions_Allowed (ON | OFF);
15645 when Pragma_Extensions_Allowed
=>
15647 Check_Arg_Count
(1);
15648 Check_No_Identifiers
;
15649 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
15651 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
15652 Extensions_Allowed
:= True;
15653 Ada_Version
:= Ada_Version_Type
'Last;
15656 Extensions_Allowed
:= False;
15657 Ada_Version
:= Ada_Version_Explicit
;
15658 Ada_Version_Pragma
:= Empty
;
15661 ------------------------
15662 -- Extensions_Visible --
15663 ------------------------
15665 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15667 -- Characteristics:
15669 -- * Analysis - The annotation is fully analyzed immediately upon
15670 -- elaboration as its expression must be static.
15672 -- * Expansion - None.
15674 -- * Template - The annotation utilizes the generic template of the
15675 -- related subprogram [body] when it is:
15677 -- aspect on subprogram declaration
15678 -- aspect on stand-alone subprogram body
15679 -- pragma on stand-alone subprogram body
15681 -- The annotation must prepare its own template when it is:
15683 -- pragma on subprogram declaration
15685 -- * Globals - Capture of global references must occur after full
15688 -- * Instance - The annotation is instantiated automatically when
15689 -- the related generic subprogram [body] is instantiated except for
15690 -- the "pragma on subprogram declaration" case. In that scenario
15691 -- the annotation must instantiate itself.
15693 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15694 Formal
: Entity_Id
;
15695 Has_OK_Formal
: Boolean := False;
15696 Spec_Id
: Entity_Id
;
15697 Subp_Decl
: Node_Id
;
15701 Check_No_Identifiers
;
15702 Check_At_Most_N_Arguments
(1);
15705 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15707 -- Abstract subprogram declaration
15709 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15712 -- Generic subprogram declaration
15714 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15717 -- Body acts as spec
15719 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15720 and then No
(Corresponding_Spec
(Subp_Decl
))
15724 -- Body stub acts as spec
15726 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15727 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15731 -- Subprogram declaration
15733 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15736 -- Otherwise the pragma is associated with an illegal construct
15739 Error_Pragma
("pragma % must apply to a subprogram");
15743 -- Mark the pragma as Ghost if the related subprogram is also
15744 -- Ghost. This also ensures that any expansion performed further
15745 -- below will produce Ghost nodes.
15747 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15748 Mark_Ghost_Pragma
(N
, Spec_Id
);
15750 -- Chain the pragma on the contract for completeness
15752 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15754 -- The legality checks of pragma Extension_Visible are affected
15755 -- by the SPARK mode in effect. Analyze all pragmas in specific
15758 Analyze_If_Present
(Pragma_SPARK_Mode
);
15760 -- Examine the formals of the related subprogram
15762 Formal
:= First_Formal
(Spec_Id
);
15763 while Present
(Formal
) loop
15765 -- At least one of the formals is of a specific tagged type,
15766 -- the pragma is legal.
15768 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15769 Has_OK_Formal
:= True;
15772 -- A generic subprogram with at least one formal of a private
15773 -- type ensures the legality of the pragma because the actual
15774 -- may be specifically tagged. Note that this is verified by
15775 -- the check above at instantiation time.
15777 elsif Is_Private_Type
(Etype
(Formal
))
15778 and then Is_Generic_Type
(Etype
(Formal
))
15780 Has_OK_Formal
:= True;
15784 Next_Formal
(Formal
);
15787 if not Has_OK_Formal
then
15788 Error_Msg_Name_1
:= Pname
;
15789 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15791 ("\subprogram & lacks parameter of specific tagged or "
15792 & "generic private type", N
, Spec_Id
);
15797 -- Analyze the Boolean expression (if any)
15799 if Present
(Arg1
) then
15800 Check_Static_Boolean_Expression
15801 (Expression
(Get_Argument
(N
, Spec_Id
)));
15803 end Extensions_Visible
;
15809 -- pragma External (
15810 -- [ Convention =>] convention_IDENTIFIER,
15811 -- [ Entity =>] LOCAL_NAME
15812 -- [, [External_Name =>] static_string_EXPRESSION ]
15813 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15815 when Pragma_External
=> External
: declare
15818 pragma Warnings
(Off
, C
);
15825 Name_External_Name
,
15827 Check_At_Least_N_Arguments
(2);
15828 Check_At_Most_N_Arguments
(4);
15829 Process_Convention
(C
, E
);
15831 -- A pragma that applies to a Ghost entity becomes Ghost for the
15832 -- purposes of legality checks and removal of ignored Ghost code.
15834 Mark_Ghost_Pragma
(N
, E
);
15836 Note_Possible_Modification
15837 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15838 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
15839 Set_Exported
(E
, Arg2
);
15842 --------------------------
15843 -- External_Name_Casing --
15844 --------------------------
15846 -- pragma External_Name_Casing (
15847 -- UPPERCASE | LOWERCASE
15848 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15850 when Pragma_External_Name_Casing
=>
15852 Check_No_Identifiers
;
15854 if Arg_Count
= 2 then
15855 Check_Arg_Is_One_Of
15856 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15858 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15860 Opt
.External_Name_Exp_Casing
:= As_Is
;
15862 when Name_Uppercase
=>
15863 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15865 when Name_Lowercase
=>
15866 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15873 Check_Arg_Count
(1);
15876 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15878 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15879 when Name_Uppercase
=>
15880 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15882 when Name_Lowercase
=>
15883 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15893 -- pragma Fast_Math;
15895 when Pragma_Fast_Math
=>
15897 Check_No_Identifiers
;
15898 Check_Valid_Configuration_Pragma
;
15901 --------------------------
15902 -- Favor_Top_Level --
15903 --------------------------
15905 -- pragma Favor_Top_Level (type_NAME);
15907 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15912 Check_No_Identifiers
;
15913 Check_Arg_Count
(1);
15914 Check_Arg_Is_Local_Name
(Arg1
);
15915 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15917 -- A pragma that applies to a Ghost entity becomes Ghost for the
15918 -- purposes of legality checks and removal of ignored Ghost code.
15920 Mark_Ghost_Pragma
(N
, Typ
);
15922 -- If it's an access-to-subprogram type (in particular, not a
15923 -- subtype), set the flag on that type.
15925 if Is_Access_Subprogram_Type
(Typ
) then
15926 Set_Can_Use_Internal_Rep
(Typ
, False);
15928 -- Otherwise it's an error (name denotes the wrong sort of entity)
15932 ("access-to-subprogram type expected",
15933 Get_Pragma_Arg
(Arg1
));
15935 end Favor_Top_Level
;
15937 ---------------------------
15938 -- Finalize_Storage_Only --
15939 ---------------------------
15941 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15943 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15944 Assoc
: constant Node_Id
:= Arg1
;
15945 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15950 Check_No_Identifiers
;
15951 Check_Arg_Count
(1);
15952 Check_Arg_Is_Local_Name
(Arg1
);
15954 Find_Type
(Type_Id
);
15955 Typ
:= Entity
(Type_Id
);
15958 or else Rep_Item_Too_Early
(Typ
, N
)
15962 Typ
:= Underlying_Type
(Typ
);
15965 if not Is_Controlled
(Typ
) then
15966 Error_Pragma
("pragma% must specify controlled type");
15969 Check_First_Subtype
(Arg1
);
15971 if Finalize_Storage_Only
(Typ
) then
15972 Error_Pragma
("duplicate pragma%, only one allowed");
15974 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15975 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15977 end Finalize_Storage
;
15983 -- pragma Ghost [ (boolean_EXPRESSION) ];
15985 when Pragma_Ghost
=> Ghost
: declare
15989 Orig_Stmt
: Node_Id
;
15990 Prev_Id
: Entity_Id
;
15995 Check_No_Identifiers
;
15996 Check_At_Most_N_Arguments
(1);
16000 while Present
(Stmt
) loop
16002 -- Skip prior pragmas, but check for duplicates
16004 if Nkind
(Stmt
) = N_Pragma
then
16005 if Pragma_Name
(Stmt
) = Pname
then
16012 -- Task unit declared without a definition cannot be subject to
16013 -- pragma Ghost (SPARK RM 6.9(19)).
16015 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
16016 N_Task_Type_Declaration
)
16018 Error_Pragma
("pragma % cannot apply to a task type");
16021 -- Skip internally generated code
16023 elsif not Comes_From_Source
(Stmt
) then
16024 Orig_Stmt
:= Original_Node
(Stmt
);
16026 -- When pragma Ghost applies to an untagged derivation, the
16027 -- derivation is transformed into a [sub]type declaration.
16029 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
16030 N_Subtype_Declaration
)
16031 and then Comes_From_Source
(Orig_Stmt
)
16032 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
16033 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
16034 N_Derived_Type_Definition
16036 Id
:= Defining_Entity
(Stmt
);
16039 -- When pragma Ghost applies to an object declaration which
16040 -- is initialized by means of a function call that returns
16041 -- on the secondary stack, the object declaration becomes a
16044 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16045 and then Comes_From_Source
(Orig_Stmt
)
16046 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16048 Id
:= Defining_Entity
(Stmt
);
16051 -- When pragma Ghost applies to an expression function, the
16052 -- expression function is transformed into a subprogram.
16054 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16055 and then Comes_From_Source
(Orig_Stmt
)
16056 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16058 Id
:= Defining_Entity
(Stmt
);
16062 -- The pragma applies to a legal construct, stop the traversal
16064 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16065 N_Full_Type_Declaration
,
16066 N_Generic_Subprogram_Declaration
,
16067 N_Object_Declaration
,
16068 N_Private_Extension_Declaration
,
16069 N_Private_Type_Declaration
,
16070 N_Subprogram_Declaration
,
16071 N_Subtype_Declaration
)
16073 Id
:= Defining_Entity
(Stmt
);
16076 -- The pragma does not apply to a legal construct, issue an
16077 -- error and stop the analysis.
16081 ("pragma % must apply to an object, package, subprogram "
16086 Stmt
:= Prev
(Stmt
);
16089 Context
:= Parent
(N
);
16091 -- Handle compilation units
16093 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
16094 Context
:= Unit
(Parent
(Context
));
16097 -- Protected and task types cannot be subject to pragma Ghost
16098 -- (SPARK RM 6.9(19)).
16100 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
16102 Error_Pragma
("pragma % cannot apply to a protected type");
16105 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
16106 Error_Pragma
("pragma % cannot apply to a task type");
16112 -- When pragma Ghost is associated with a [generic] package, it
16113 -- appears in the visible declarations.
16115 if Nkind
(Context
) = N_Package_Specification
16116 and then Present
(Visible_Declarations
(Context
))
16117 and then List_Containing
(N
) = Visible_Declarations
(Context
)
16119 Id
:= Defining_Entity
(Context
);
16121 -- Pragma Ghost applies to a stand-alone subprogram body
16123 elsif Nkind
(Context
) = N_Subprogram_Body
16124 and then No
(Corresponding_Spec
(Context
))
16126 Id
:= Defining_Entity
(Context
);
16128 -- Pragma Ghost applies to a subprogram declaration that acts
16129 -- as a compilation unit.
16131 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
16132 Id
:= Defining_Entity
(Context
);
16134 -- Pragma Ghost applies to a generic subprogram
16136 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
16137 Id
:= Defining_Entity
(Specification
(Context
));
16143 ("pragma % must apply to an object, package, subprogram or "
16148 -- Handle completions of types and constants that are subject to
16151 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
16152 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
16154 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
16155 Error_Msg_Name_1
:= Pname
;
16157 -- The full declaration of a deferred constant cannot be
16158 -- subject to pragma Ghost unless the deferred declaration
16159 -- is also Ghost (SPARK RM 6.9(9)).
16161 if Ekind
(Prev_Id
) = E_Constant
then
16162 Error_Msg_Name_1
:= Pname
;
16163 Error_Msg_NE
(Fix_Error
16164 ("pragma % must apply to declaration of deferred "
16165 & "constant &"), N
, Id
);
16168 -- Pragma Ghost may appear on the full view of an incomplete
16169 -- type because the incomplete declaration lacks aspects and
16170 -- cannot be subject to pragma Ghost.
16172 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
16175 -- The full declaration of a type cannot be subject to
16176 -- pragma Ghost unless the partial view is also Ghost
16177 -- (SPARK RM 6.9(9)).
16180 Error_Msg_NE
(Fix_Error
16181 ("pragma % must apply to partial view of type &"),
16187 -- A synchronized object cannot be subject to pragma Ghost
16188 -- (SPARK RM 6.9(19)).
16190 elsif Ekind
(Id
) = E_Variable
then
16191 if Is_Protected_Type
(Etype
(Id
)) then
16192 Error_Pragma
("pragma % cannot apply to a protected object");
16195 elsif Is_Task_Type
(Etype
(Id
)) then
16196 Error_Pragma
("pragma % cannot apply to a task object");
16201 -- Analyze the Boolean expression (if any)
16203 if Present
(Arg1
) then
16204 Expr
:= Get_Pragma_Arg
(Arg1
);
16206 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
16208 if Is_OK_Static_Expression
(Expr
) then
16210 -- "Ghostness" cannot be turned off once enabled within a
16211 -- region (SPARK RM 6.9(6)).
16213 if Is_False
(Expr_Value
(Expr
))
16214 and then Ghost_Mode
> None
16217 ("pragma % with value False cannot appear in enabled "
16222 -- Otherwie the expression is not static
16226 ("expression of pragma % must be static", Expr
);
16231 Set_Is_Ghost_Entity
(Id
);
16238 -- pragma Global (GLOBAL_SPECIFICATION);
16240 -- GLOBAL_SPECIFICATION ::=
16243 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16245 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16247 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16248 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16249 -- GLOBAL_ITEM ::= NAME
16251 -- Characteristics:
16253 -- * Analysis - The annotation undergoes initial checks to verify
16254 -- the legal placement and context. Secondary checks fully analyze
16255 -- the dependency clauses in:
16257 -- Analyze_Global_In_Decl_Part
16259 -- * Expansion - None.
16261 -- * Template - The annotation utilizes the generic template of the
16262 -- related subprogram [body] when it is:
16264 -- aspect on subprogram declaration
16265 -- aspect on stand-alone subprogram body
16266 -- pragma on stand-alone subprogram body
16268 -- The annotation must prepare its own template when it is:
16270 -- pragma on subprogram declaration
16272 -- * Globals - Capture of global references must occur after full
16275 -- * Instance - The annotation is instantiated automatically when
16276 -- the related generic subprogram [body] is instantiated except for
16277 -- the "pragma on subprogram declaration" case. In that scenario
16278 -- the annotation must instantiate itself.
16280 when Pragma_Global
=> Global
: declare
16282 Spec_Id
: Entity_Id
;
16283 Subp_Decl
: Node_Id
;
16286 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16290 -- Chain the pragma on the contract for further processing by
16291 -- Analyze_Global_In_Decl_Part.
16293 Add_Contract_Item
(N
, Spec_Id
);
16295 -- Fully analyze the pragma when it appears inside an entry
16296 -- or subprogram body because it cannot benefit from forward
16299 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
16301 N_Subprogram_Body_Stub
)
16303 -- The legality checks of pragmas Depends and Global are
16304 -- affected by the SPARK mode in effect and the volatility
16305 -- of the context. In addition these two pragmas are subject
16306 -- to an inherent order:
16311 -- Analyze all these pragmas in the order outlined above
16313 Analyze_If_Present
(Pragma_SPARK_Mode
);
16314 Analyze_If_Present
(Pragma_Volatile_Function
);
16315 Analyze_Global_In_Decl_Part
(N
);
16316 Analyze_If_Present
(Pragma_Depends
);
16325 -- pragma Ident (static_string_EXPRESSION)
16327 -- Note: pragma Comment shares this processing. Pragma Ident is
16328 -- identical in effect to pragma Commment.
16330 when Pragma_Comment
16338 Check_Arg_Count
(1);
16339 Check_No_Identifiers
;
16340 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16343 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
16350 GP
:= Parent
(Parent
(N
));
16352 if Nkind_In
(GP
, N_Package_Declaration
,
16353 N_Generic_Package_Declaration
)
16358 -- If we have a compilation unit, then record the ident value,
16359 -- checking for improper duplication.
16361 if Nkind
(GP
) = N_Compilation_Unit
then
16362 CS
:= Ident_String
(Current_Sem_Unit
);
16364 if Present
(CS
) then
16366 -- If we have multiple instances, concatenate them, but
16367 -- not in ASIS, where we want the original tree.
16369 if not ASIS_Mode
then
16370 Start_String
(Strval
(CS
));
16371 Store_String_Char
(' ');
16372 Store_String_Chars
(Strval
(Str
));
16373 Set_Strval
(CS
, End_String
);
16377 Set_Ident_String
(Current_Sem_Unit
, Str
);
16380 -- For subunits, we just ignore the Ident, since in GNAT these
16381 -- are not separate object files, and hence not separate units
16382 -- in the unit table.
16384 elsif Nkind
(GP
) = N_Subunit
then
16390 -------------------
16391 -- Ignore_Pragma --
16392 -------------------
16394 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16396 -- Entirely handled in the parser, nothing to do here
16398 when Pragma_Ignore_Pragma
=>
16401 ----------------------------
16402 -- Implementation_Defined --
16403 ----------------------------
16405 -- pragma Implementation_Defined (LOCAL_NAME);
16407 -- Marks previously declared entity as implementation defined. For
16408 -- an overloaded entity, applies to the most recent homonym.
16410 -- pragma Implementation_Defined;
16412 -- The form with no arguments appears anywhere within a scope, most
16413 -- typically a package spec, and indicates that all entities that are
16414 -- defined within the package spec are Implementation_Defined.
16416 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
16421 Check_No_Identifiers
;
16423 -- Form with no arguments
16425 if Arg_Count
= 0 then
16426 Set_Is_Implementation_Defined
(Current_Scope
);
16428 -- Form with one argument
16431 Check_Arg_Count
(1);
16432 Check_Arg_Is_Local_Name
(Arg1
);
16433 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
16434 Set_Is_Implementation_Defined
(Ent
);
16436 end Implementation_Defined
;
16442 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
16444 -- IMPLEMENTATION_KIND ::=
16445 -- By_Entry | By_Protected_Procedure | By_Any | Optional
16447 -- "By_Any" and "Optional" are treated as synonyms in order to
16448 -- support Ada 2012 aspect Synchronization.
16450 when Pragma_Implemented
=> Implemented
: declare
16451 Proc_Id
: Entity_Id
;
16456 Check_Arg_Count
(2);
16457 Check_No_Identifiers
;
16458 Check_Arg_Is_Identifier
(Arg1
);
16459 Check_Arg_Is_Local_Name
(Arg1
);
16460 Check_Arg_Is_One_Of
(Arg2
,
16463 Name_By_Protected_Procedure
,
16466 -- Extract the name of the local procedure
16468 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16470 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16471 -- primitive procedure of a synchronized tagged type.
16473 if Ekind
(Proc_Id
) = E_Procedure
16474 and then Is_Primitive
(Proc_Id
)
16475 and then Present
(First_Formal
(Proc_Id
))
16477 Typ
:= Etype
(First_Formal
(Proc_Id
));
16479 if Is_Tagged_Type
(Typ
)
16482 -- Check for a protected, a synchronized or a task interface
16484 ((Is_Interface
(Typ
)
16485 and then Is_Synchronized_Interface
(Typ
))
16487 -- Check for a protected type or a task type that implements
16491 (Is_Concurrent_Record_Type
(Typ
)
16492 and then Present
(Interfaces
(Typ
)))
16494 -- In analysis-only mode, examine original protected type
16497 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
16498 and then Present
(Interface_List
(Parent
(Typ
))))
16500 -- Check for a private record extension with keyword
16504 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
16505 E_Record_Subtype_With_Private
)
16506 and then Synchronized_Present
(Parent
(Typ
))))
16511 ("controlling formal must be of synchronized tagged type",
16516 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16517 -- By_Protected_Procedure to the primitive procedure of a task
16520 if Chars
(Arg2
) = Name_By_Protected_Procedure
16521 and then Is_Interface
(Typ
)
16522 and then Is_Task_Interface
(Typ
)
16525 ("implementation kind By_Protected_Procedure cannot be "
16526 & "applied to a task interface primitive", Arg2
);
16530 -- Procedures declared inside a protected type must be accepted
16532 elsif Ekind
(Proc_Id
) = E_Procedure
16533 and then Is_Protected_Type
(Scope
(Proc_Id
))
16537 -- The first argument is not a primitive procedure
16541 ("pragma % must be applied to a primitive procedure", Arg1
);
16545 Record_Rep_Item
(Proc_Id
, N
);
16548 ----------------------
16549 -- Implicit_Packing --
16550 ----------------------
16552 -- pragma Implicit_Packing;
16554 when Pragma_Implicit_Packing
=>
16556 Check_Arg_Count
(0);
16557 Implicit_Packing
:= True;
16564 -- [Convention =>] convention_IDENTIFIER,
16565 -- [Entity =>] LOCAL_NAME
16566 -- [, [External_Name =>] static_string_EXPRESSION ]
16567 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16569 when Pragma_Import
=>
16570 Check_Ada_83_Warning
;
16574 Name_External_Name
,
16577 Check_At_Least_N_Arguments
(2);
16578 Check_At_Most_N_Arguments
(4);
16579 Process_Import_Or_Interface
;
16581 ---------------------
16582 -- Import_Function --
16583 ---------------------
16585 -- pragma Import_Function (
16586 -- [Internal =>] LOCAL_NAME,
16587 -- [, [External =>] EXTERNAL_SYMBOL]
16588 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16589 -- [, [Result_Type =>] SUBTYPE_MARK]
16590 -- [, [Mechanism =>] MECHANISM]
16591 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16593 -- EXTERNAL_SYMBOL ::=
16595 -- | static_string_EXPRESSION
16597 -- PARAMETER_TYPES ::=
16599 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16601 -- TYPE_DESIGNATOR ::=
16603 -- | subtype_Name ' Access
16607 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16609 -- MECHANISM_ASSOCIATION ::=
16610 -- [formal_parameter_NAME =>] MECHANISM_NAME
16612 -- MECHANISM_NAME ::=
16616 when Pragma_Import_Function
=> Import_Function
: declare
16617 Args
: Args_List
(1 .. 6);
16618 Names
: constant Name_List
(1 .. 6) := (
16621 Name_Parameter_Types
,
16624 Name_Result_Mechanism
);
16626 Internal
: Node_Id
renames Args
(1);
16627 External
: Node_Id
renames Args
(2);
16628 Parameter_Types
: Node_Id
renames Args
(3);
16629 Result_Type
: Node_Id
renames Args
(4);
16630 Mechanism
: Node_Id
renames Args
(5);
16631 Result_Mechanism
: Node_Id
renames Args
(6);
16635 Gather_Associations
(Names
, Args
);
16636 Process_Extended_Import_Export_Subprogram_Pragma
(
16637 Arg_Internal
=> Internal
,
16638 Arg_External
=> External
,
16639 Arg_Parameter_Types
=> Parameter_Types
,
16640 Arg_Result_Type
=> Result_Type
,
16641 Arg_Mechanism
=> Mechanism
,
16642 Arg_Result_Mechanism
=> Result_Mechanism
);
16643 end Import_Function
;
16645 -------------------
16646 -- Import_Object --
16647 -------------------
16649 -- pragma Import_Object (
16650 -- [Internal =>] LOCAL_NAME
16651 -- [, [External =>] EXTERNAL_SYMBOL]
16652 -- [, [Size =>] EXTERNAL_SYMBOL]);
16654 -- EXTERNAL_SYMBOL ::=
16656 -- | static_string_EXPRESSION
16658 when Pragma_Import_Object
=> Import_Object
: declare
16659 Args
: Args_List
(1 .. 3);
16660 Names
: constant Name_List
(1 .. 3) := (
16665 Internal
: Node_Id
renames Args
(1);
16666 External
: Node_Id
renames Args
(2);
16667 Size
: Node_Id
renames Args
(3);
16671 Gather_Associations
(Names
, Args
);
16672 Process_Extended_Import_Export_Object_Pragma
(
16673 Arg_Internal
=> Internal
,
16674 Arg_External
=> External
,
16678 ----------------------
16679 -- Import_Procedure --
16680 ----------------------
16682 -- pragma Import_Procedure (
16683 -- [Internal =>] LOCAL_NAME
16684 -- [, [External =>] EXTERNAL_SYMBOL]
16685 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16686 -- [, [Mechanism =>] MECHANISM]);
16688 -- EXTERNAL_SYMBOL ::=
16690 -- | static_string_EXPRESSION
16692 -- PARAMETER_TYPES ::=
16694 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16696 -- TYPE_DESIGNATOR ::=
16698 -- | subtype_Name ' Access
16702 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16704 -- MECHANISM_ASSOCIATION ::=
16705 -- [formal_parameter_NAME =>] MECHANISM_NAME
16707 -- MECHANISM_NAME ::=
16711 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16712 Args
: Args_List
(1 .. 4);
16713 Names
: constant Name_List
(1 .. 4) := (
16716 Name_Parameter_Types
,
16719 Internal
: Node_Id
renames Args
(1);
16720 External
: Node_Id
renames Args
(2);
16721 Parameter_Types
: Node_Id
renames Args
(3);
16722 Mechanism
: Node_Id
renames Args
(4);
16726 Gather_Associations
(Names
, Args
);
16727 Process_Extended_Import_Export_Subprogram_Pragma
(
16728 Arg_Internal
=> Internal
,
16729 Arg_External
=> External
,
16730 Arg_Parameter_Types
=> Parameter_Types
,
16731 Arg_Mechanism
=> Mechanism
);
16732 end Import_Procedure
;
16734 -----------------------------
16735 -- Import_Valued_Procedure --
16736 -----------------------------
16738 -- pragma Import_Valued_Procedure (
16739 -- [Internal =>] LOCAL_NAME
16740 -- [, [External =>] EXTERNAL_SYMBOL]
16741 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16742 -- [, [Mechanism =>] MECHANISM]);
16744 -- EXTERNAL_SYMBOL ::=
16746 -- | static_string_EXPRESSION
16748 -- PARAMETER_TYPES ::=
16750 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16752 -- TYPE_DESIGNATOR ::=
16754 -- | subtype_Name ' Access
16758 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16760 -- MECHANISM_ASSOCIATION ::=
16761 -- [formal_parameter_NAME =>] MECHANISM_NAME
16763 -- MECHANISM_NAME ::=
16767 when Pragma_Import_Valued_Procedure
=>
16768 Import_Valued_Procedure
: declare
16769 Args
: Args_List
(1 .. 4);
16770 Names
: constant Name_List
(1 .. 4) := (
16773 Name_Parameter_Types
,
16776 Internal
: Node_Id
renames Args
(1);
16777 External
: Node_Id
renames Args
(2);
16778 Parameter_Types
: Node_Id
renames Args
(3);
16779 Mechanism
: Node_Id
renames Args
(4);
16783 Gather_Associations
(Names
, Args
);
16784 Process_Extended_Import_Export_Subprogram_Pragma
(
16785 Arg_Internal
=> Internal
,
16786 Arg_External
=> External
,
16787 Arg_Parameter_Types
=> Parameter_Types
,
16788 Arg_Mechanism
=> Mechanism
);
16789 end Import_Valued_Procedure
;
16795 -- pragma Independent (LOCAL_NAME);
16797 when Pragma_Independent
=>
16798 Process_Atomic_Independent_Shared_Volatile
;
16800 ----------------------------
16801 -- Independent_Components --
16802 ----------------------------
16804 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16806 when Pragma_Independent_Components
=> Independent_Components
: declare
16814 Check_Ada_83_Warning
;
16816 Check_No_Identifiers
;
16817 Check_Arg_Count
(1);
16818 Check_Arg_Is_Local_Name
(Arg1
);
16819 E_Id
:= Get_Pragma_Arg
(Arg1
);
16821 if Etype
(E_Id
) = Any_Type
then
16825 E
:= Entity
(E_Id
);
16827 -- A pragma that applies to a Ghost entity becomes Ghost for the
16828 -- purposes of legality checks and removal of ignored Ghost code.
16830 Mark_Ghost_Pragma
(N
, E
);
16832 -- Check duplicate before we chain ourselves
16834 Check_Duplicate_Pragma
(E
);
16836 -- Check appropriate entity
16838 if Rep_Item_Too_Early
(E
, N
)
16840 Rep_Item_Too_Late
(E
, N
)
16845 D
:= Declaration_Node
(E
);
16848 -- The flag is set on the base type, or on the object
16850 if K
= N_Full_Type_Declaration
16851 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16853 Set_Has_Independent_Components
(Base_Type
(E
));
16854 Record_Independence_Check
(N
, Base_Type
(E
));
16856 -- For record type, set all components independent
16858 if Is_Record_Type
(E
) then
16859 C
:= First_Component
(E
);
16860 while Present
(C
) loop
16861 Set_Is_Independent
(C
);
16862 Next_Component
(C
);
16866 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16867 and then Nkind
(D
) = N_Object_Declaration
16868 and then Nkind
(Object_Definition
(D
)) =
16869 N_Constrained_Array_Definition
16871 Set_Has_Independent_Components
(E
);
16872 Record_Independence_Check
(N
, E
);
16875 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16877 end Independent_Components
;
16879 -----------------------
16880 -- Initial_Condition --
16881 -----------------------
16883 -- pragma Initial_Condition (boolean_EXPRESSION);
16885 -- Characteristics:
16887 -- * Analysis - The annotation undergoes initial checks to verify
16888 -- the legal placement and context. Secondary checks preanalyze the
16891 -- Analyze_Initial_Condition_In_Decl_Part
16893 -- * Expansion - The annotation is expanded during the expansion of
16894 -- the package body whose declaration is subject to the annotation
16897 -- Expand_Pragma_Initial_Condition
16899 -- * Template - The annotation utilizes the generic template of the
16900 -- related package declaration.
16902 -- * Globals - Capture of global references must occur after full
16905 -- * Instance - The annotation is instantiated automatically when
16906 -- the related generic package is instantiated.
16908 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16909 Pack_Decl
: Node_Id
;
16910 Pack_Id
: Entity_Id
;
16914 Check_No_Identifiers
;
16915 Check_Arg_Count
(1);
16917 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16919 -- Ensure the proper placement of the pragma. Initial_Condition
16920 -- must be associated with a package declaration.
16922 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16923 N_Package_Declaration
)
16927 -- Otherwise the pragma is associated with an illegal context
16934 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16936 -- A pragma that applies to a Ghost entity becomes Ghost for the
16937 -- purposes of legality checks and removal of ignored Ghost code.
16939 Mark_Ghost_Pragma
(N
, Pack_Id
);
16941 -- Chain the pragma on the contract for further processing by
16942 -- Analyze_Initial_Condition_In_Decl_Part.
16944 Add_Contract_Item
(N
, Pack_Id
);
16946 -- The legality checks of pragmas Abstract_State, Initializes, and
16947 -- Initial_Condition are affected by the SPARK mode in effect. In
16948 -- addition, these three pragmas are subject to an inherent order:
16950 -- 1) Abstract_State
16952 -- 3) Initial_Condition
16954 -- Analyze all these pragmas in the order outlined above
16956 Analyze_If_Present
(Pragma_SPARK_Mode
);
16957 Analyze_If_Present
(Pragma_Abstract_State
);
16958 Analyze_If_Present
(Pragma_Initializes
);
16959 end Initial_Condition
;
16961 ------------------------
16962 -- Initialize_Scalars --
16963 ------------------------
16965 -- pragma Initialize_Scalars;
16967 when Pragma_Initialize_Scalars
=>
16969 Check_Arg_Count
(0);
16970 Check_Valid_Configuration_Pragma
;
16971 Check_Restriction
(No_Initialize_Scalars
, N
);
16973 -- Initialize_Scalars creates false positives in CodePeer, and
16974 -- incorrect negative results in GNATprove mode, so ignore this
16975 -- pragma in these modes.
16977 if not Restriction_Active
(No_Initialize_Scalars
)
16978 and then not (CodePeer_Mode
or GNATprove_Mode
)
16980 Init_Or_Norm_Scalars
:= True;
16981 Initialize_Scalars
:= True;
16988 -- pragma Initializes (INITIALIZATION_LIST);
16990 -- INITIALIZATION_LIST ::=
16992 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16994 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16999 -- | (INPUT {, INPUT})
17003 -- Characteristics:
17005 -- * Analysis - The annotation undergoes initial checks to verify
17006 -- the legal placement and context. Secondary checks preanalyze the
17009 -- Analyze_Initializes_In_Decl_Part
17011 -- * Expansion - None.
17013 -- * Template - The annotation utilizes the generic template of the
17014 -- related package declaration.
17016 -- * Globals - Capture of global references must occur after full
17019 -- * Instance - The annotation is instantiated automatically when
17020 -- the related generic package is instantiated.
17022 when Pragma_Initializes
=> Initializes
: declare
17023 Pack_Decl
: Node_Id
;
17024 Pack_Id
: Entity_Id
;
17028 Check_No_Identifiers
;
17029 Check_Arg_Count
(1);
17031 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
17033 -- Ensure the proper placement of the pragma. Initializes must be
17034 -- associated with a package declaration.
17036 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
17037 N_Package_Declaration
)
17041 -- Otherwise the pragma is associated with an illegal construc
17048 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17050 -- A pragma that applies to a Ghost entity becomes Ghost for the
17051 -- purposes of legality checks and removal of ignored Ghost code.
17053 Mark_Ghost_Pragma
(N
, Pack_Id
);
17054 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
17056 -- Chain the pragma on the contract for further processing by
17057 -- Analyze_Initializes_In_Decl_Part.
17059 Add_Contract_Item
(N
, Pack_Id
);
17061 -- The legality checks of pragmas Abstract_State, Initializes, and
17062 -- Initial_Condition are affected by the SPARK mode in effect. In
17063 -- addition, these three pragmas are subject to an inherent order:
17065 -- 1) Abstract_State
17067 -- 3) Initial_Condition
17069 -- Analyze all these pragmas in the order outlined above
17071 Analyze_If_Present
(Pragma_SPARK_Mode
);
17072 Analyze_If_Present
(Pragma_Abstract_State
);
17073 Analyze_If_Present
(Pragma_Initial_Condition
);
17080 -- pragma Inline ( NAME {, NAME} );
17082 when Pragma_Inline
=>
17084 -- Pragma always active unless in GNATprove mode. It is disabled
17085 -- in GNATprove mode because frontend inlining is applied
17086 -- independently of pragmas Inline and Inline_Always for
17087 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
17090 if not GNATprove_Mode
then
17092 -- Inline status is Enabled if option -gnatn is specified.
17093 -- However this status determines only the value of the
17094 -- Is_Inlined flag on the subprogram and does not prevent
17095 -- the pragma itself from being recorded for later use,
17096 -- in particular for a later modification of Is_Inlined
17097 -- independently of the -gnatn option.
17099 -- In other words, if -gnatn is specified for a unit, then
17100 -- all Inline pragmas processed for the compilation of this
17101 -- unit, including those in the spec of other units, are
17102 -- activated, so subprograms will be inlined across units.
17104 -- If -gnatn is not specified, no Inline pragma is activated
17105 -- here, which means that subprograms will not be inlined
17106 -- across units. The Is_Inlined flag will nevertheless be
17107 -- set later when bodies are analyzed, so subprograms will
17108 -- be inlined within the unit.
17110 if Inline_Active
then
17111 Process_Inline
(Enabled
);
17113 Process_Inline
(Disabled
);
17117 -------------------
17118 -- Inline_Always --
17119 -------------------
17121 -- pragma Inline_Always ( NAME {, NAME} );
17123 when Pragma_Inline_Always
=>
17126 -- Pragma always active unless in CodePeer mode or GNATprove
17127 -- mode. It is disabled in CodePeer mode because inlining is
17128 -- not helpful, and enabling it caused walk order issues. It
17129 -- is disabled in GNATprove mode because frontend inlining is
17130 -- applied independently of pragmas Inline and Inline_Always for
17131 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
17134 if not CodePeer_Mode
and not GNATprove_Mode
then
17135 Process_Inline
(Enabled
);
17138 --------------------
17139 -- Inline_Generic --
17140 --------------------
17142 -- pragma Inline_Generic (NAME {, NAME});
17144 when Pragma_Inline_Generic
=>
17146 Process_Generic_List
;
17148 ----------------------
17149 -- Inspection_Point --
17150 ----------------------
17152 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
17154 when Pragma_Inspection_Point
=> Inspection_Point
: declare
17161 if Arg_Count
> 0 then
17164 Exp
:= Get_Pragma_Arg
(Arg
);
17167 if not Is_Entity_Name
(Exp
)
17168 or else not Is_Object
(Entity
(Exp
))
17170 Error_Pragma_Arg
("object name required", Arg
);
17174 exit when No
(Arg
);
17177 end Inspection_Point
;
17183 -- pragma Interface (
17184 -- [ Convention =>] convention_IDENTIFIER,
17185 -- [ Entity =>] LOCAL_NAME
17186 -- [, [External_Name =>] static_string_EXPRESSION ]
17187 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17189 when Pragma_Interface
=>
17194 Name_External_Name
,
17196 Check_At_Least_N_Arguments
(2);
17197 Check_At_Most_N_Arguments
(4);
17198 Process_Import_Or_Interface
;
17200 -- In Ada 2005, the permission to use Interface (a reserved word)
17201 -- as a pragma name is considered an obsolescent feature, and this
17202 -- pragma was already obsolescent in Ada 95.
17204 if Ada_Version
>= Ada_95
then
17206 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
17208 if Warn_On_Obsolescent_Feature
then
17210 ("pragma Interface is an obsolescent feature?j?", N
);
17212 ("|use pragma Import instead?j?", N
);
17216 --------------------
17217 -- Interface_Name --
17218 --------------------
17220 -- pragma Interface_Name (
17221 -- [ Entity =>] LOCAL_NAME
17222 -- [,[External_Name =>] static_string_EXPRESSION ]
17223 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17225 when Pragma_Interface_Name
=> Interface_Name
: declare
17227 Def_Id
: Entity_Id
;
17228 Hom_Id
: Entity_Id
;
17234 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
17235 Check_At_Least_N_Arguments
(2);
17236 Check_At_Most_N_Arguments
(3);
17237 Id
:= Get_Pragma_Arg
(Arg1
);
17240 -- This is obsolete from Ada 95 on, but it is an implementation
17241 -- defined pragma, so we do not consider that it violates the
17242 -- restriction (No_Obsolescent_Features).
17244 if Ada_Version
>= Ada_95
then
17245 if Warn_On_Obsolescent_Feature
then
17247 ("pragma Interface_Name is an obsolescent feature?j?", N
);
17249 ("|use pragma Import instead?j?", N
);
17253 if not Is_Entity_Name
(Id
) then
17255 ("first argument for pragma% must be entity name", Arg1
);
17256 elsif Etype
(Id
) = Any_Type
then
17259 Def_Id
:= Entity
(Id
);
17262 -- Special DEC-compatible processing for the object case, forces
17263 -- object to be imported.
17265 if Ekind
(Def_Id
) = E_Variable
then
17266 Kill_Size_Check_Code
(Def_Id
);
17267 Note_Possible_Modification
(Id
, Sure
=> False);
17269 -- Initialization is not allowed for imported variable
17271 if Present
(Expression
(Parent
(Def_Id
)))
17272 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
17274 Error_Msg_Sloc
:= Sloc
(Def_Id
);
17276 ("no initialization allowed for declaration of& #",
17280 -- For compatibility, support VADS usage of providing both
17281 -- pragmas Interface and Interface_Name to obtain the effect
17282 -- of a single Import pragma.
17284 if Is_Imported
(Def_Id
)
17285 and then Present
(First_Rep_Item
(Def_Id
))
17286 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
17287 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
17292 Set_Imported
(Def_Id
);
17295 Set_Is_Public
(Def_Id
);
17296 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17299 -- Otherwise must be subprogram
17301 elsif not Is_Subprogram
(Def_Id
) then
17303 ("argument of pragma% is not subprogram", Arg1
);
17306 Check_At_Most_N_Arguments
(3);
17310 -- Loop through homonyms
17313 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
17315 if Is_Imported
(Def_Id
) then
17316 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17320 exit when From_Aspect_Specification
(N
);
17321 Hom_Id
:= Homonym
(Hom_Id
);
17323 exit when No
(Hom_Id
)
17324 or else Scope
(Hom_Id
) /= Current_Scope
;
17329 ("argument of pragma% is not imported subprogram",
17333 end Interface_Name
;
17335 -----------------------
17336 -- Interrupt_Handler --
17337 -----------------------
17339 -- pragma Interrupt_Handler (handler_NAME);
17341 when Pragma_Interrupt_Handler
=>
17342 Check_Ada_83_Warning
;
17343 Check_Arg_Count
(1);
17344 Check_No_Identifiers
;
17346 if No_Run_Time_Mode
then
17347 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
17349 Check_Interrupt_Or_Attach_Handler
;
17350 Process_Interrupt_Or_Attach_Handler
;
17353 ------------------------
17354 -- Interrupt_Priority --
17355 ------------------------
17357 -- pragma Interrupt_Priority [(EXPRESSION)];
17359 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
17360 P
: constant Node_Id
:= Parent
(N
);
17365 Check_Ada_83_Warning
;
17367 if Arg_Count
/= 0 then
17368 Arg
:= Get_Pragma_Arg
(Arg1
);
17369 Check_Arg_Count
(1);
17370 Check_No_Identifiers
;
17372 -- The expression must be analyzed in the special manner
17373 -- described in "Handling of Default and Per-Object
17374 -- Expressions" in sem.ads.
17376 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
17379 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
17384 Ent
:= Defining_Identifier
(Parent
(P
));
17386 -- Check duplicate pragma before we chain the pragma in the Rep
17387 -- Item chain of Ent.
17389 Check_Duplicate_Pragma
(Ent
);
17390 Record_Rep_Item
(Ent
, N
);
17392 -- Check the No_Task_At_Interrupt_Priority restriction
17394 if Nkind
(P
) = N_Task_Definition
then
17395 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
17398 end Interrupt_Priority
;
17400 ---------------------
17401 -- Interrupt_State --
17402 ---------------------
17404 -- pragma Interrupt_State (
17405 -- [Name =>] INTERRUPT_ID,
17406 -- [State =>] INTERRUPT_STATE);
17408 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
17409 -- INTERRUPT_STATE => System | Runtime | User
17411 -- Note: if the interrupt id is given as an identifier, then it must
17412 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
17413 -- given as a static integer expression which must be in the range of
17414 -- Ada.Interrupts.Interrupt_ID.
17416 when Pragma_Interrupt_State
=> Interrupt_State
: declare
17417 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
17418 -- This is the entity Ada.Interrupts.Interrupt_ID;
17420 State_Type
: Character;
17421 -- Set to 's'/'r'/'u' for System/Runtime/User
17424 -- Index to entry in Interrupt_States table
17427 -- Value of interrupt
17429 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17430 -- The first argument to the pragma
17432 Int_Ent
: Entity_Id
;
17433 -- Interrupt entity in Ada.Interrupts.Names
17437 Check_Arg_Order
((Name_Name
, Name_State
));
17438 Check_Arg_Count
(2);
17440 Check_Optional_Identifier
(Arg1
, Name_Name
);
17441 Check_Optional_Identifier
(Arg2
, Name_State
);
17442 Check_Arg_Is_Identifier
(Arg2
);
17444 -- First argument is identifier
17446 if Nkind
(Arg1X
) = N_Identifier
then
17448 -- Search list of names in Ada.Interrupts.Names
17450 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
17452 if No
(Int_Ent
) then
17453 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
17455 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
17456 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
17460 Next_Entity
(Int_Ent
);
17463 -- First argument is not an identifier, so it must be a static
17464 -- expression of type Ada.Interrupts.Interrupt_ID.
17467 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
17468 Int_Val
:= Expr_Value
(Arg1X
);
17470 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
17472 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
17475 ("value not in range of type "
17476 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
17482 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17483 when Name_Runtime
=> State_Type
:= 'r';
17484 when Name_System
=> State_Type
:= 's';
17485 when Name_User
=> State_Type
:= 'u';
17488 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
17491 -- Check if entry is already stored
17493 IST_Num
:= Interrupt_States
.First
;
17495 -- If entry not found, add it
17497 if IST_Num
> Interrupt_States
.Last
then
17498 Interrupt_States
.Append
17499 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
17500 Interrupt_State
=> State_Type
,
17501 Pragma_Loc
=> Loc
));
17504 -- Case of entry for the same entry
17506 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
17509 -- If state matches, done, no need to make redundant entry
17512 State_Type
= Interrupt_States
.Table
(IST_Num
).
17515 -- Otherwise if state does not match, error
17518 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
17520 ("state conflicts with that given #", Arg2
);
17524 IST_Num
:= IST_Num
+ 1;
17526 end Interrupt_State
;
17532 -- pragma Invariant
17533 -- ([Entity =>] type_LOCAL_NAME,
17534 -- [Check =>] EXPRESSION
17535 -- [,[Message =>] String_Expression]);
17537 when Pragma_Invariant
=> Invariant
: declare
17544 Check_At_Least_N_Arguments
(2);
17545 Check_At_Most_N_Arguments
(3);
17546 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17547 Check_Optional_Identifier
(Arg2
, Name_Check
);
17549 if Arg_Count
= 3 then
17550 Check_Optional_Identifier
(Arg3
, Name_Message
);
17551 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
17554 Check_Arg_Is_Local_Name
(Arg1
);
17556 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
17557 Find_Type
(Typ_Arg
);
17558 Typ
:= Entity
(Typ_Arg
);
17560 -- Nothing to do of the related type is erroneous in some way
17562 if Typ
= Any_Type
then
17565 -- AI12-0041: Invariants are allowed in interface types
17567 elsif Is_Interface
(Typ
) then
17570 -- An invariant must apply to a private type, or appear in the
17571 -- private part of a package spec and apply to a completion.
17572 -- a class-wide invariant can only appear on a private declaration
17573 -- or private extension, not a completion.
17575 -- A [class-wide] invariant may be associated a [limited] private
17576 -- type or a private extension.
17578 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
17580 E_Record_Type_With_Private
)
17584 -- A non-class-wide invariant may be associated with the full view
17585 -- of a [limited] private type or a private extension.
17587 elsif Has_Private_Declaration
(Typ
)
17588 and then not Class_Present
(N
)
17592 -- A class-wide invariant may appear on the partial view only
17594 elsif Class_Present
(N
) then
17596 ("pragma % only allowed for private type", Arg1
);
17599 -- A regular invariant may appear on both views
17603 ("pragma % only allowed for private type or corresponding "
17604 & "full view", Arg1
);
17608 -- An invariant associated with an abstract type (this includes
17609 -- interfaces) must be class-wide.
17611 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
17613 ("pragma % not allowed for abstract type", Arg1
);
17617 -- A pragma that applies to a Ghost entity becomes Ghost for the
17618 -- purposes of legality checks and removal of ignored Ghost code.
17620 Mark_Ghost_Pragma
(N
, Typ
);
17622 -- The pragma defines a type-specific invariant, the type is said
17623 -- to have invariants of its "own".
17625 Set_Has_Own_Invariants
(Typ
);
17627 -- If the invariant is class-wide, then it can be inherited by
17628 -- derived or interface implementing types. The type is said to
17629 -- have "inheritable" invariants.
17631 if Class_Present
(N
) then
17632 Set_Has_Inheritable_Invariants
(Typ
);
17635 -- Chain the pragma on to the rep item chain, for processing when
17636 -- the type is frozen.
17638 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17640 -- Create the declaration of the invariant procedure that will
17641 -- verify the invariant at run time. Interfaces are treated as the
17642 -- partial view of a private type in order to achieve uniformity
17643 -- with the general case. As a result, an interface receives only
17644 -- a "partial" invariant procedure, which is never called.
17646 Build_Invariant_Procedure_Declaration
17648 Partial_Invariant
=> Is_Interface
(Typ
));
17655 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17657 when Pragma_Keep_Names
=> Keep_Names
: declare
17662 Check_Arg_Count
(1);
17663 Check_Optional_Identifier
(Arg1
, Name_On
);
17664 Check_Arg_Is_Local_Name
(Arg1
);
17666 Arg
:= Get_Pragma_Arg
(Arg1
);
17669 if Etype
(Arg
) = Any_Type
then
17673 if not Is_Entity_Name
(Arg
)
17674 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
17677 ("pragma% requires a local enumeration type", Arg1
);
17680 Set_Discard_Names
(Entity
(Arg
), False);
17687 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17689 when Pragma_License
=>
17692 -- Do not analyze pragma any further in CodePeer mode, to avoid
17693 -- extraneous errors in this implementation-dependent pragma,
17694 -- which has a different profile on other compilers.
17696 if CodePeer_Mode
then
17700 Check_Arg_Count
(1);
17701 Check_No_Identifiers
;
17702 Check_Valid_Configuration_Pragma
;
17703 Check_Arg_Is_Identifier
(Arg1
);
17706 Sind
: constant Source_File_Index
:=
17707 Source_Index
(Current_Sem_Unit
);
17710 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17712 Set_License
(Sind
, GPL
);
17714 when Name_Modified_GPL
=>
17715 Set_License
(Sind
, Modified_GPL
);
17717 when Name_Restricted
=>
17718 Set_License
(Sind
, Restricted
);
17720 when Name_Unrestricted
=>
17721 Set_License
(Sind
, Unrestricted
);
17724 Error_Pragma_Arg
("invalid license name", Arg1
);
17732 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17734 when Pragma_Link_With
=> Link_With
: declare
17740 if Operating_Mode
= Generate_Code
17741 and then In_Extended_Main_Source_Unit
(N
)
17743 Check_At_Least_N_Arguments
(1);
17744 Check_No_Identifiers
;
17745 Check_Is_In_Decl_Part_Or_Package_Spec
;
17746 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17750 while Present
(Arg
) loop
17751 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17753 -- Store argument, converting sequences of spaces to a
17754 -- single null character (this is one of the differences
17755 -- in processing between Link_With and Linker_Options).
17757 Arg_Store
: declare
17758 C
: constant Char_Code
:= Get_Char_Code
(' ');
17759 S
: constant String_Id
:=
17760 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17761 L
: constant Nat
:= String_Length
(S
);
17764 procedure Skip_Spaces
;
17765 -- Advance F past any spaces
17771 procedure Skip_Spaces
is
17773 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17778 -- Start of processing for Arg_Store
17781 Skip_Spaces
; -- skip leading spaces
17783 -- Loop through characters, changing any embedded
17784 -- sequence of spaces to a single null character (this
17785 -- is how Link_With/Linker_Options differ)
17788 if Get_String_Char
(S
, F
) = C
then
17791 Store_String_Char
(ASCII
.NUL
);
17794 Store_String_Char
(Get_String_Char
(S
, F
));
17802 if Present
(Arg
) then
17803 Store_String_Char
(ASCII
.NUL
);
17807 Store_Linker_Option_String
(End_String
);
17815 -- pragma Linker_Alias (
17816 -- [Entity =>] LOCAL_NAME
17817 -- [Target =>] static_string_EXPRESSION);
17819 when Pragma_Linker_Alias
=>
17821 Check_Arg_Order
((Name_Entity
, Name_Target
));
17822 Check_Arg_Count
(2);
17823 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17824 Check_Optional_Identifier
(Arg2
, Name_Target
);
17825 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17826 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17828 -- The only processing required is to link this item on to the
17829 -- list of rep items for the given entity. This is accomplished
17830 -- by the call to Rep_Item_Too_Late (when no error is detected
17831 -- and False is returned).
17833 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17836 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17839 ------------------------
17840 -- Linker_Constructor --
17841 ------------------------
17843 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17845 -- Code is shared with Linker_Destructor
17847 -----------------------
17848 -- Linker_Destructor --
17849 -----------------------
17851 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17853 when Pragma_Linker_Constructor
17854 | Pragma_Linker_Destructor
17856 Linker_Constructor
: declare
17862 Check_Arg_Count
(1);
17863 Check_No_Identifiers
;
17864 Check_Arg_Is_Local_Name
(Arg1
);
17865 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17867 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17869 if not Is_Library_Level_Entity
(Proc
) then
17871 ("argument for pragma% must be library level entity", Arg1
);
17874 -- The only processing required is to link this item on to the
17875 -- list of rep items for the given entity. This is accomplished
17876 -- by the call to Rep_Item_Too_Late (when no error is detected
17877 -- and False is returned).
17879 if Rep_Item_Too_Late
(Proc
, N
) then
17882 Set_Has_Gigi_Rep_Item
(Proc
);
17884 end Linker_Constructor
;
17886 --------------------
17887 -- Linker_Options --
17888 --------------------
17890 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17892 when Pragma_Linker_Options
=> Linker_Options
: declare
17896 Check_Ada_83_Warning
;
17897 Check_No_Identifiers
;
17898 Check_Arg_Count
(1);
17899 Check_Is_In_Decl_Part_Or_Package_Spec
;
17900 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17901 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17904 while Present
(Arg
) loop
17905 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17906 Store_String_Char
(ASCII
.NUL
);
17908 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17912 if Operating_Mode
= Generate_Code
17913 and then In_Extended_Main_Source_Unit
(N
)
17915 Store_Linker_Option_String
(End_String
);
17917 end Linker_Options
;
17919 --------------------
17920 -- Linker_Section --
17921 --------------------
17923 -- pragma Linker_Section (
17924 -- [Entity =>] LOCAL_NAME
17925 -- [Section =>] static_string_EXPRESSION);
17927 when Pragma_Linker_Section
=> Linker_Section
: declare
17932 Ghost_Error_Posted
: Boolean := False;
17933 -- Flag set when an error concerning the illegal mix of Ghost and
17934 -- non-Ghost subprograms is emitted.
17936 Ghost_Id
: Entity_Id
:= Empty
;
17937 -- The entity of the first Ghost subprogram encountered while
17938 -- processing the arguments of the pragma.
17942 Check_Arg_Order
((Name_Entity
, Name_Section
));
17943 Check_Arg_Count
(2);
17944 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17945 Check_Optional_Identifier
(Arg2
, Name_Section
);
17946 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17947 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17949 -- Check kind of entity
17951 Arg
:= Get_Pragma_Arg
(Arg1
);
17952 Ent
:= Entity
(Arg
);
17954 case Ekind
(Ent
) is
17956 -- Objects (constants and variables) and types. For these cases
17957 -- all we need to do is to set the Linker_Section_pragma field,
17958 -- checking that we do not have a duplicate.
17964 LPE
:= Linker_Section_Pragma
(Ent
);
17966 if Present
(LPE
) then
17967 Error_Msg_Sloc
:= Sloc
(LPE
);
17969 ("Linker_Section already specified for &#", Arg1
, Ent
);
17972 Set_Linker_Section_Pragma
(Ent
, N
);
17974 -- A pragma that applies to a Ghost entity becomes Ghost for
17975 -- the purposes of legality checks and removal of ignored
17978 Mark_Ghost_Pragma
(N
, Ent
);
17982 when Subprogram_Kind
=>
17984 -- Aspect case, entity already set
17986 if From_Aspect_Specification
(N
) then
17987 Set_Linker_Section_Pragma
17988 (Entity
(Corresponding_Aspect
(N
)), N
);
17990 -- Pragma case, we must climb the homonym chain, but skip
17991 -- any for which the linker section is already set.
17995 if No
(Linker_Section_Pragma
(Ent
)) then
17996 Set_Linker_Section_Pragma
(Ent
, N
);
17998 -- A pragma that applies to a Ghost entity becomes
17999 -- Ghost for the purposes of legality checks and
18000 -- removal of ignored Ghost code.
18002 Mark_Ghost_Pragma
(N
, Ent
);
18004 -- Capture the entity of the first Ghost subprogram
18005 -- being processed for error detection purposes.
18007 if Is_Ghost_Entity
(Ent
) then
18008 if No
(Ghost_Id
) then
18012 -- Otherwise the subprogram is non-Ghost. It is
18013 -- illegal to mix references to Ghost and non-Ghost
18014 -- entities (SPARK RM 6.9).
18016 elsif Present
(Ghost_Id
)
18017 and then not Ghost_Error_Posted
18019 Ghost_Error_Posted
:= True;
18021 Error_Msg_Name_1
:= Pname
;
18023 ("pragma % cannot mention ghost and "
18024 & "non-ghost subprograms", N
);
18026 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18028 ("\& # declared as ghost", N
, Ghost_Id
);
18030 Error_Msg_Sloc
:= Sloc
(Ent
);
18032 ("\& # declared as non-ghost", N
, Ent
);
18036 Ent
:= Homonym
(Ent
);
18038 or else Scope
(Ent
) /= Current_Scope
;
18042 -- All other cases are illegal
18046 ("pragma% applies only to objects, subprograms, and types",
18049 end Linker_Section
;
18055 -- pragma List (On | Off)
18057 -- There is nothing to do here, since we did all the processing for
18058 -- this pragma in Par.Prag (so that it works properly even in syntax
18061 when Pragma_List
=>
18068 -- pragma Lock_Free [(Boolean_EXPRESSION)];
18070 when Pragma_Lock_Free
=> Lock_Free
: declare
18071 P
: constant Node_Id
:= Parent
(N
);
18077 Check_No_Identifiers
;
18078 Check_At_Most_N_Arguments
(1);
18080 -- Protected definition case
18082 if Nkind
(P
) = N_Protected_Definition
then
18083 Ent
:= Defining_Identifier
(Parent
(P
));
18087 if Arg_Count
= 1 then
18088 Arg
:= Get_Pragma_Arg
(Arg1
);
18089 Val
:= Is_True
(Static_Boolean
(Arg
));
18091 -- No arguments (expression is considered to be True)
18097 -- Check duplicate pragma before we chain the pragma in the Rep
18098 -- Item chain of Ent.
18100 Check_Duplicate_Pragma
(Ent
);
18101 Record_Rep_Item
(Ent
, N
);
18102 Set_Uses_Lock_Free
(Ent
, Val
);
18104 -- Anything else is incorrect placement
18111 --------------------
18112 -- Locking_Policy --
18113 --------------------
18115 -- pragma Locking_Policy (policy_IDENTIFIER);
18117 when Pragma_Locking_Policy
=> declare
18118 subtype LP_Range
is Name_Id
18119 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
18124 Check_Ada_83_Warning
;
18125 Check_Arg_Count
(1);
18126 Check_No_Identifiers
;
18127 Check_Arg_Is_Locking_Policy
(Arg1
);
18128 Check_Valid_Configuration_Pragma
;
18129 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18132 when Name_Ceiling_Locking
=> LP
:= 'C';
18133 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
18134 when Name_Inheritance_Locking
=> LP
:= 'I';
18137 if Locking_Policy
/= ' '
18138 and then Locking_Policy
/= LP
18140 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18141 Error_Pragma
("locking policy incompatible with policy#");
18143 -- Set new policy, but always preserve System_Location since we
18144 -- like the error message with the run time name.
18147 Locking_Policy
:= LP
;
18149 if Locking_Policy_Sloc
/= System_Location
then
18150 Locking_Policy_Sloc
:= Loc
;
18155 -------------------
18156 -- Loop_Optimize --
18157 -------------------
18159 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
18161 -- OPTIMIZATION_HINT ::=
18162 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
18164 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
18169 Check_At_Least_N_Arguments
(1);
18170 Check_No_Identifiers
;
18172 Hint
:= First
(Pragma_Argument_Associations
(N
));
18173 while Present
(Hint
) loop
18174 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
18182 Check_Loop_Pragma_Placement
;
18189 -- pragma Loop_Variant
18190 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
18192 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
18194 -- CHANGE_DIRECTION ::= Increases | Decreases
18196 when Pragma_Loop_Variant
=> Loop_Variant
: declare
18201 Check_At_Least_N_Arguments
(1);
18202 Check_Loop_Pragma_Placement
;
18204 -- Process all increasing / decreasing expressions
18206 Variant
:= First
(Pragma_Argument_Associations
(N
));
18207 while Present
(Variant
) loop
18208 if Chars
(Variant
) = No_Name
then
18209 Error_Pragma_Arg
("expect name `Increases`", Variant
);
18211 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
18215 Name
: String := Get_Name_String
(Chars
(Variant
));
18218 -- It is a common mistake to write "Increasing" for
18219 -- "Increases" or "Decreasing" for "Decreases". Recognize
18220 -- specially names starting with "incr" or "decr" to
18221 -- suggest the corresponding name.
18223 System
.Case_Util
.To_Lower
(Name
);
18225 if Name
'Length >= 4
18226 and then Name
(1 .. 4) = "incr"
18228 Error_Pragma_Arg_Ident
18229 ("expect name `Increases`", Variant
);
18231 elsif Name
'Length >= 4
18232 and then Name
(1 .. 4) = "decr"
18234 Error_Pragma_Arg_Ident
18235 ("expect name `Decreases`", Variant
);
18238 Error_Pragma_Arg_Ident
18239 ("expect name `Increases` or `Decreases`", Variant
);
18244 Preanalyze_Assert_Expression
18245 (Expression
(Variant
), Any_Discrete
);
18251 -----------------------
18252 -- Machine_Attribute --
18253 -----------------------
18255 -- pragma Machine_Attribute (
18256 -- [Entity =>] LOCAL_NAME,
18257 -- [Attribute_Name =>] static_string_EXPRESSION
18258 -- [, [Info =>] static_EXPRESSION] );
18260 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
18261 Def_Id
: Entity_Id
;
18265 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
18267 if Arg_Count
= 3 then
18268 Check_Optional_Identifier
(Arg3
, Name_Info
);
18269 Check_Arg_Is_OK_Static_Expression
(Arg3
);
18271 Check_Arg_Count
(2);
18274 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18275 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
18276 Check_Arg_Is_Local_Name
(Arg1
);
18277 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18278 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18280 if Is_Access_Type
(Def_Id
) then
18281 Def_Id
:= Designated_Type
(Def_Id
);
18284 if Rep_Item_Too_Early
(Def_Id
, N
) then
18288 Def_Id
:= Underlying_Type
(Def_Id
);
18290 -- The only processing required is to link this item on to the
18291 -- list of rep items for the given entity. This is accomplished
18292 -- by the call to Rep_Item_Too_Late (when no error is detected
18293 -- and False is returned).
18295 if Rep_Item_Too_Late
(Def_Id
, N
) then
18298 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18300 end Machine_Attribute
;
18307 -- (MAIN_OPTION [, MAIN_OPTION]);
18310 -- [STACK_SIZE =>] static_integer_EXPRESSION
18311 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
18312 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
18314 when Pragma_Main
=> Main
: declare
18315 Args
: Args_List
(1 .. 3);
18316 Names
: constant Name_List
(1 .. 3) := (
18318 Name_Task_Stack_Size_Default
,
18319 Name_Time_Slicing_Enabled
);
18325 Gather_Associations
(Names
, Args
);
18327 for J
in 1 .. 2 loop
18328 if Present
(Args
(J
)) then
18329 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18333 if Present
(Args
(3)) then
18334 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
18338 while Present
(Nod
) loop
18339 if Nkind
(Nod
) = N_Pragma
18340 and then Pragma_Name
(Nod
) = Name_Main
18342 Error_Msg_Name_1
:= Pname
;
18343 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18354 -- pragma Main_Storage
18355 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
18357 -- MAIN_STORAGE_OPTION ::=
18358 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
18359 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
18361 when Pragma_Main_Storage
=> Main_Storage
: declare
18362 Args
: Args_List
(1 .. 2);
18363 Names
: constant Name_List
(1 .. 2) := (
18364 Name_Working_Storage
,
18371 Gather_Associations
(Names
, Args
);
18373 for J
in 1 .. 2 loop
18374 if Present
(Args
(J
)) then
18375 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18379 Check_In_Main_Program
;
18382 while Present
(Nod
) loop
18383 if Nkind
(Nod
) = N_Pragma
18384 and then Pragma_Name
(Nod
) = Name_Main_Storage
18386 Error_Msg_Name_1
:= Pname
;
18387 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18394 ----------------------
18395 -- Max_Queue_Length --
18396 ----------------------
18398 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
18400 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
18402 Entry_Decl
: Node_Id
;
18403 Entry_Id
: Entity_Id
;
18408 Check_Arg_Count
(1);
18411 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
18413 -- Entry declaration
18415 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
18417 -- Entry illegally within a task
18419 if Nkind
(Parent
(N
)) = N_Task_Definition
then
18420 Error_Pragma
("pragma % cannot apply to task entries");
18424 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
18426 -- Otherwise the pragma is associated with an illegal construct
18429 Error_Pragma
("pragma % must apply to a protected entry");
18433 -- Mark the pragma as Ghost if the related subprogram is also
18434 -- Ghost. This also ensures that any expansion performed further
18435 -- below will produce Ghost nodes.
18437 Mark_Ghost_Pragma
(N
, Entry_Id
);
18439 -- Analyze the Integer expression
18441 Arg
:= Get_Pragma_Arg
(Arg1
);
18442 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
18444 Val
:= Expr_Value
(Arg
);
18448 ("argument for pragma% must be positive", Arg1
);
18450 elsif not UI_Is_In_Int_Range
(Val
) then
18452 ("argument for pragma% out of range of Integer", Arg1
);
18456 -- Manually substitute the expression value of the pragma argument
18457 -- if it's not an integer literal because this is not taken care
18458 -- of automatically elsewhere.
18460 if Nkind
(Arg
) /= N_Integer_Literal
then
18461 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
18464 Record_Rep_Item
(Entry_Id
, N
);
18465 end Max_Queue_Length
;
18471 -- pragma Memory_Size (NUMERIC_LITERAL)
18473 when Pragma_Memory_Size
=>
18476 -- Memory size is simply ignored
18478 Check_No_Identifiers
;
18479 Check_Arg_Count
(1);
18480 Check_Arg_Is_Integer_Literal
(Arg1
);
18488 -- The only correct use of this pragma is on its own in a file, in
18489 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
18490 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
18491 -- check for a file containing nothing but a No_Body pragma). If we
18492 -- attempt to process it during normal semantics processing, it means
18493 -- it was misplaced.
18495 when Pragma_No_Body
=>
18499 -----------------------------
18500 -- No_Elaboration_Code_All --
18501 -----------------------------
18503 -- pragma No_Elaboration_Code_All;
18505 when Pragma_No_Elaboration_Code_All
=>
18507 Check_Valid_Library_Unit_Pragma
;
18509 if Nkind
(N
) = N_Null_Statement
then
18513 -- Must appear for a spec or generic spec
18515 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
18516 N_Generic_Package_Declaration
,
18517 N_Generic_Subprogram_Declaration
,
18518 N_Package_Declaration
,
18519 N_Subprogram_Declaration
)
18523 ("pragma% can only occur for package "
18524 & "or subprogram spec"));
18527 -- Set flag in unit table
18529 Set_No_Elab_Code_All
(Current_Sem_Unit
);
18531 -- Set restriction No_Elaboration_Code if this is the main unit
18533 if Current_Sem_Unit
= Main_Unit
then
18534 Set_Restriction
(No_Elaboration_Code
, N
);
18537 -- If we are in the main unit or in an extended main source unit,
18538 -- then we also add it to the configuration restrictions so that
18539 -- it will apply to all units in the extended main source.
18541 if Current_Sem_Unit
= Main_Unit
18542 or else In_Extended_Main_Source_Unit
(N
)
18544 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
18547 -- If in main extended unit, activate transitive with test
18549 if In_Extended_Main_Source_Unit
(N
) then
18550 Opt
.No_Elab_Code_All_Pragma
:= N
;
18553 -----------------------------
18554 -- No_Component_Reordering --
18555 -----------------------------
18557 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
18559 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
18565 Check_At_Most_N_Arguments
(1);
18567 if Arg_Count
= 0 then
18568 Check_Valid_Configuration_Pragma
;
18569 Opt
.No_Component_Reordering
:= True;
18572 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18573 Check_Arg_Is_Local_Name
(Arg1
);
18574 E_Id
:= Get_Pragma_Arg
(Arg1
);
18576 if Etype
(E_Id
) = Any_Type
then
18580 E
:= Entity
(E_Id
);
18582 if not Is_Record_Type
(E
) then
18583 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
18586 Set_No_Reordering
(Base_Type
(E
));
18588 end No_Comp_Reordering
;
18590 --------------------------
18591 -- No_Heap_Finalization --
18592 --------------------------
18594 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18596 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
18597 Context
: constant Node_Id
:= Parent
(N
);
18598 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18604 Check_No_Identifiers
;
18606 -- The pragma appears in a configuration file
18608 if No
(Context
) then
18609 Check_Arg_Count
(0);
18610 Check_Valid_Configuration_Pragma
;
18612 -- Detect a duplicate pragma
18614 if Present
(No_Heap_Finalization_Pragma
) then
18617 Prev
=> No_Heap_Finalization_Pragma
);
18621 No_Heap_Finalization_Pragma
:= N
;
18623 -- Otherwise the pragma should be associated with a library-level
18624 -- named access-to-object type.
18627 Check_Arg_Count
(1);
18628 Check_Arg_Is_Local_Name
(Arg1
);
18630 Find_Type
(Typ_Arg
);
18631 Typ
:= Entity
(Typ_Arg
);
18633 -- The type being subjected to the pragma is erroneous
18635 if Typ
= Any_Type
then
18636 Error_Pragma
("cannot find type referenced by pragma %");
18638 -- The pragma is applied to an incomplete or generic formal
18639 -- type way too early.
18641 elsif Rep_Item_Too_Early
(Typ
, N
) then
18645 Typ
:= Underlying_Type
(Typ
);
18648 -- The pragma must apply to an access-to-object type
18650 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
18653 -- Give a detailed error message on all other access type kinds
18655 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
18657 ("pragma % cannot apply to access protected subprogram "
18660 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
18662 ("pragma % cannot apply to access subprogram type");
18664 elsif Is_Anonymous_Access_Type
(Typ
) then
18666 ("pragma % cannot apply to anonymous access type");
18668 -- Give a general error message in case the pragma applies to a
18669 -- non-access type.
18673 ("pragma % must apply to library level access type");
18676 -- At this point the argument denotes an access-to-object type.
18677 -- Ensure that the type is declared at the library level.
18679 if Is_Library_Level_Entity
(Typ
) then
18682 -- Quietly ignore an access-to-object type originally declared
18683 -- at the library level within a generic, but instantiated at
18684 -- a non-library level. As a result the access-to-object type
18685 -- "loses" its No_Heap_Finalization property.
18687 elsif In_Instance
then
18692 ("pragma % must apply to library level access type");
18695 -- Detect a duplicate pragma
18697 if Present
(No_Heap_Finalization_Pragma
) then
18700 Prev
=> No_Heap_Finalization_Pragma
);
18704 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
18706 if Present
(Prev
) then
18714 Record_Rep_Item
(Typ
, N
);
18716 end No_Heap_Finalization
;
18722 -- pragma No_Inline ( NAME {, NAME} );
18724 when Pragma_No_Inline
=>
18726 Process_Inline
(Suppressed
);
18732 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18734 when Pragma_No_Return
=> No_Return
: declare
18740 Ghost_Error_Posted
: Boolean := False;
18741 -- Flag set when an error concerning the illegal mix of Ghost and
18742 -- non-Ghost subprograms is emitted.
18744 Ghost_Id
: Entity_Id
:= Empty
;
18745 -- The entity of the first Ghost procedure encountered while
18746 -- processing the arguments of the pragma.
18750 Check_At_Least_N_Arguments
(1);
18752 -- Loop through arguments of pragma
18755 while Present
(Arg
) loop
18756 Check_Arg_Is_Local_Name
(Arg
);
18757 Id
:= Get_Pragma_Arg
(Arg
);
18760 if not Is_Entity_Name
(Id
) then
18761 Error_Pragma_Arg
("entity name required", Arg
);
18764 if Etype
(Id
) = Any_Type
then
18768 -- Loop to find matching procedures
18774 and then Scope
(E
) = Current_Scope
18776 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
18778 -- Check that the pragma is not applied to a body.
18779 -- First check the specless body case, to give a
18780 -- different error message. These checks do not apply
18781 -- if Relaxed_RM_Semantics, to accommodate other Ada
18782 -- compilers. Disable these checks under -gnatd.J.
18784 if not Debug_Flag_Dot_JJ
then
18785 if Nkind
(Parent
(Declaration_Node
(E
))) =
18787 and then not Relaxed_RM_Semantics
18790 ("pragma% requires separate spec and must come "
18794 -- Now the "specful" body case
18796 if Rep_Item_Too_Late
(E
, N
) then
18803 -- A pragma that applies to a Ghost entity becomes Ghost
18804 -- for the purposes of legality checks and removal of
18805 -- ignored Ghost code.
18807 Mark_Ghost_Pragma
(N
, E
);
18809 -- Capture the entity of the first Ghost procedure being
18810 -- processed for error detection purposes.
18812 if Is_Ghost_Entity
(E
) then
18813 if No
(Ghost_Id
) then
18817 -- Otherwise the subprogram is non-Ghost. It is illegal
18818 -- to mix references to Ghost and non-Ghost entities
18821 elsif Present
(Ghost_Id
)
18822 and then not Ghost_Error_Posted
18824 Ghost_Error_Posted
:= True;
18826 Error_Msg_Name_1
:= Pname
;
18828 ("pragma % cannot mention ghost and non-ghost "
18829 & "procedures", N
);
18831 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18832 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
18834 Error_Msg_Sloc
:= Sloc
(E
);
18835 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
18838 -- Set flag on any alias as well
18840 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
18841 Set_No_Return
(Alias
(E
));
18847 exit when From_Aspect_Specification
(N
);
18851 -- If entity in not in current scope it may be the enclosing
18852 -- suprogram body to which the aspect applies.
18855 if Entity
(Id
) = Current_Scope
18856 and then From_Aspect_Specification
(N
)
18858 Set_No_Return
(Entity
(Id
));
18860 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
18872 -- pragma No_Run_Time;
18874 -- Note: this pragma is retained for backwards compatibility. See
18875 -- body of Rtsfind for full details on its handling.
18877 when Pragma_No_Run_Time
=>
18879 Check_Valid_Configuration_Pragma
;
18880 Check_Arg_Count
(0);
18882 -- Remove backward compatibility if Build_Type is FSF or GPL and
18883 -- generate a warning.
18886 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
18889 Error_Pragma
("pragma% is ignored, has no effect??");
18891 No_Run_Time_Mode
:= True;
18892 Configurable_Run_Time_Mode
:= True;
18894 -- Set Duration to 32 bits if word size is 32
18896 if Ttypes
.System_Word_Size
= 32 then
18897 Duration_32_Bits_On_Target
:= True;
18900 -- Set appropriate restrictions
18902 Set_Restriction
(No_Finalization
, N
);
18903 Set_Restriction
(No_Exception_Handlers
, N
);
18904 Set_Restriction
(Max_Tasks
, N
, 0);
18905 Set_Restriction
(No_Tasking
, N
);
18909 -----------------------
18910 -- No_Tagged_Streams --
18911 -----------------------
18913 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18915 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
18921 Check_At_Most_N_Arguments
(1);
18923 -- One argument case
18925 if Arg_Count
= 1 then
18926 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18927 Check_Arg_Is_Local_Name
(Arg1
);
18928 E_Id
:= Get_Pragma_Arg
(Arg1
);
18930 if Etype
(E_Id
) = Any_Type
then
18934 E
:= Entity
(E_Id
);
18936 Check_Duplicate_Pragma
(E
);
18938 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
18940 ("argument for pragma% must be root tagged type", Arg1
);
18943 if Rep_Item_Too_Early
(E
, N
)
18945 Rep_Item_Too_Late
(E
, N
)
18949 Set_No_Tagged_Streams_Pragma
(E
, N
);
18952 -- Zero argument case
18955 Check_Is_In_Decl_Part_Or_Package_Spec
;
18956 No_Tagged_Streams
:= N
;
18958 end No_Tagged_Strms
;
18960 ------------------------
18961 -- No_Strict_Aliasing --
18962 ------------------------
18964 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18966 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
18972 Check_At_Most_N_Arguments
(1);
18974 if Arg_Count
= 0 then
18975 Check_Valid_Configuration_Pragma
;
18976 Opt
.No_Strict_Aliasing
:= True;
18979 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18980 Check_Arg_Is_Local_Name
(Arg1
);
18981 E_Id
:= Get_Pragma_Arg
(Arg1
);
18983 if Etype
(E_Id
) = Any_Type
then
18987 E
:= Entity
(E_Id
);
18989 if not Is_Access_Type
(E
) then
18990 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
18993 Set_No_Strict_Aliasing
(Base_Type
(E
));
18995 end No_Strict_Aliasing
;
18997 -----------------------
18998 -- Normalize_Scalars --
18999 -----------------------
19001 -- pragma Normalize_Scalars;
19003 when Pragma_Normalize_Scalars
=>
19004 Check_Ada_83_Warning
;
19005 Check_Arg_Count
(0);
19006 Check_Valid_Configuration_Pragma
;
19008 -- Normalize_Scalars creates false positives in CodePeer, and
19009 -- incorrect negative results in GNATprove mode, so ignore this
19010 -- pragma in these modes.
19012 if not (CodePeer_Mode
or GNATprove_Mode
) then
19013 Normalize_Scalars
:= True;
19014 Init_Or_Norm_Scalars
:= True;
19021 -- pragma Obsolescent;
19023 -- pragma Obsolescent (
19024 -- [Message =>] static_string_EXPRESSION
19025 -- [,[Version =>] Ada_05]]);
19027 -- pragma Obsolescent (
19028 -- [Entity =>] NAME
19029 -- [,[Message =>] static_string_EXPRESSION
19030 -- [,[Version =>] Ada_05]] );
19032 when Pragma_Obsolescent
=> Obsolescent
: declare
19036 procedure Set_Obsolescent
(E
: Entity_Id
);
19037 -- Given an entity Ent, mark it as obsolescent if appropriate
19039 ---------------------
19040 -- Set_Obsolescent --
19041 ---------------------
19043 procedure Set_Obsolescent
(E
: Entity_Id
) is
19052 -- A pragma that applies to a Ghost entity becomes Ghost for
19053 -- the purposes of legality checks and removal of ignored Ghost
19056 Mark_Ghost_Pragma
(N
, E
);
19058 -- Entity name was given
19060 if Present
(Ename
) then
19062 -- If entity name matches, we are fine. Save entity in
19063 -- pragma argument, for ASIS use.
19065 if Chars
(Ename
) = Chars
(Ent
) then
19066 Set_Entity
(Ename
, Ent
);
19067 Generate_Reference
(Ent
, Ename
);
19069 -- If entity name does not match, only possibility is an
19070 -- enumeration literal from an enumeration type declaration.
19072 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
19074 ("pragma % entity name does not match declaration");
19077 Ent
:= First_Literal
(E
);
19081 ("pragma % entity name does not match any "
19082 & "enumeration literal");
19084 elsif Chars
(Ent
) = Chars
(Ename
) then
19085 Set_Entity
(Ename
, Ent
);
19086 Generate_Reference
(Ent
, Ename
);
19090 Ent
:= Next_Literal
(Ent
);
19096 -- Ent points to entity to be marked
19098 if Arg_Count
>= 1 then
19100 -- Deal with static string argument
19102 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19103 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
19105 for J
in 1 .. String_Length
(S
) loop
19106 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
19108 ("pragma% argument does not allow wide characters",
19113 Obsolescent_Warnings
.Append
19114 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
19116 -- Check for Ada_05 parameter
19118 if Arg_Count
/= 1 then
19119 Check_Arg_Count
(2);
19122 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19125 Check_Arg_Is_Identifier
(Argx
);
19127 if Chars
(Argx
) /= Name_Ada_05
then
19128 Error_Msg_Name_2
:= Name_Ada_05
;
19130 ("only allowed argument for pragma% is %", Argx
);
19133 if Ada_Version_Explicit
< Ada_2005
19134 or else not Warn_On_Ada_2005_Compatibility
19142 -- Set flag if pragma active
19145 Set_Is_Obsolescent
(Ent
);
19149 end Set_Obsolescent
;
19151 -- Start of processing for pragma Obsolescent
19156 Check_At_Most_N_Arguments
(3);
19158 -- See if first argument specifies an entity name
19162 (Chars
(Arg1
) = Name_Entity
19164 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
19166 N_Operator_Symbol
))
19168 Ename
:= Get_Pragma_Arg
(Arg1
);
19170 -- Eliminate first argument, so we can share processing
19174 Arg_Count
:= Arg_Count
- 1;
19176 -- No Entity name argument given
19182 if Arg_Count
>= 1 then
19183 Check_Optional_Identifier
(Arg1
, Name_Message
);
19185 if Arg_Count
= 2 then
19186 Check_Optional_Identifier
(Arg2
, Name_Version
);
19190 -- Get immediately preceding declaration
19193 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
19197 -- Cases where we do not follow anything other than another pragma
19201 -- First case: library level compilation unit declaration with
19202 -- the pragma immediately following the declaration.
19204 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
19206 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
19209 -- Case 2: library unit placement for package
19213 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
19215 if Is_Package_Or_Generic_Package
(Ent
) then
19216 Set_Obsolescent
(Ent
);
19222 -- Cases where we must follow a declaration, including an
19223 -- abstract subprogram declaration, which is not in the
19224 -- other node subtypes.
19227 if Nkind
(Decl
) not in N_Declaration
19228 and then Nkind
(Decl
) not in N_Later_Decl_Item
19229 and then Nkind
(Decl
) not in N_Generic_Declaration
19230 and then Nkind
(Decl
) not in N_Renaming_Declaration
19231 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
19234 ("pragma% misplaced, "
19235 & "must immediately follow a declaration");
19238 Set_Obsolescent
(Defining_Entity
(Decl
));
19248 -- pragma Optimize (Time | Space | Off);
19250 -- The actual check for optimize is done in Gigi. Note that this
19251 -- pragma does not actually change the optimization setting, it
19252 -- simply checks that it is consistent with the pragma.
19254 when Pragma_Optimize
=>
19255 Check_No_Identifiers
;
19256 Check_Arg_Count
(1);
19257 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
19259 ------------------------
19260 -- Optimize_Alignment --
19261 ------------------------
19263 -- pragma Optimize_Alignment (Time | Space | Off);
19265 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
19267 Check_No_Identifiers
;
19268 Check_Arg_Count
(1);
19269 Check_Valid_Configuration_Pragma
;
19272 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
19275 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
19276 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
19277 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
19280 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
19284 -- Set indication that mode is set locally. If we are in fact in a
19285 -- configuration pragma file, this setting is harmless since the
19286 -- switch will get reset anyway at the start of each unit.
19288 Optimize_Alignment_Local
:= True;
19289 end Optimize_Alignment
;
19295 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
19297 when Pragma_Ordered
=> Ordered
: declare
19298 Assoc
: constant Node_Id
:= Arg1
;
19304 Check_No_Identifiers
;
19305 Check_Arg_Count
(1);
19306 Check_Arg_Is_Local_Name
(Arg1
);
19308 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19309 Find_Type
(Type_Id
);
19310 Typ
:= Entity
(Type_Id
);
19312 if Typ
= Any_Type
then
19315 Typ
:= Underlying_Type
(Typ
);
19318 if not Is_Enumeration_Type
(Typ
) then
19319 Error_Pragma
("pragma% must specify enumeration type");
19322 Check_First_Subtype
(Arg1
);
19323 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
19326 -------------------
19327 -- Overflow_Mode --
19328 -------------------
19330 -- pragma Overflow_Mode
19331 -- ([General => ] MODE [, [Assertions => ] MODE]);
19333 -- MODE := STRICT | MINIMIZED | ELIMINATED
19335 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
19336 -- since System.Bignums makes this assumption. This is true of nearly
19337 -- all (all?) targets.
19339 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
19340 function Get_Overflow_Mode
19342 Arg
: Node_Id
) return Overflow_Mode_Type
;
19343 -- Function to process one pragma argument, Arg. If an identifier
19344 -- is present, it must be Name. Mode type is returned if a valid
19345 -- argument exists, otherwise an error is signalled.
19347 -----------------------
19348 -- Get_Overflow_Mode --
19349 -----------------------
19351 function Get_Overflow_Mode
19353 Arg
: Node_Id
) return Overflow_Mode_Type
19355 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
19358 Check_Optional_Identifier
(Arg
, Name
);
19359 Check_Arg_Is_Identifier
(Argx
);
19361 if Chars
(Argx
) = Name_Strict
then
19364 elsif Chars
(Argx
) = Name_Minimized
then
19367 elsif Chars
(Argx
) = Name_Eliminated
then
19368 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
19370 ("Eliminated not implemented on this target", Argx
);
19376 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
19378 end Get_Overflow_Mode
;
19380 -- Start of processing for Overflow_Mode
19384 Check_At_Least_N_Arguments
(1);
19385 Check_At_Most_N_Arguments
(2);
19387 -- Process first argument
19389 Scope_Suppress
.Overflow_Mode_General
:=
19390 Get_Overflow_Mode
(Name_General
, Arg1
);
19392 -- Case of only one argument
19394 if Arg_Count
= 1 then
19395 Scope_Suppress
.Overflow_Mode_Assertions
:=
19396 Scope_Suppress
.Overflow_Mode_General
;
19398 -- Case of two arguments present
19401 Scope_Suppress
.Overflow_Mode_Assertions
:=
19402 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
19406 --------------------------
19407 -- Overriding Renamings --
19408 --------------------------
19410 -- pragma Overriding_Renamings;
19412 when Pragma_Overriding_Renamings
=>
19414 Check_Arg_Count
(0);
19415 Check_Valid_Configuration_Pragma
;
19416 Overriding_Renamings
:= True;
19422 -- pragma Pack (first_subtype_LOCAL_NAME);
19424 when Pragma_Pack
=> Pack
: declare
19425 Assoc
: constant Node_Id
:= Arg1
;
19427 Ignore
: Boolean := False;
19432 Check_No_Identifiers
;
19433 Check_Arg_Count
(1);
19434 Check_Arg_Is_Local_Name
(Arg1
);
19435 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19437 if not Is_Entity_Name
(Type_Id
)
19438 or else not Is_Type
(Entity
(Type_Id
))
19441 ("argument for pragma% must be type or subtype", Arg1
);
19444 Find_Type
(Type_Id
);
19445 Typ
:= Entity
(Type_Id
);
19448 or else Rep_Item_Too_Early
(Typ
, N
)
19452 Typ
:= Underlying_Type
(Typ
);
19455 -- A pragma that applies to a Ghost entity becomes Ghost for the
19456 -- purposes of legality checks and removal of ignored Ghost code.
19458 Mark_Ghost_Pragma
(N
, Typ
);
19460 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
19461 Error_Pragma
("pragma% must specify array or record type");
19464 Check_First_Subtype
(Arg1
);
19465 Check_Duplicate_Pragma
(Typ
);
19469 if Is_Array_Type
(Typ
) then
19470 Ctyp
:= Component_Type
(Typ
);
19472 -- Ignore pack that does nothing
19474 if Known_Static_Esize
(Ctyp
)
19475 and then Known_Static_RM_Size
(Ctyp
)
19476 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
19477 and then Addressable
(Esize
(Ctyp
))
19482 -- Process OK pragma Pack. Note that if there is a separate
19483 -- component clause present, the Pack will be cancelled. This
19484 -- processing is in Freeze.
19486 if not Rep_Item_Too_Late
(Typ
, N
) then
19488 -- In CodePeer mode, we do not need complex front-end
19489 -- expansions related to pragma Pack, so disable handling
19492 if CodePeer_Mode
then
19495 -- Normal case where we do the pack action
19499 Set_Is_Packed
(Base_Type
(Typ
));
19500 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19503 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19507 -- For record types, the pack is always effective
19509 else pragma Assert
(Is_Record_Type
(Typ
));
19510 if not Rep_Item_Too_Late
(Typ
, N
) then
19511 Set_Is_Packed
(Base_Type
(Typ
));
19512 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19513 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19524 -- There is nothing to do here, since we did all the processing for
19525 -- this pragma in Par.Prag (so that it works properly even in syntax
19528 when Pragma_Page
=>
19535 -- pragma Part_Of (ABSTRACT_STATE);
19537 -- ABSTRACT_STATE ::= NAME
19539 when Pragma_Part_Of
=> Part_Of
: declare
19540 procedure Propagate_Part_Of
19541 (Pack_Id
: Entity_Id
;
19542 State_Id
: Entity_Id
;
19543 Instance
: Node_Id
);
19544 -- Propagate the Part_Of indicator to all abstract states and
19545 -- objects declared in the visible state space of a package
19546 -- denoted by Pack_Id. State_Id is the encapsulating state.
19547 -- Instance is the package instantiation node.
19549 -----------------------
19550 -- Propagate_Part_Of --
19551 -----------------------
19553 procedure Propagate_Part_Of
19554 (Pack_Id
: Entity_Id
;
19555 State_Id
: Entity_Id
;
19556 Instance
: Node_Id
)
19558 Has_Item
: Boolean := False;
19559 -- Flag set when the visible state space contains at least one
19560 -- abstract state or variable.
19562 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
19563 -- Propagate the Part_Of indicator to all abstract states and
19564 -- objects declared in the visible state space of a package
19565 -- denoted by Pack_Id.
19567 -----------------------
19568 -- Propagate_Part_Of --
19569 -----------------------
19571 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
19572 Constits
: Elist_Id
;
19573 Item_Id
: Entity_Id
;
19576 -- Traverse the entity chain of the package and set relevant
19577 -- attributes of abstract states and objects declared in the
19578 -- visible state space of the package.
19580 Item_Id
:= First_Entity
(Pack_Id
);
19581 while Present
(Item_Id
)
19582 and then not In_Private_Part
(Item_Id
)
19584 -- Do not consider internally generated items
19586 if not Comes_From_Source
(Item_Id
) then
19589 -- The Part_Of indicator turns an abstract state or an
19590 -- object into a constituent of the encapsulating state.
19592 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
19597 Constits
:= Part_Of_Constituents
(State_Id
);
19599 if No
(Constits
) then
19600 Constits
:= New_Elmt_List
;
19601 Set_Part_Of_Constituents
(State_Id
, Constits
);
19604 Append_Elmt
(Item_Id
, Constits
);
19605 Set_Encapsulating_State
(Item_Id
, State_Id
);
19607 -- Recursively handle nested packages and instantiations
19609 elsif Ekind
(Item_Id
) = E_Package
then
19610 Propagate_Part_Of
(Item_Id
);
19613 Next_Entity
(Item_Id
);
19615 end Propagate_Part_Of
;
19617 -- Start of processing for Propagate_Part_Of
19620 Propagate_Part_Of
(Pack_Id
);
19622 -- Detect a package instantiation that is subject to a Part_Of
19623 -- indicator, but has no visible state.
19625 if not Has_Item
then
19627 ("package instantiation & has Part_Of indicator but "
19628 & "lacks visible state", Instance
, Pack_Id
);
19630 end Propagate_Part_Of
;
19634 Constits
: Elist_Id
;
19636 Encap_Id
: Entity_Id
;
19637 Item_Id
: Entity_Id
;
19641 -- Start of processing for Part_Of
19645 Check_No_Identifiers
;
19646 Check_Arg_Count
(1);
19648 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
19650 -- Object declaration
19652 if Nkind
(Stmt
) = N_Object_Declaration
then
19655 -- Package instantiation
19657 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
19660 -- Single concurrent type declaration
19662 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
19665 -- Otherwise the pragma is associated with an illegal construct
19672 -- Extract the entity of the related object declaration or package
19673 -- instantiation. In the case of the instantiation, use the entity
19674 -- of the instance spec.
19676 if Nkind
(Stmt
) = N_Package_Instantiation
then
19677 Stmt
:= Instance_Spec
(Stmt
);
19680 Item_Id
:= Defining_Entity
(Stmt
);
19682 -- A pragma that applies to a Ghost entity becomes Ghost for the
19683 -- purposes of legality checks and removal of ignored Ghost code.
19685 Mark_Ghost_Pragma
(N
, Item_Id
);
19687 -- Chain the pragma on the contract for further processing by
19688 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19690 Add_Contract_Item
(N
, Item_Id
);
19692 -- A variable may act as constituent of a single concurrent type
19693 -- which in turn could be declared after the variable. Due to this
19694 -- discrepancy, the full analysis of indicator Part_Of is delayed
19695 -- until the end of the enclosing declarative region (see routine
19696 -- Analyze_Part_Of_In_Decl_Part).
19698 if Ekind
(Item_Id
) = E_Variable
then
19701 -- Otherwise indicator Part_Of applies to a constant or a package
19705 Encap
:= Get_Pragma_Arg
(Arg1
);
19707 -- Detect any discrepancies between the placement of the
19708 -- constant or package instantiation with respect to state
19709 -- space and the encapsulating state.
19713 Item_Id
=> Item_Id
,
19715 Encap_Id
=> Encap_Id
,
19719 pragma Assert
(Present
(Encap_Id
));
19721 if Ekind
(Item_Id
) = E_Constant
then
19722 Constits
:= Part_Of_Constituents
(Encap_Id
);
19724 if No
(Constits
) then
19725 Constits
:= New_Elmt_List
;
19726 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
19729 Append_Elmt
(Item_Id
, Constits
);
19730 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
19732 -- Propagate the Part_Of indicator to the visible state
19733 -- space of the package instantiation.
19737 (Pack_Id
=> Item_Id
,
19738 State_Id
=> Encap_Id
,
19745 ----------------------------------
19746 -- Partition_Elaboration_Policy --
19747 ----------------------------------
19749 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19751 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
19752 subtype PEP_Range
is Name_Id
19753 range First_Partition_Elaboration_Policy_Name
19754 .. Last_Partition_Elaboration_Policy_Name
;
19755 PEP_Val
: PEP_Range
;
19760 Check_Arg_Count
(1);
19761 Check_No_Identifiers
;
19762 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
19763 Check_Valid_Configuration_Pragma
;
19764 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19767 when Name_Concurrent
=> PEP
:= 'C';
19768 when Name_Sequential
=> PEP
:= 'S';
19771 if Partition_Elaboration_Policy
/= ' '
19772 and then Partition_Elaboration_Policy
/= PEP
19774 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
19776 ("partition elaboration policy incompatible with policy#");
19778 -- Set new policy, but always preserve System_Location since we
19779 -- like the error message with the run time name.
19782 Partition_Elaboration_Policy
:= PEP
;
19784 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
19785 Partition_Elaboration_Policy_Sloc
:= Loc
;
19794 -- pragma Passive [(PASSIVE_FORM)];
19796 -- PASSIVE_FORM ::= Semaphore | No
19798 when Pragma_Passive
=>
19801 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
19802 Error_Pragma
("pragma% must be within task definition");
19805 if Arg_Count
/= 0 then
19806 Check_Arg_Count
(1);
19807 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
19810 ----------------------------------
19811 -- Preelaborable_Initialization --
19812 ----------------------------------
19814 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19816 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
19821 Check_Arg_Count
(1);
19822 Check_No_Identifiers
;
19823 Check_Arg_Is_Identifier
(Arg1
);
19824 Check_Arg_Is_Local_Name
(Arg1
);
19825 Check_First_Subtype
(Arg1
);
19826 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19828 -- A pragma that applies to a Ghost entity becomes Ghost for the
19829 -- purposes of legality checks and removal of ignored Ghost code.
19831 Mark_Ghost_Pragma
(N
, Ent
);
19833 -- The pragma may come from an aspect on a private declaration,
19834 -- even if the freeze point at which this is analyzed in the
19835 -- private part after the full view.
19837 if Has_Private_Declaration
(Ent
)
19838 and then From_Aspect_Specification
(N
)
19842 -- Check appropriate type argument
19844 elsif Is_Private_Type
(Ent
)
19845 or else Is_Protected_Type
(Ent
)
19846 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
19848 -- AI05-0028: The pragma applies to all composite types. Note
19849 -- that we apply this binding interpretation to earlier versions
19850 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19851 -- choice since there are other compilers that do the same.
19853 or else Is_Composite_Type
(Ent
)
19859 ("pragma % can only be applied to private, formal derived, "
19860 & "protected, or composite type", Arg1
);
19863 -- Give an error if the pragma is applied to a protected type that
19864 -- does not qualify (due to having entries, or due to components
19865 -- that do not qualify).
19867 if Is_Protected_Type
(Ent
)
19868 and then not Has_Preelaborable_Initialization
(Ent
)
19871 ("protected type & does not have preelaborable "
19872 & "initialization", Ent
);
19874 -- Otherwise mark the type as definitely having preelaborable
19878 Set_Known_To_Have_Preelab_Init
(Ent
);
19881 if Has_Pragma_Preelab_Init
(Ent
)
19882 and then Warn_On_Redundant_Constructs
19884 Error_Pragma
("?r?duplicate pragma%!");
19886 Set_Has_Pragma_Preelab_Init
(Ent
);
19890 --------------------
19891 -- Persistent_BSS --
19892 --------------------
19894 -- pragma Persistent_BSS [(object_NAME)];
19896 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
19903 Check_At_Most_N_Arguments
(1);
19905 -- Case of application to specific object (one argument)
19907 if Arg_Count
= 1 then
19908 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19910 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
19912 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
19915 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
19918 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19920 -- A pragma that applies to a Ghost entity becomes Ghost for
19921 -- the purposes of legality checks and removal of ignored Ghost
19924 Mark_Ghost_Pragma
(N
, Ent
);
19926 -- Check for duplication before inserting in list of
19927 -- representation items.
19929 Check_Duplicate_Pragma
(Ent
);
19931 if Rep_Item_Too_Late
(Ent
, N
) then
19935 Decl
:= Parent
(Ent
);
19937 if Present
(Expression
(Decl
)) then
19939 ("object for pragma% cannot have initialization", Arg1
);
19942 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
19944 ("object type for pragma% is not potentially persistent",
19949 Make_Linker_Section_Pragma
19950 (Ent
, Sloc
(N
), ".persistent.bss");
19951 Insert_After
(N
, Prag
);
19954 -- Case of use as configuration pragma with no arguments
19957 Check_Valid_Configuration_Pragma
;
19958 Persistent_BSS_Mode
:= True;
19960 end Persistent_BSS
;
19962 --------------------
19963 -- Rename_Pragma --
19964 --------------------
19966 -- pragma Rename_Pragma (
19967 -- [New_Name =>] IDENTIFIER,
19968 -- [Renamed =>] pragma_IDENTIFIER);
19970 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
19971 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19972 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19976 Check_Valid_Configuration_Pragma
;
19977 Check_Arg_Count
(2);
19978 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
19979 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
19981 if Nkind
(New_Name
) /= N_Identifier
then
19982 Error_Pragma_Arg
("identifier expected", Arg1
);
19985 if Nkind
(Old_Name
) /= N_Identifier
then
19986 Error_Pragma_Arg
("identifier expected", Arg2
);
19989 -- The New_Name arg should not be an existing pragma (but we allow
19990 -- it; it's just a warning). The Old_Name arg must be an existing
19993 if Is_Pragma_Name
(Chars
(New_Name
)) then
19994 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
19997 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
19998 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
20001 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
20008 -- pragma Polling (ON | OFF);
20010 when Pragma_Polling
=>
20012 Check_Arg_Count
(1);
20013 Check_No_Identifiers
;
20014 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20015 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
20017 -----------------------------------
20018 -- Post/Post_Class/Postcondition --
20019 -----------------------------------
20021 -- pragma Post (Boolean_EXPRESSION);
20022 -- pragma Post_Class (Boolean_EXPRESSION);
20023 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
20024 -- [,[Message =>] String_EXPRESSION]);
20026 -- Characteristics:
20028 -- * Analysis - The annotation undergoes initial checks to verify
20029 -- the legal placement and context. Secondary checks preanalyze the
20032 -- Analyze_Pre_Post_Condition_In_Decl_Part
20034 -- * Expansion - The annotation is expanded during the expansion of
20035 -- the related subprogram [body] contract as performed in:
20037 -- Expand_Subprogram_Contract
20039 -- * Template - The annotation utilizes the generic template of the
20040 -- related subprogram [body] when it is:
20042 -- aspect on subprogram declaration
20043 -- aspect on stand-alone subprogram body
20044 -- pragma on stand-alone subprogram body
20046 -- The annotation must prepare its own template when it is:
20048 -- pragma on subprogram declaration
20050 -- * Globals - Capture of global references must occur after full
20053 -- * Instance - The annotation is instantiated automatically when
20054 -- the related generic subprogram [body] is instantiated except for
20055 -- the "pragma on subprogram declaration" case. In that scenario
20056 -- the annotation must instantiate itself.
20059 | Pragma_Post_Class
20060 | Pragma_Postcondition
20062 Analyze_Pre_Post_Condition
;
20064 --------------------------------
20065 -- Pre/Pre_Class/Precondition --
20066 --------------------------------
20068 -- pragma Pre (Boolean_EXPRESSION);
20069 -- pragma Pre_Class (Boolean_EXPRESSION);
20070 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
20071 -- [,[Message =>] String_EXPRESSION]);
20073 -- Characteristics:
20075 -- * Analysis - The annotation undergoes initial checks to verify
20076 -- the legal placement and context. Secondary checks preanalyze the
20079 -- Analyze_Pre_Post_Condition_In_Decl_Part
20081 -- * Expansion - The annotation is expanded during the expansion of
20082 -- the related subprogram [body] contract as performed in:
20084 -- Expand_Subprogram_Contract
20086 -- * Template - The annotation utilizes the generic template of the
20087 -- related subprogram [body] when it is:
20089 -- aspect on subprogram declaration
20090 -- aspect on stand-alone subprogram body
20091 -- pragma on stand-alone subprogram body
20093 -- The annotation must prepare its own template when it is:
20095 -- pragma on subprogram declaration
20097 -- * Globals - Capture of global references must occur after full
20100 -- * Instance - The annotation is instantiated automatically when
20101 -- the related generic subprogram [body] is instantiated except for
20102 -- the "pragma on subprogram declaration" case. In that scenario
20103 -- the annotation must instantiate itself.
20107 | Pragma_Precondition
20109 Analyze_Pre_Post_Condition
;
20115 -- pragma Predicate
20116 -- ([Entity =>] type_LOCAL_NAME,
20117 -- [Check =>] boolean_EXPRESSION);
20119 when Pragma_Predicate
=> Predicate
: declare
20126 Check_Arg_Count
(2);
20127 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20128 Check_Optional_Identifier
(Arg2
, Name_Check
);
20130 Check_Arg_Is_Local_Name
(Arg1
);
20132 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20133 Find_Type
(Type_Id
);
20134 Typ
:= Entity
(Type_Id
);
20136 if Typ
= Any_Type
then
20140 -- A pragma that applies to a Ghost entity becomes Ghost for the
20141 -- purposes of legality checks and removal of ignored Ghost code.
20143 Mark_Ghost_Pragma
(N
, Typ
);
20145 -- The remaining processing is simply to link the pragma on to
20146 -- the rep item chain, for processing when the type is frozen.
20147 -- This is accomplished by a call to Rep_Item_Too_Late. We also
20148 -- mark the type as having predicates.
20150 -- If the current policy for predicate checking is Ignore mark the
20151 -- subtype accordingly. In the case of predicates we consider them
20152 -- enabled unless Ignore is specified (either directly or with a
20153 -- general Assertion_Policy pragma) to preserve existing warnings.
20155 Set_Has_Predicates
(Typ
);
20156 Set_Predicates_Ignored
(Typ
,
20157 Present
(Check_Policy_List
)
20159 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
20160 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20163 -----------------------
20164 -- Predicate_Failure --
20165 -----------------------
20167 -- pragma Predicate_Failure
20168 -- ([Entity =>] type_LOCAL_NAME,
20169 -- [Message =>] string_EXPRESSION);
20171 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
20178 Check_Arg_Count
(2);
20179 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20180 Check_Optional_Identifier
(Arg2
, Name_Message
);
20182 Check_Arg_Is_Local_Name
(Arg1
);
20184 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20185 Find_Type
(Type_Id
);
20186 Typ
:= Entity
(Type_Id
);
20188 if Typ
= Any_Type
then
20192 -- A pragma that applies to a Ghost entity becomes Ghost for the
20193 -- purposes of legality checks and removal of ignored Ghost code.
20195 Mark_Ghost_Pragma
(N
, Typ
);
20197 -- The remaining processing is simply to link the pragma on to
20198 -- the rep item chain, for processing when the type is frozen.
20199 -- This is accomplished by a call to Rep_Item_Too_Late.
20201 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20202 end Predicate_Failure
;
20208 -- pragma Preelaborate [(library_unit_NAME)];
20210 -- Set the flag Is_Preelaborated of program unit name entity
20212 when Pragma_Preelaborate
=> Preelaborate
: declare
20213 Pa
: constant Node_Id
:= Parent
(N
);
20214 Pk
: constant Node_Kind
:= Nkind
(Pa
);
20218 Check_Ada_83_Warning
;
20219 Check_Valid_Library_Unit_Pragma
;
20221 if Nkind
(N
) = N_Null_Statement
then
20225 Ent
:= Find_Lib_Unit_Name
;
20227 -- A pragma that applies to a Ghost entity becomes Ghost for the
20228 -- purposes of legality checks and removal of ignored Ghost code.
20230 Mark_Ghost_Pragma
(N
, Ent
);
20231 Check_Duplicate_Pragma
(Ent
);
20233 -- This filters out pragmas inside generic parents that show up
20234 -- inside instantiations. Pragmas that come from aspects in the
20235 -- unit are not ignored.
20237 if Present
(Ent
) then
20238 if Pk
= N_Package_Specification
20239 and then Present
(Generic_Parent
(Pa
))
20240 and then not From_Aspect_Specification
(N
)
20245 if not Debug_Flag_U
then
20246 Set_Is_Preelaborated
(Ent
);
20248 if Legacy_Elaboration_Checks
then
20249 Set_Suppress_Elaboration_Warnings
(Ent
);
20256 -------------------------------
20257 -- Prefix_Exception_Messages --
20258 -------------------------------
20260 -- pragma Prefix_Exception_Messages;
20262 when Pragma_Prefix_Exception_Messages
=>
20264 Check_Valid_Configuration_Pragma
;
20265 Check_Arg_Count
(0);
20266 Prefix_Exception_Messages
:= True;
20272 -- pragma Priority (EXPRESSION);
20274 when Pragma_Priority
=> Priority
: declare
20275 P
: constant Node_Id
:= Parent
(N
);
20280 Check_No_Identifiers
;
20281 Check_Arg_Count
(1);
20285 if Nkind
(P
) = N_Subprogram_Body
then
20286 Check_In_Main_Program
;
20288 Ent
:= Defining_Unit_Name
(Specification
(P
));
20290 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
20291 Ent
:= Defining_Identifier
(Ent
);
20294 Arg
:= Get_Pragma_Arg
(Arg1
);
20295 Analyze_And_Resolve
(Arg
, Standard_Integer
);
20299 if not Is_OK_Static_Expression
(Arg
) then
20300 Flag_Non_Static_Expr
20301 ("main subprogram priority is not static!", Arg
);
20304 -- If constraint error, then we already signalled an error
20306 elsif Raises_Constraint_Error
(Arg
) then
20309 -- Otherwise check in range except if Relaxed_RM_Semantics
20310 -- where we ignore the value if out of range.
20313 if not Relaxed_RM_Semantics
20314 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
20317 ("main subprogram priority is out of range", Arg1
);
20320 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
20324 -- Load an arbitrary entity from System.Tasking.Stages or
20325 -- System.Tasking.Restricted.Stages (depending on the
20326 -- supported profile) to make sure that one of these packages
20327 -- is implicitly with'ed, since we need to have the tasking
20328 -- run time active for the pragma Priority to have any effect.
20329 -- Previously we with'ed the package System.Tasking, but this
20330 -- package does not trigger the required initialization of the
20331 -- run-time library.
20334 Discard
: Entity_Id
;
20335 pragma Warnings
(Off
, Discard
);
20337 if Restricted_Profile
then
20338 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
20340 Discard
:= RTE
(RE_Activate_Tasks
);
20344 -- Task or Protected, must be of type Integer
20346 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
20347 Arg
:= Get_Pragma_Arg
(Arg1
);
20348 Ent
:= Defining_Identifier
(Parent
(P
));
20350 -- The expression must be analyzed in the special manner
20351 -- described in "Handling of Default and Per-Object
20352 -- Expressions" in sem.ads.
20354 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
20356 if not Is_OK_Static_Expression
(Arg
) then
20357 Check_Restriction
(Static_Priorities
, Arg
);
20360 -- Anything else is incorrect
20366 -- Check duplicate pragma before we chain the pragma in the Rep
20367 -- Item chain of Ent.
20369 Check_Duplicate_Pragma
(Ent
);
20370 Record_Rep_Item
(Ent
, N
);
20373 -----------------------------------
20374 -- Priority_Specific_Dispatching --
20375 -----------------------------------
20377 -- pragma Priority_Specific_Dispatching (
20378 -- policy_IDENTIFIER,
20379 -- first_priority_EXPRESSION,
20380 -- last_priority_EXPRESSION);
20382 when Pragma_Priority_Specific_Dispatching
=>
20383 Priority_Specific_Dispatching
: declare
20384 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
20385 -- This is the entity System.Any_Priority;
20388 Lower_Bound
: Node_Id
;
20389 Upper_Bound
: Node_Id
;
20395 Check_Arg_Count
(3);
20396 Check_No_Identifiers
;
20397 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20398 Check_Valid_Configuration_Pragma
;
20399 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20400 DP
:= Fold_Upper
(Name_Buffer
(1));
20402 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
20403 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
20404 Lower_Val
:= Expr_Value
(Lower_Bound
);
20406 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
20407 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
20408 Upper_Val
:= Expr_Value
(Upper_Bound
);
20410 -- It is not allowed to use Task_Dispatching_Policy and
20411 -- Priority_Specific_Dispatching in the same partition.
20413 if Task_Dispatching_Policy
/= ' ' then
20414 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20416 ("pragma% incompatible with Task_Dispatching_Policy#");
20418 -- Check lower bound in range
20420 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20422 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20425 ("first_priority is out of range", Arg2
);
20427 -- Check upper bound in range
20429 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20431 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20434 ("last_priority is out of range", Arg3
);
20436 -- Check that the priority range is valid
20438 elsif Lower_Val
> Upper_Val
then
20440 ("last_priority_expression must be greater than or equal to "
20441 & "first_priority_expression");
20443 -- Store the new policy, but always preserve System_Location since
20444 -- we like the error message with the run-time name.
20447 -- Check overlapping in the priority ranges specified in other
20448 -- Priority_Specific_Dispatching pragmas within the same
20449 -- partition. We can only check those we know about.
20452 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
20454 if Specific_Dispatching
.Table
(J
).First_Priority
in
20455 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20456 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
20457 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20460 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
20462 ("priority range overlaps with "
20463 & "Priority_Specific_Dispatching#");
20467 -- The use of Priority_Specific_Dispatching is incompatible
20468 -- with Task_Dispatching_Policy.
20470 if Task_Dispatching_Policy
/= ' ' then
20471 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20473 ("Priority_Specific_Dispatching incompatible "
20474 & "with Task_Dispatching_Policy#");
20477 -- The use of Priority_Specific_Dispatching forces ceiling
20480 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
20481 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20483 ("Priority_Specific_Dispatching incompatible "
20484 & "with Locking_Policy#");
20486 -- Set the Ceiling_Locking policy, but preserve System_Location
20487 -- since we like the error message with the run time name.
20490 Locking_Policy
:= 'C';
20492 if Locking_Policy_Sloc
/= System_Location
then
20493 Locking_Policy_Sloc
:= Loc
;
20497 -- Add entry in the table
20499 Specific_Dispatching
.Append
20500 ((Dispatching_Policy
=> DP
,
20501 First_Priority
=> UI_To_Int
(Lower_Val
),
20502 Last_Priority
=> UI_To_Int
(Upper_Val
),
20503 Pragma_Loc
=> Loc
));
20505 end Priority_Specific_Dispatching
;
20511 -- pragma Profile (profile_IDENTIFIER);
20513 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
20515 when Pragma_Profile
=>
20517 Check_Arg_Count
(1);
20518 Check_Valid_Configuration_Pragma
;
20519 Check_No_Identifiers
;
20522 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20525 if Chars
(Argx
) = Name_Ravenscar
then
20526 Set_Ravenscar_Profile
(Ravenscar
, N
);
20528 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
20529 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
20531 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
20532 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
20534 elsif Chars
(Argx
) = Name_Restricted
then
20535 Set_Profile_Restrictions
20537 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20539 elsif Chars
(Argx
) = Name_Rational
then
20540 Set_Rational_Profile
;
20542 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20543 Set_Profile_Restrictions
20544 (No_Implementation_Extensions
,
20545 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20548 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20552 ----------------------
20553 -- Profile_Warnings --
20554 ----------------------
20556 -- pragma Profile_Warnings (profile_IDENTIFIER);
20558 -- profile_IDENTIFIER => Restricted | Ravenscar
20560 when Pragma_Profile_Warnings
=>
20562 Check_Arg_Count
(1);
20563 Check_Valid_Configuration_Pragma
;
20564 Check_No_Identifiers
;
20567 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20570 if Chars
(Argx
) = Name_Ravenscar
then
20571 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
20573 elsif Chars
(Argx
) = Name_Restricted
then
20574 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
20576 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20577 Set_Profile_Restrictions
20578 (No_Implementation_Extensions
, N
, Warn
=> True);
20581 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20585 --------------------------
20586 -- Propagate_Exceptions --
20587 --------------------------
20589 -- pragma Propagate_Exceptions;
20591 -- Note: this pragma is obsolete and has no effect
20593 when Pragma_Propagate_Exceptions
=>
20595 Check_Arg_Count
(0);
20597 if Warn_On_Obsolescent_Feature
then
20599 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20600 "and has no effect?j?", N
);
20603 -----------------------------
20604 -- Provide_Shift_Operators --
20605 -----------------------------
20607 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20609 when Pragma_Provide_Shift_Operators
=>
20610 Provide_Shift_Operators
: declare
20613 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
20614 -- Insert declaration and pragma Instrinsic for named shift op
20616 ----------------------------
20617 -- Declare_Shift_Operator --
20618 ----------------------------
20620 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
20626 Make_Subprogram_Declaration
(Loc
,
20627 Make_Function_Specification
(Loc
,
20628 Defining_Unit_Name
=>
20629 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
20631 Result_Definition
=>
20632 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
20634 Parameter_Specifications
=> New_List
(
20635 Make_Parameter_Specification
(Loc
,
20636 Defining_Identifier
=>
20637 Make_Defining_Identifier
(Loc
, Name_Value
),
20639 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
20641 Make_Parameter_Specification
(Loc
,
20642 Defining_Identifier
=>
20643 Make_Defining_Identifier
(Loc
, Name_Amount
),
20645 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
20649 Chars
=> Name_Import
,
20650 Pragma_Argument_Associations
=> New_List
(
20651 Make_Pragma_Argument_Association
(Loc
,
20652 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
20653 Make_Pragma_Argument_Association
(Loc
,
20654 Expression
=> Make_Identifier
(Loc
, Nam
))));
20656 Insert_After
(N
, Import
);
20657 Insert_After
(N
, Func
);
20658 end Declare_Shift_Operator
;
20660 -- Start of processing for Provide_Shift_Operators
20664 Check_Arg_Count
(1);
20665 Check_Arg_Is_Local_Name
(Arg1
);
20667 Arg1
:= Get_Pragma_Arg
(Arg1
);
20669 -- We must have an entity name
20671 if not Is_Entity_Name
(Arg1
) then
20673 ("pragma % must apply to integer first subtype", Arg1
);
20676 -- If no Entity, means there was a prior error so ignore
20678 if Present
(Entity
(Arg1
)) then
20679 Ent
:= Entity
(Arg1
);
20681 -- Apply error checks
20683 if not Is_First_Subtype
(Ent
) then
20685 ("cannot apply pragma %",
20686 "\& is not a first subtype",
20689 elsif not Is_Integer_Type
(Ent
) then
20691 ("cannot apply pragma %",
20692 "\& is not an integer type",
20695 elsif Has_Shift_Operator
(Ent
) then
20697 ("cannot apply pragma %",
20698 "\& already has declared shift operators",
20701 elsif Is_Frozen
(Ent
) then
20703 ("pragma % appears too late",
20704 "\& is already frozen",
20708 -- Now declare the operators. We do this during analysis rather
20709 -- than expansion, since we want the operators available if we
20710 -- are operating in -gnatc or ASIS mode.
20712 Declare_Shift_Operator
(Name_Rotate_Left
);
20713 Declare_Shift_Operator
(Name_Rotate_Right
);
20714 Declare_Shift_Operator
(Name_Shift_Left
);
20715 Declare_Shift_Operator
(Name_Shift_Right
);
20716 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
20718 end Provide_Shift_Operators
;
20724 -- pragma Psect_Object (
20725 -- [Internal =>] LOCAL_NAME,
20726 -- [, [External =>] EXTERNAL_SYMBOL]
20727 -- [, [Size =>] EXTERNAL_SYMBOL]);
20729 when Pragma_Common_Object
20730 | Pragma_Psect_Object
20732 Psect_Object
: declare
20733 Args
: Args_List
(1 .. 3);
20734 Names
: constant Name_List
(1 .. 3) := (
20739 Internal
: Node_Id
renames Args
(1);
20740 External
: Node_Id
renames Args
(2);
20741 Size
: Node_Id
renames Args
(3);
20743 Def_Id
: Entity_Id
;
20745 procedure Check_Arg
(Arg
: Node_Id
);
20746 -- Checks that argument is either a string literal or an
20747 -- identifier, and posts error message if not.
20753 procedure Check_Arg
(Arg
: Node_Id
) is
20755 if not Nkind_In
(Original_Node
(Arg
),
20760 ("inappropriate argument for pragma %", Arg
);
20764 -- Start of processing for Common_Object/Psect_Object
20768 Gather_Associations
(Names
, Args
);
20769 Process_Extended_Import_Export_Internal_Arg
(Internal
);
20771 Def_Id
:= Entity
(Internal
);
20773 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
20775 ("pragma% must designate an object", Internal
);
20778 Check_Arg
(Internal
);
20780 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
20782 ("cannot use pragma% for imported/exported object",
20786 if Is_Concurrent_Type
(Etype
(Internal
)) then
20788 ("cannot specify pragma % for task/protected object",
20792 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
20794 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
20796 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
20799 if Ekind
(Def_Id
) = E_Constant
then
20801 ("cannot specify pragma % for a constant", Internal
);
20804 if Is_Record_Type
(Etype
(Internal
)) then
20810 Ent
:= First_Entity
(Etype
(Internal
));
20811 while Present
(Ent
) loop
20812 Decl
:= Declaration_Node
(Ent
);
20814 if Ekind
(Ent
) = E_Component
20815 and then Nkind
(Decl
) = N_Component_Declaration
20816 and then Present
(Expression
(Decl
))
20817 and then Warn_On_Export_Import
20820 ("?x?object for pragma % has defaults", Internal
);
20830 if Present
(Size
) then
20834 if Present
(External
) then
20835 Check_Arg_Is_External_Name
(External
);
20838 -- If all error tests pass, link pragma on to the rep item chain
20840 Record_Rep_Item
(Def_Id
, N
);
20847 -- pragma Pure [(library_unit_NAME)];
20849 when Pragma_Pure
=> Pure
: declare
20853 Check_Ada_83_Warning
;
20855 -- If the pragma comes from a subprogram instantiation, nothing to
20856 -- check, this can happen at any level of nesting.
20858 if Is_Wrapper_Package
(Current_Scope
) then
20861 Check_Valid_Library_Unit_Pragma
;
20864 if Nkind
(N
) = N_Null_Statement
then
20868 Ent
:= Find_Lib_Unit_Name
;
20870 -- A pragma that applies to a Ghost entity becomes Ghost for the
20871 -- purposes of legality checks and removal of ignored Ghost code.
20873 Mark_Ghost_Pragma
(N
, Ent
);
20875 if not Debug_Flag_U
then
20877 Set_Has_Pragma_Pure
(Ent
);
20879 if Legacy_Elaboration_Checks
then
20880 Set_Suppress_Elaboration_Warnings
(Ent
);
20885 -------------------
20886 -- Pure_Function --
20887 -------------------
20889 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20891 when Pragma_Pure_Function
=> Pure_Function
: declare
20892 Def_Id
: Entity_Id
;
20895 Effective
: Boolean := False;
20899 Check_Arg_Count
(1);
20900 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20901 Check_Arg_Is_Local_Name
(Arg1
);
20902 E_Id
:= Get_Pragma_Arg
(Arg1
);
20904 if Etype
(E_Id
) = Any_Type
then
20908 -- Loop through homonyms (overloadings) of referenced entity
20910 E
:= Entity
(E_Id
);
20912 -- A pragma that applies to a Ghost entity becomes Ghost for the
20913 -- purposes of legality checks and removal of ignored Ghost code.
20915 Mark_Ghost_Pragma
(N
, E
);
20917 if Present
(E
) then
20919 Def_Id
:= Get_Base_Subprogram
(E
);
20921 if not Ekind_In
(Def_Id
, E_Function
,
20922 E_Generic_Function
,
20926 ("pragma% requires a function name", Arg1
);
20929 Set_Is_Pure
(Def_Id
);
20931 if not Has_Pragma_Pure_Function
(Def_Id
) then
20932 Set_Has_Pragma_Pure_Function
(Def_Id
);
20936 exit when From_Aspect_Specification
(N
);
20938 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
20942 and then Warn_On_Redundant_Constructs
20945 ("pragma Pure_Function on& is redundant?r?",
20951 --------------------
20952 -- Queuing_Policy --
20953 --------------------
20955 -- pragma Queuing_Policy (policy_IDENTIFIER);
20957 when Pragma_Queuing_Policy
=> declare
20961 Check_Ada_83_Warning
;
20962 Check_Arg_Count
(1);
20963 Check_No_Identifiers
;
20964 Check_Arg_Is_Queuing_Policy
(Arg1
);
20965 Check_Valid_Configuration_Pragma
;
20966 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20967 QP
:= Fold_Upper
(Name_Buffer
(1));
20969 if Queuing_Policy
/= ' '
20970 and then Queuing_Policy
/= QP
20972 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
20973 Error_Pragma
("queuing policy incompatible with policy#");
20975 -- Set new policy, but always preserve System_Location since we
20976 -- like the error message with the run time name.
20979 Queuing_Policy
:= QP
;
20981 if Queuing_Policy_Sloc
/= System_Location
then
20982 Queuing_Policy_Sloc
:= Loc
;
20991 -- pragma Rational, for compatibility with foreign compiler
20993 when Pragma_Rational
=>
20994 Set_Rational_Profile
;
20996 ---------------------
20997 -- Refined_Depends --
20998 ---------------------
21000 -- pragma Refined_Depends (DEPENDENCY_RELATION);
21002 -- DEPENDENCY_RELATION ::=
21004 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
21006 -- DEPENDENCY_CLAUSE ::=
21007 -- OUTPUT_LIST =>[+] INPUT_LIST
21008 -- | NULL_DEPENDENCY_CLAUSE
21010 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
21012 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
21014 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
21016 -- OUTPUT ::= NAME | FUNCTION_RESULT
21019 -- where FUNCTION_RESULT is a function Result attribute_reference
21021 -- Characteristics:
21023 -- * Analysis - The annotation undergoes initial checks to verify
21024 -- the legal placement and context. Secondary checks fully analyze
21025 -- the dependency clauses/global list in:
21027 -- Analyze_Refined_Depends_In_Decl_Part
21029 -- * Expansion - None.
21031 -- * Template - The annotation utilizes the generic template of the
21032 -- related subprogram body.
21034 -- * Globals - Capture of global references must occur after full
21037 -- * Instance - The annotation is instantiated automatically when
21038 -- the related generic subprogram body is instantiated.
21040 when Pragma_Refined_Depends
=> Refined_Depends
: declare
21041 Body_Id
: Entity_Id
;
21043 Spec_Id
: Entity_Id
;
21046 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21050 -- Chain the pragma on the contract for further processing by
21051 -- Analyze_Refined_Depends_In_Decl_Part.
21053 Add_Contract_Item
(N
, Body_Id
);
21055 -- The legality checks of pragmas Refined_Depends and
21056 -- Refined_Global are affected by the SPARK mode in effect and
21057 -- the volatility of the context. In addition these two pragmas
21058 -- are subject to an inherent order:
21060 -- 1) Refined_Global
21061 -- 2) Refined_Depends
21063 -- Analyze all these pragmas in the order outlined above
21065 Analyze_If_Present
(Pragma_SPARK_Mode
);
21066 Analyze_If_Present
(Pragma_Volatile_Function
);
21067 Analyze_If_Present
(Pragma_Refined_Global
);
21068 Analyze_Refined_Depends_In_Decl_Part
(N
);
21070 end Refined_Depends
;
21072 --------------------
21073 -- Refined_Global --
21074 --------------------
21076 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
21078 -- GLOBAL_SPECIFICATION ::=
21081 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
21083 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
21085 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
21086 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
21087 -- GLOBAL_ITEM ::= NAME
21089 -- Characteristics:
21091 -- * Analysis - The annotation undergoes initial checks to verify
21092 -- the legal placement and context. Secondary checks fully analyze
21093 -- the dependency clauses/global list in:
21095 -- Analyze_Refined_Global_In_Decl_Part
21097 -- * Expansion - None.
21099 -- * Template - The annotation utilizes the generic template of the
21100 -- related subprogram body.
21102 -- * Globals - Capture of global references must occur after full
21105 -- * Instance - The annotation is instantiated automatically when
21106 -- the related generic subprogram body is instantiated.
21108 when Pragma_Refined_Global
=> Refined_Global
: declare
21109 Body_Id
: Entity_Id
;
21111 Spec_Id
: Entity_Id
;
21114 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21118 -- Chain the pragma on the contract for further processing by
21119 -- Analyze_Refined_Global_In_Decl_Part.
21121 Add_Contract_Item
(N
, Body_Id
);
21123 -- The legality checks of pragmas Refined_Depends and
21124 -- Refined_Global are affected by the SPARK mode in effect and
21125 -- the volatility of the context. In addition these two pragmas
21126 -- are subject to an inherent order:
21128 -- 1) Refined_Global
21129 -- 2) Refined_Depends
21131 -- Analyze all these pragmas in the order outlined above
21133 Analyze_If_Present
(Pragma_SPARK_Mode
);
21134 Analyze_If_Present
(Pragma_Volatile_Function
);
21135 Analyze_Refined_Global_In_Decl_Part
(N
);
21136 Analyze_If_Present
(Pragma_Refined_Depends
);
21138 end Refined_Global
;
21144 -- pragma Refined_Post (boolean_EXPRESSION);
21146 -- Characteristics:
21148 -- * Analysis - The annotation is fully analyzed immediately upon
21149 -- elaboration as it cannot forward reference entities.
21151 -- * Expansion - The annotation is expanded during the expansion of
21152 -- the related subprogram body contract as performed in:
21154 -- Expand_Subprogram_Contract
21156 -- * Template - The annotation utilizes the generic template of the
21157 -- related subprogram body.
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.
21165 when Pragma_Refined_Post
=> Refined_Post
: declare
21166 Body_Id
: Entity_Id
;
21168 Spec_Id
: Entity_Id
;
21171 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21173 -- Fully analyze the pragma when it appears inside a subprogram
21174 -- body because it cannot benefit from forward references.
21178 -- Chain the pragma on the contract for completeness
21180 Add_Contract_Item
(N
, Body_Id
);
21182 -- The legality checks of pragma Refined_Post are affected by
21183 -- the SPARK mode in effect and the volatility of the context.
21184 -- Analyze all pragmas in a specific order.
21186 Analyze_If_Present
(Pragma_SPARK_Mode
);
21187 Analyze_If_Present
(Pragma_Volatile_Function
);
21188 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
21190 -- Currently it is not possible to inline pre/postconditions on
21191 -- a subprogram subject to pragma Inline_Always.
21193 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
21197 -------------------
21198 -- Refined_State --
21199 -------------------
21201 -- pragma Refined_State (REFINEMENT_LIST);
21203 -- REFINEMENT_LIST ::=
21204 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
21206 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
21208 -- CONSTITUENT_LIST ::=
21211 -- | (CONSTITUENT {, CONSTITUENT})
21213 -- CONSTITUENT ::= object_NAME | state_NAME
21215 -- Characteristics:
21217 -- * Analysis - The annotation undergoes initial checks to verify
21218 -- the legal placement and context. Secondary checks preanalyze the
21219 -- refinement clauses in:
21221 -- Analyze_Refined_State_In_Decl_Part
21223 -- * Expansion - None.
21225 -- * Template - The annotation utilizes the template of the related
21228 -- * Globals - Capture of global references must occur after full
21231 -- * Instance - The annotation is instantiated automatically when
21232 -- the related generic package body is instantiated.
21234 when Pragma_Refined_State
=> Refined_State
: declare
21235 Pack_Decl
: Node_Id
;
21236 Spec_Id
: Entity_Id
;
21240 Check_No_Identifiers
;
21241 Check_Arg_Count
(1);
21243 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
21245 -- Ensure the proper placement of the pragma. Refined states must
21246 -- be associated with a package body.
21248 if Nkind
(Pack_Decl
) = N_Package_Body
then
21251 -- Otherwise the pragma is associated with an illegal construct
21258 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
21260 -- A pragma that applies to a Ghost entity becomes Ghost for the
21261 -- purposes of legality checks and removal of ignored Ghost code.
21263 Mark_Ghost_Pragma
(N
, Spec_Id
);
21265 -- Chain the pragma on the contract for further processing by
21266 -- Analyze_Refined_State_In_Decl_Part.
21268 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
21270 -- The legality checks of pragma Refined_State are affected by the
21271 -- SPARK mode in effect. Analyze all pragmas in a specific order.
21273 Analyze_If_Present
(Pragma_SPARK_Mode
);
21275 -- State refinement is allowed only when the corresponding package
21276 -- declaration has non-null pragma Abstract_State. Refinement not
21277 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
21279 if SPARK_Mode
/= Off
21281 (No
(Abstract_States
(Spec_Id
))
21282 or else Has_Null_Abstract_State
(Spec_Id
))
21285 ("useless refinement, package & does not define abstract "
21286 & "states", N
, Spec_Id
);
21291 -----------------------
21292 -- Relative_Deadline --
21293 -----------------------
21295 -- pragma Relative_Deadline (time_span_EXPRESSION);
21297 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
21298 P
: constant Node_Id
:= Parent
(N
);
21303 Check_No_Identifiers
;
21304 Check_Arg_Count
(1);
21306 Arg
:= Get_Pragma_Arg
(Arg1
);
21308 -- The expression must be analyzed in the special manner described
21309 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
21311 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
21315 if Nkind
(P
) = N_Subprogram_Body
then
21316 Check_In_Main_Program
;
21318 -- Only Task and subprogram cases allowed
21320 elsif Nkind
(P
) /= N_Task_Definition
then
21324 -- Check duplicate pragma before we set the corresponding flag
21326 if Has_Relative_Deadline_Pragma
(P
) then
21327 Error_Pragma
("duplicate pragma% not allowed");
21330 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
21331 -- Relative_Deadline pragma node cannot be inserted in the Rep
21332 -- Item chain of Ent since it is rewritten by the expander as a
21333 -- procedure call statement that will break the chain.
21335 Set_Has_Relative_Deadline_Pragma
(P
);
21336 end Relative_Deadline
;
21338 ------------------------
21339 -- Remote_Access_Type --
21340 ------------------------
21342 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
21344 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
21349 Check_Arg_Count
(1);
21350 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21351 Check_Arg_Is_Local_Name
(Arg1
);
21353 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
21355 -- A pragma that applies to a Ghost entity becomes Ghost for the
21356 -- purposes of legality checks and removal of ignored Ghost code.
21358 Mark_Ghost_Pragma
(N
, E
);
21360 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
21361 and then Ekind
(E
) = E_General_Access_Type
21362 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
21363 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
21365 and then Is_Valid_Remote_Object_Type
21366 (Root_Type
(Directly_Designated_Type
(E
)))
21368 Set_Is_Remote_Types
(E
);
21372 ("pragma% applies only to formal access-to-class-wide types",
21375 end Remote_Access_Type
;
21377 ---------------------------
21378 -- Remote_Call_Interface --
21379 ---------------------------
21381 -- pragma Remote_Call_Interface [(library_unit_NAME)];
21383 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
21384 Cunit_Node
: Node_Id
;
21385 Cunit_Ent
: Entity_Id
;
21389 Check_Ada_83_Warning
;
21390 Check_Valid_Library_Unit_Pragma
;
21392 if Nkind
(N
) = N_Null_Statement
then
21396 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21397 K
:= Nkind
(Unit
(Cunit_Node
));
21398 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21400 -- A pragma that applies to a Ghost entity becomes Ghost for the
21401 -- purposes of legality checks and removal of ignored Ghost code.
21403 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21405 if K
= N_Package_Declaration
21406 or else K
= N_Generic_Package_Declaration
21407 or else K
= N_Subprogram_Declaration
21408 or else K
= N_Generic_Subprogram_Declaration
21409 or else (K
= N_Subprogram_Body
21410 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
21415 "pragma% must apply to package or subprogram declaration");
21418 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
21419 end Remote_Call_Interface
;
21425 -- pragma Remote_Types [(library_unit_NAME)];
21427 when Pragma_Remote_Types
=> Remote_Types
: declare
21428 Cunit_Node
: Node_Id
;
21429 Cunit_Ent
: Entity_Id
;
21432 Check_Ada_83_Warning
;
21433 Check_Valid_Library_Unit_Pragma
;
21435 if Nkind
(N
) = N_Null_Statement
then
21439 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21440 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21442 -- A pragma that applies to a Ghost entity becomes Ghost for the
21443 -- purposes of legality checks and removal of ignored Ghost code.
21445 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21447 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21448 N_Generic_Package_Declaration
)
21451 ("pragma% can only apply to a package declaration");
21454 Set_Is_Remote_Types
(Cunit_Ent
);
21461 -- pragma Ravenscar;
21463 when Pragma_Ravenscar
=>
21465 Check_Arg_Count
(0);
21466 Check_Valid_Configuration_Pragma
;
21467 Set_Ravenscar_Profile
(Ravenscar
, N
);
21469 if Warn_On_Obsolescent_Feature
then
21471 ("pragma Ravenscar is an obsolescent feature?j?", N
);
21473 ("|use pragma Profile (Ravenscar) instead?j?", N
);
21476 -------------------------
21477 -- Restricted_Run_Time --
21478 -------------------------
21480 -- pragma Restricted_Run_Time;
21482 when Pragma_Restricted_Run_Time
=>
21484 Check_Arg_Count
(0);
21485 Check_Valid_Configuration_Pragma
;
21486 Set_Profile_Restrictions
21487 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
21489 if Warn_On_Obsolescent_Feature
then
21491 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
21494 ("|use pragma Profile (Restricted) instead?j?", N
);
21501 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
21504 -- restriction_IDENTIFIER
21505 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21507 when Pragma_Restrictions
=>
21508 Process_Restrictions_Or_Restriction_Warnings
21509 (Warn
=> Treat_Restrictions_As_Warnings
);
21511 --------------------------
21512 -- Restriction_Warnings --
21513 --------------------------
21515 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
21518 -- restriction_IDENTIFIER
21519 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21521 when Pragma_Restriction_Warnings
=>
21523 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
21529 -- pragma Reviewable;
21531 when Pragma_Reviewable
=>
21532 Check_Ada_83_Warning
;
21533 Check_Arg_Count
(0);
21535 -- Call dummy debugging function rv. This is done to assist front
21536 -- end debugging. By placing a Reviewable pragma in the source
21537 -- program, a breakpoint on rv catches this place in the source,
21538 -- allowing convenient stepping to the point of interest.
21542 --------------------------
21543 -- Secondary_Stack_Size --
21544 --------------------------
21546 -- pragma Secondary_Stack_Size (EXPRESSION);
21548 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
21549 P
: constant Node_Id
:= Parent
(N
);
21555 Check_No_Identifiers
;
21556 Check_Arg_Count
(1);
21558 if Nkind
(P
) = N_Task_Definition
then
21559 Arg
:= Get_Pragma_Arg
(Arg1
);
21560 Ent
:= Defining_Identifier
(Parent
(P
));
21562 -- The expression must be analyzed in the special manner
21563 -- described in "Handling of Default Expressions" in sem.ads.
21565 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21567 -- The pragma cannot appear if the No_Secondary_Stack
21568 -- restriction is in effect.
21570 Check_Restriction
(No_Secondary_Stack
, Arg
);
21572 -- Anything else is incorrect
21578 -- Check duplicate pragma before we chain the pragma in the Rep
21579 -- Item chain of Ent.
21581 Check_Duplicate_Pragma
(Ent
);
21582 Record_Rep_Item
(Ent
, N
);
21583 end Secondary_Stack_Size
;
21585 --------------------------
21586 -- Short_Circuit_And_Or --
21587 --------------------------
21589 -- pragma Short_Circuit_And_Or;
21591 when Pragma_Short_Circuit_And_Or
=>
21593 Check_Arg_Count
(0);
21594 Check_Valid_Configuration_Pragma
;
21595 Short_Circuit_And_Or
:= True;
21597 -------------------
21598 -- Share_Generic --
21599 -------------------
21601 -- pragma Share_Generic (GNAME {, GNAME});
21603 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21605 when Pragma_Share_Generic
=>
21607 Process_Generic_List
;
21613 -- pragma Shared (LOCAL_NAME);
21615 when Pragma_Shared
=>
21617 Process_Atomic_Independent_Shared_Volatile
;
21619 --------------------
21620 -- Shared_Passive --
21621 --------------------
21623 -- pragma Shared_Passive [(library_unit_NAME)];
21625 -- Set the flag Is_Shared_Passive of program unit name entity
21627 when Pragma_Shared_Passive
=> Shared_Passive
: declare
21628 Cunit_Node
: Node_Id
;
21629 Cunit_Ent
: Entity_Id
;
21632 Check_Ada_83_Warning
;
21633 Check_Valid_Library_Unit_Pragma
;
21635 if Nkind
(N
) = N_Null_Statement
then
21639 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21640 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21642 -- A pragma that applies to a Ghost entity becomes Ghost for the
21643 -- purposes of legality checks and removal of ignored Ghost code.
21645 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21647 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21648 N_Generic_Package_Declaration
)
21651 ("pragma% can only apply to a package declaration");
21654 Set_Is_Shared_Passive
(Cunit_Ent
);
21655 end Shared_Passive
;
21657 -----------------------
21658 -- Short_Descriptors --
21659 -----------------------
21661 -- pragma Short_Descriptors;
21663 -- Recognize and validate, but otherwise ignore
21665 when Pragma_Short_Descriptors
=>
21667 Check_Arg_Count
(0);
21668 Check_Valid_Configuration_Pragma
;
21670 ------------------------------
21671 -- Simple_Storage_Pool_Type --
21672 ------------------------------
21674 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21676 when Pragma_Simple_Storage_Pool_Type
=>
21677 Simple_Storage_Pool_Type
: declare
21683 Check_Arg_Count
(1);
21684 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21686 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21687 Find_Type
(Type_Id
);
21688 Typ
:= Entity
(Type_Id
);
21690 if Typ
= Any_Type
then
21694 -- A pragma that applies to a Ghost entity becomes Ghost for the
21695 -- purposes of legality checks and removal of ignored Ghost code.
21697 Mark_Ghost_Pragma
(N
, Typ
);
21699 -- We require the pragma to apply to a type declared in a package
21700 -- declaration, but not (immediately) within a package body.
21702 if Ekind
(Current_Scope
) /= E_Package
21703 or else In_Package_Body
(Current_Scope
)
21706 ("pragma% can only apply to type declared immediately "
21707 & "within a package declaration");
21710 -- A simple storage pool type must be an immutably limited record
21711 -- or private type. If the pragma is given for a private type,
21712 -- the full type is similarly restricted (which is checked later
21713 -- in Freeze_Entity).
21715 if Is_Record_Type
(Typ
)
21716 and then not Is_Limited_View
(Typ
)
21719 ("pragma% can only apply to explicitly limited record type");
21721 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
21723 ("pragma% can only apply to a private type that is limited");
21725 elsif not Is_Record_Type
(Typ
)
21726 and then not Is_Private_Type
(Typ
)
21729 ("pragma% can only apply to limited record or private type");
21732 Record_Rep_Item
(Typ
, N
);
21733 end Simple_Storage_Pool_Type
;
21735 ----------------------
21736 -- Source_File_Name --
21737 ----------------------
21739 -- There are five forms for this pragma:
21741 -- pragma Source_File_Name (
21742 -- [UNIT_NAME =>] unit_NAME,
21743 -- BODY_FILE_NAME => STRING_LITERAL
21744 -- [, [INDEX =>] INTEGER_LITERAL]);
21746 -- pragma Source_File_Name (
21747 -- [UNIT_NAME =>] unit_NAME,
21748 -- SPEC_FILE_NAME => STRING_LITERAL
21749 -- [, [INDEX =>] INTEGER_LITERAL]);
21751 -- pragma Source_File_Name (
21752 -- BODY_FILE_NAME => STRING_LITERAL
21753 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21754 -- [, CASING => CASING_SPEC]);
21756 -- pragma Source_File_Name (
21757 -- SPEC_FILE_NAME => STRING_LITERAL
21758 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21759 -- [, CASING => CASING_SPEC]);
21761 -- pragma Source_File_Name (
21762 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21763 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21764 -- [, CASING => CASING_SPEC]);
21766 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21768 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21769 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21770 -- only be used when no project file is used, while SFNP can only be
21771 -- used when a project file is used.
21773 -- No processing here. Processing was completed during parsing, since
21774 -- we need to have file names set as early as possible. Units are
21775 -- loaded well before semantic processing starts.
21777 -- The only processing we defer to this point is the check for
21778 -- correct placement.
21780 when Pragma_Source_File_Name
=>
21782 Check_Valid_Configuration_Pragma
;
21784 ------------------------------
21785 -- Source_File_Name_Project --
21786 ------------------------------
21788 -- See Source_File_Name for syntax
21790 -- No processing here. Processing was completed during parsing, since
21791 -- we need to have file names set as early as possible. Units are
21792 -- loaded well before semantic processing starts.
21794 -- The only processing we defer to this point is the check for
21795 -- correct placement.
21797 when Pragma_Source_File_Name_Project
=>
21799 Check_Valid_Configuration_Pragma
;
21801 -- Check that a pragma Source_File_Name_Project is used only in a
21802 -- configuration pragmas file.
21804 -- Pragmas Source_File_Name_Project should only be generated by
21805 -- the Project Manager in configuration pragmas files.
21807 -- This is really an ugly test. It seems to depend on some
21808 -- accidental and undocumented property. At the very least it
21809 -- needs to be documented, but it would be better to have a
21810 -- clean way of testing if we are in a configuration file???
21812 if Present
(Parent
(N
)) then
21814 ("pragma% can only appear in a configuration pragmas file");
21817 ----------------------
21818 -- Source_Reference --
21819 ----------------------
21821 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21823 -- Nothing to do, all processing completed in Par.Prag, since we need
21824 -- the information for possible parser messages that are output.
21826 when Pragma_Source_Reference
=>
21833 -- pragma SPARK_Mode [(On | Off)];
21835 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
21836 Mode_Id
: SPARK_Mode_Type
;
21838 procedure Check_Pragma_Conformance
21839 (Context_Pragma
: Node_Id
;
21840 Entity
: Entity_Id
;
21841 Entity_Pragma
: Node_Id
);
21842 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21843 -- conformance of pragma N depending the following scenarios:
21845 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21846 -- compatible with the pragma Context_Pragma that was inherited
21847 -- from the context:
21848 -- * If the mode of Context_Pragma is ON, then the new mode can
21850 -- * If the mode of Context_Pragma is OFF, then the only allowed
21851 -- new mode is also OFF. Emit error if this is not the case.
21853 -- If Entity is not Empty, verify that pragma N is compatible with
21854 -- pragma Entity_Pragma that belongs to Entity.
21855 -- * If Entity_Pragma is Empty, always issue an error as this
21856 -- corresponds to the case where a previous section of Entity
21857 -- has no SPARK_Mode set.
21858 -- * If the mode of Entity_Pragma is ON, then the new mode can
21860 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21861 -- new mode is also OFF. Emit error if this is not the case.
21863 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
21864 -- Subsidiary to routines Process_xxx. Verify that the related
21865 -- entity E subject to pragma SPARK_Mode is library-level.
21867 procedure Process_Body
(Decl
: Node_Id
);
21868 -- Verify the legality of pragma SPARK_Mode when it appears as the
21869 -- top of the body declarations of entry, package, protected unit,
21870 -- subprogram or task unit body denoted by Decl.
21872 procedure Process_Overloadable
(Decl
: Node_Id
);
21873 -- Verify the legality of pragma SPARK_Mode when it applies to an
21874 -- entry or [generic] subprogram declaration denoted by Decl.
21876 procedure Process_Private_Part
(Decl
: Node_Id
);
21877 -- Verify the legality of pragma SPARK_Mode when it appears at the
21878 -- top of the private declarations of a package spec, protected or
21879 -- task unit declaration denoted by Decl.
21881 procedure Process_Statement_Part
(Decl
: Node_Id
);
21882 -- Verify the legality of pragma SPARK_Mode when it appears at the
21883 -- top of the statement sequence of a package body denoted by node
21886 procedure Process_Visible_Part
(Decl
: Node_Id
);
21887 -- Verify the legality of pragma SPARK_Mode when it appears at the
21888 -- top of the visible declarations of a package spec, protected or
21889 -- task unit declaration denoted by Decl. The routine is also used
21890 -- on protected or task units declared without a definition.
21892 procedure Set_SPARK_Context
;
21893 -- Subsidiary to routines Process_xxx. Set the global variables
21894 -- which represent the mode of the context from pragma N. Ensure
21895 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21897 ------------------------------
21898 -- Check_Pragma_Conformance --
21899 ------------------------------
21901 procedure Check_Pragma_Conformance
21902 (Context_Pragma
: Node_Id
;
21903 Entity
: Entity_Id
;
21904 Entity_Pragma
: Node_Id
)
21906 Err_Id
: Entity_Id
;
21910 -- The current pragma may appear without an argument. If this
21911 -- is the case, associate all error messages with the pragma
21914 if Present
(Arg1
) then
21920 -- The mode of the current pragma is compared against that of
21921 -- an enclosing context.
21923 if Present
(Context_Pragma
) then
21924 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
21926 -- Issue an error if the new mode is less restrictive than
21927 -- that of the context.
21929 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
21930 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21933 ("cannot change SPARK_Mode from Off to On", Err_N
);
21934 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21935 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
21940 -- The mode of the current pragma is compared against that of
21941 -- an initial package, protected type, subprogram or task type
21944 if Present
(Entity
) then
21946 -- A simple protected or task type is transformed into an
21947 -- anonymous type whose name cannot be used to issue error
21948 -- messages. Recover the original entity of the type.
21950 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
21953 (Original_Node
(Unit_Declaration_Node
(Entity
)));
21958 -- Both the initial declaration and the completion carry
21959 -- SPARK_Mode pragmas.
21961 if Present
(Entity_Pragma
) then
21962 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
21964 -- Issue an error if the new mode is less restrictive
21965 -- than that of the initial declaration.
21967 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
21968 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21970 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21971 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
21973 ("\value Off was set for SPARK_Mode on&#",
21978 -- Otherwise the initial declaration lacks a SPARK_Mode
21979 -- pragma in which case the current pragma is illegal as
21980 -- it cannot "complete".
21983 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21984 Error_Msg_Sloc
:= Sloc
(Err_Id
);
21986 ("\no value was set for SPARK_Mode on&#",
21991 end Check_Pragma_Conformance
;
21993 --------------------------------
21994 -- Check_Library_Level_Entity --
21995 --------------------------------
21997 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
21998 procedure Add_Entity_To_Name_Buffer
;
21999 -- Add the E_Kind of entity E to the name buffer
22001 -------------------------------
22002 -- Add_Entity_To_Name_Buffer --
22003 -------------------------------
22005 procedure Add_Entity_To_Name_Buffer
is
22007 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
22008 Add_Str_To_Name_Buffer
("entry");
22010 elsif Ekind_In
(E
, E_Generic_Package
,
22014 Add_Str_To_Name_Buffer
("package");
22016 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
22017 Add_Str_To_Name_Buffer
("protected type");
22019 elsif Ekind_In
(E
, E_Function
,
22020 E_Generic_Function
,
22021 E_Generic_Procedure
,
22025 Add_Str_To_Name_Buffer
("subprogram");
22028 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
22029 Add_Str_To_Name_Buffer
("task type");
22031 end Add_Entity_To_Name_Buffer
;
22035 Msg_1
: constant String := "incorrect placement of pragma%";
22038 -- Start of processing for Check_Library_Level_Entity
22041 if not Is_Library_Level_Entity
(E
) then
22042 Error_Msg_Name_1
:= Pname
;
22043 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
22046 Add_Str_To_Name_Buffer
("\& is not a library-level ");
22047 Add_Entity_To_Name_Buffer
;
22049 Msg_2
:= Name_Find
;
22050 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
22054 end Check_Library_Level_Entity
;
22060 procedure Process_Body
(Decl
: Node_Id
) is
22061 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22062 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
22065 -- Ignore pragma when applied to the special body created for
22066 -- inlining, recognized by its internal name _Parent.
22068 if Chars
(Body_Id
) = Name_uParent
then
22072 Check_Library_Level_Entity
(Body_Id
);
22074 -- For entry bodies, verify the legality against:
22075 -- * The mode of the context
22076 -- * The mode of the spec (if any)
22078 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
22080 -- A stand-alone subprogram body
22082 if Body_Id
= Spec_Id
then
22083 Check_Pragma_Conformance
22084 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22086 Entity_Pragma
=> Empty
);
22088 -- An entry or subprogram body that completes a previous
22092 Check_Pragma_Conformance
22093 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22095 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22099 Set_SPARK_Pragma
(Body_Id
, N
);
22100 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22102 -- For package bodies, verify the legality against:
22103 -- * The mode of the context
22104 -- * The mode of the private part
22106 -- This case is separated from protected and task bodies
22107 -- because the statement part of the package body inherits
22108 -- the mode of the body declarations.
22110 elsif Nkind
(Decl
) = N_Package_Body
then
22111 Check_Pragma_Conformance
22112 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22114 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22117 Set_SPARK_Pragma
(Body_Id
, N
);
22118 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22119 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22120 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
22122 -- For protected and task bodies, verify the legality against:
22123 -- * The mode of the context
22124 -- * The mode of the private part
22128 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
22130 Check_Pragma_Conformance
22131 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22133 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22136 Set_SPARK_Pragma
(Body_Id
, N
);
22137 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22141 --------------------------
22142 -- Process_Overloadable --
22143 --------------------------
22145 procedure Process_Overloadable
(Decl
: Node_Id
) is
22146 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22147 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
22150 Check_Library_Level_Entity
(Spec_Id
);
22152 -- Verify the legality against:
22153 -- * The mode of the context
22155 Check_Pragma_Conformance
22156 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22158 Entity_Pragma
=> Empty
);
22160 Set_SPARK_Pragma
(Spec_Id
, N
);
22161 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22163 -- When the pragma applies to the anonymous object created for
22164 -- a single task type, decorate the type as well. This scenario
22165 -- arises when the single task type lacks a task definition,
22166 -- therefore there is no issue with respect to a potential
22167 -- pragma SPARK_Mode in the private part.
22169 -- task type Anon_Task_Typ;
22170 -- Obj : Anon_Task_Typ;
22171 -- pragma SPARK_Mode ...;
22173 if Is_Single_Task_Object
(Spec_Id
) then
22174 Set_SPARK_Pragma
(Spec_Typ
, N
);
22175 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
22176 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
22177 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
22179 end Process_Overloadable
;
22181 --------------------------
22182 -- Process_Private_Part --
22183 --------------------------
22185 procedure Process_Private_Part
(Decl
: Node_Id
) is
22186 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22189 Check_Library_Level_Entity
(Spec_Id
);
22191 -- Verify the legality against:
22192 -- * The mode of the visible declarations
22194 Check_Pragma_Conformance
22195 (Context_Pragma
=> Empty
,
22197 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22200 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22201 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
22202 end Process_Private_Part
;
22204 ----------------------------
22205 -- Process_Statement_Part --
22206 ----------------------------
22208 procedure Process_Statement_Part
(Decl
: Node_Id
) is
22209 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22212 Check_Library_Level_Entity
(Body_Id
);
22214 -- Verify the legality against:
22215 -- * The mode of the body declarations
22217 Check_Pragma_Conformance
22218 (Context_Pragma
=> Empty
,
22220 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
22223 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22224 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
22225 end Process_Statement_Part
;
22227 --------------------------
22228 -- Process_Visible_Part --
22229 --------------------------
22231 procedure Process_Visible_Part
(Decl
: Node_Id
) is
22232 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22233 Obj_Id
: Entity_Id
;
22236 Check_Library_Level_Entity
(Spec_Id
);
22238 -- Verify the legality against:
22239 -- * The mode of the context
22241 Check_Pragma_Conformance
22242 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22244 Entity_Pragma
=> Empty
);
22246 -- A task unit declared without a definition does not set the
22247 -- SPARK_Mode of the context because the task does not have any
22248 -- entries that could inherit the mode.
22250 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
22251 N_Task_Type_Declaration
)
22256 Set_SPARK_Pragma
(Spec_Id
, N
);
22257 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22258 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22259 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
22261 -- When the pragma applies to a single protected or task type,
22262 -- decorate the corresponding anonymous object as well.
22264 -- protected Anon_Prot_Typ is
22265 -- pragma SPARK_Mode ...;
22267 -- end Anon_Prot_Typ;
22269 -- Obj : Anon_Prot_Typ;
22271 if Is_Single_Concurrent_Type
(Spec_Id
) then
22272 Obj_Id
:= Anonymous_Object
(Spec_Id
);
22274 Set_SPARK_Pragma
(Obj_Id
, N
);
22275 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
22277 end Process_Visible_Part
;
22279 -----------------------
22280 -- Set_SPARK_Context --
22281 -----------------------
22283 procedure Set_SPARK_Context
is
22285 SPARK_Mode
:= Mode_Id
;
22286 SPARK_Mode_Pragma
:= N
;
22287 end Set_SPARK_Context
;
22295 -- Start of processing for Do_SPARK_Mode
22298 -- When a SPARK_Mode pragma appears inside an instantiation whose
22299 -- enclosing context has SPARK_Mode set to "off", the pragma has
22300 -- no semantic effect.
22302 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
22303 Rewrite
(N
, Make_Null_Statement
(Loc
));
22309 Check_No_Identifiers
;
22310 Check_At_Most_N_Arguments
(1);
22312 -- Check the legality of the mode (no argument = ON)
22314 if Arg_Count
= 1 then
22315 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22316 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
22321 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
22322 Context
:= Parent
(N
);
22324 -- The pragma appears in a configuration file
22326 if No
(Context
) then
22327 Check_Valid_Configuration_Pragma
;
22329 if Present
(SPARK_Mode_Pragma
) then
22332 Prev
=> SPARK_Mode_Pragma
);
22338 -- The pragma acts as a configuration pragma in a compilation unit
22340 -- pragma SPARK_Mode ...;
22341 -- package Pack is ...;
22343 elsif Nkind
(Context
) = N_Compilation_Unit
22344 and then List_Containing
(N
) = Context_Items
(Context
)
22346 Check_Valid_Configuration_Pragma
;
22349 -- Otherwise the placement of the pragma within the tree dictates
22350 -- its associated construct. Inspect the declarative list where
22351 -- the pragma resides to find a potential construct.
22355 while Present
(Stmt
) loop
22357 -- Skip prior pragmas, but check for duplicates. Note that
22358 -- this also takes care of pragmas generated for aspects.
22360 if Nkind
(Stmt
) = N_Pragma
then
22361 if Pragma_Name
(Stmt
) = Pname
then
22368 -- The pragma applies to an expression function that has
22369 -- already been rewritten into a subprogram declaration.
22371 -- function Expr_Func return ... is (...);
22372 -- pragma SPARK_Mode ...;
22374 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
22375 and then Nkind
(Original_Node
(Stmt
)) =
22376 N_Expression_Function
22378 Process_Overloadable
(Stmt
);
22381 -- The pragma applies to the anonymous object created for a
22382 -- single concurrent type.
22384 -- protected type Anon_Prot_Typ ...;
22385 -- Obj : Anon_Prot_Typ;
22386 -- pragma SPARK_Mode ...;
22388 elsif Nkind
(Stmt
) = N_Object_Declaration
22389 and then Is_Single_Concurrent_Object
22390 (Defining_Entity
(Stmt
))
22392 Process_Overloadable
(Stmt
);
22395 -- Skip internally generated code
22397 elsif not Comes_From_Source
(Stmt
) then
22400 -- The pragma applies to an entry or [generic] subprogram
22404 -- pragma SPARK_Mode ...;
22407 -- procedure Proc ...;
22408 -- pragma SPARK_Mode ...;
22410 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
22411 N_Subprogram_Declaration
)
22412 or else (Nkind
(Stmt
) = N_Entry_Declaration
22413 and then Is_Protected_Type
22414 (Scope
(Defining_Entity
(Stmt
))))
22416 Process_Overloadable
(Stmt
);
22419 -- Otherwise the pragma does not apply to a legal construct
22420 -- or it does not appear at the top of a declarative or a
22421 -- statement list. Issue an error and stop the analysis.
22431 -- The pragma applies to a package or a subprogram that acts as
22432 -- a compilation unit.
22434 -- procedure Proc ...;
22435 -- pragma SPARK_Mode ...;
22437 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
22438 Context
:= Unit
(Parent
(Context
));
22441 -- The pragma appears at the top of entry, package, protected
22442 -- unit, subprogram or task unit body declarations.
22444 -- entry Ent when ... is
22445 -- pragma SPARK_Mode ...;
22447 -- package body Pack is
22448 -- pragma SPARK_Mode ...;
22450 -- procedure Proc ... is
22451 -- pragma SPARK_Mode;
22453 -- protected body Prot is
22454 -- pragma SPARK_Mode ...;
22456 if Nkind_In
(Context
, N_Entry_Body
,
22462 Process_Body
(Context
);
22464 -- The pragma appears at the top of the visible or private
22465 -- declaration of a package spec, protected or task unit.
22468 -- pragma SPARK_Mode ...;
22470 -- pragma SPARK_Mode ...;
22472 -- protected [type] Prot is
22473 -- pragma SPARK_Mode ...;
22475 -- pragma SPARK_Mode ...;
22477 elsif Nkind_In
(Context
, N_Package_Specification
,
22478 N_Protected_Definition
,
22481 if List_Containing
(N
) = Visible_Declarations
(Context
) then
22482 Process_Visible_Part
(Parent
(Context
));
22484 Process_Private_Part
(Parent
(Context
));
22487 -- The pragma appears at the top of package body statements
22489 -- package body Pack is
22491 -- pragma SPARK_Mode;
22493 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
22494 and then Nkind
(Parent
(Context
)) = N_Package_Body
22496 Process_Statement_Part
(Parent
(Context
));
22498 -- The pragma appeared as an aspect of a [generic] subprogram
22499 -- declaration that acts as a compilation unit.
22502 -- procedure Proc ...;
22503 -- pragma SPARK_Mode ...;
22505 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
22506 N_Subprogram_Declaration
)
22508 Process_Overloadable
(Context
);
22510 -- The pragma does not apply to a legal construct, issue error
22518 --------------------------------
22519 -- Static_Elaboration_Desired --
22520 --------------------------------
22522 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
22524 when Pragma_Static_Elaboration_Desired
=>
22526 Check_At_Most_N_Arguments
(1);
22528 if Is_Compilation_Unit
(Current_Scope
)
22529 and then Ekind
(Current_Scope
) = E_Package
22531 Set_Static_Elaboration_Desired
(Current_Scope
, True);
22533 Error_Pragma
("pragma% must apply to a library-level package");
22540 -- pragma Storage_Size (EXPRESSION);
22542 when Pragma_Storage_Size
=> Storage_Size
: declare
22543 P
: constant Node_Id
:= Parent
(N
);
22547 Check_No_Identifiers
;
22548 Check_Arg_Count
(1);
22550 -- The expression must be analyzed in the special manner described
22551 -- in "Handling of Default Expressions" in sem.ads.
22553 Arg
:= Get_Pragma_Arg
(Arg1
);
22554 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22556 if not Is_OK_Static_Expression
(Arg
) then
22557 Check_Restriction
(Static_Storage_Size
, Arg
);
22560 if Nkind
(P
) /= N_Task_Definition
then
22565 if Has_Storage_Size_Pragma
(P
) then
22566 Error_Pragma
("duplicate pragma% not allowed");
22568 Set_Has_Storage_Size_Pragma
(P
, True);
22571 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
22579 -- pragma Storage_Unit (NUMERIC_LITERAL);
22581 -- Only permitted argument is System'Storage_Unit value
22583 when Pragma_Storage_Unit
=>
22584 Check_No_Identifiers
;
22585 Check_Arg_Count
(1);
22586 Check_Arg_Is_Integer_Literal
(Arg1
);
22588 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
22589 UI_From_Int
(Ttypes
.System_Storage_Unit
)
22591 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
22593 ("the only allowed argument for pragma% is ^", Arg1
);
22596 --------------------
22597 -- Stream_Convert --
22598 --------------------
22600 -- pragma Stream_Convert (
22601 -- [Entity =>] type_LOCAL_NAME,
22602 -- [Read =>] function_NAME,
22603 -- [Write =>] function NAME);
22605 when Pragma_Stream_Convert
=> Stream_Convert
: declare
22606 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
22607 -- Check that the given argument is the name of a local function
22608 -- of one argument that is not overloaded earlier in the current
22609 -- local scope. A check is also made that the argument is a
22610 -- function with one parameter.
22612 --------------------------------------
22613 -- Check_OK_Stream_Convert_Function --
22614 --------------------------------------
22616 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
22620 Check_Arg_Is_Local_Name
(Arg
);
22621 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
22623 if Has_Homonym
(Ent
) then
22625 ("argument for pragma% may not be overloaded", Arg
);
22628 if Ekind
(Ent
) /= E_Function
22629 or else No
(First_Formal
(Ent
))
22630 or else Present
(Next_Formal
(First_Formal
(Ent
)))
22633 ("argument for pragma% must be function of one argument",
22636 end Check_OK_Stream_Convert_Function
;
22638 -- Start of processing for Stream_Convert
22642 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
22643 Check_Arg_Count
(3);
22644 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22645 Check_Optional_Identifier
(Arg2
, Name_Read
);
22646 Check_Optional_Identifier
(Arg3
, Name_Write
);
22647 Check_Arg_Is_Local_Name
(Arg1
);
22648 Check_OK_Stream_Convert_Function
(Arg2
);
22649 Check_OK_Stream_Convert_Function
(Arg3
);
22652 Typ
: constant Entity_Id
:=
22653 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
22654 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
22655 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
22658 Check_First_Subtype
(Arg1
);
22660 -- Check for too early or too late. Note that we don't enforce
22661 -- the rule about primitive operations in this case, since, as
22662 -- is the case for explicit stream attributes themselves, these
22663 -- restrictions are not appropriate. Note that the chaining of
22664 -- the pragma by Rep_Item_Too_Late is actually the critical
22665 -- processing done for this pragma.
22667 if Rep_Item_Too_Early
(Typ
, N
)
22669 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
22674 -- Return if previous error
22676 if Etype
(Typ
) = Any_Type
22678 Etype
(Read
) = Any_Type
22680 Etype
(Write
) = Any_Type
22687 if Underlying_Type
(Etype
(Read
)) /= Typ
then
22689 ("incorrect return type for function&", Arg2
);
22692 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
22694 ("incorrect parameter type for function&", Arg3
);
22697 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
22698 Underlying_Type
(Etype
(Write
))
22701 ("result type of & does not match Read parameter type",
22705 end Stream_Convert
;
22711 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22713 -- This is processed by the parser since some of the style checks
22714 -- take place during source scanning and parsing. This means that
22715 -- we don't need to issue error messages here.
22717 when Pragma_Style_Checks
=> Style_Checks
: declare
22718 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22724 Check_No_Identifiers
;
22726 -- Two argument form
22728 if Arg_Count
= 2 then
22729 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22736 E_Id
:= Get_Pragma_Arg
(Arg2
);
22739 if not Is_Entity_Name
(E_Id
) then
22741 ("second argument of pragma% must be entity name",
22745 E
:= Entity
(E_Id
);
22747 if not Ignore_Style_Checks_Pragmas
then
22752 Set_Suppress_Style_Checks
22753 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
22754 exit when No
(Homonym
(E
));
22761 -- One argument form
22764 Check_Arg_Count
(1);
22766 if Nkind
(A
) = N_String_Literal
then
22770 Slen
: constant Natural := Natural (String_Length
(S
));
22771 Options
: String (1 .. Slen
);
22777 C
:= Get_String_Char
(S
, Pos
(J
));
22778 exit when not In_Character_Range
(C
);
22779 Options
(J
) := Get_Character
(C
);
22781 -- If at end of string, set options. As per discussion
22782 -- above, no need to check for errors, since we issued
22783 -- them in the parser.
22786 if not Ignore_Style_Checks_Pragmas
then
22787 Set_Style_Check_Options
(Options
);
22797 elsif Nkind
(A
) = N_Identifier
then
22798 if Chars
(A
) = Name_All_Checks
then
22799 if not Ignore_Style_Checks_Pragmas
then
22801 Set_GNAT_Style_Check_Options
;
22803 Set_Default_Style_Check_Options
;
22807 elsif Chars
(A
) = Name_On
then
22808 if not Ignore_Style_Checks_Pragmas
then
22809 Style_Check
:= True;
22812 elsif Chars
(A
) = Name_Off
then
22813 if not Ignore_Style_Checks_Pragmas
then
22814 Style_Check
:= False;
22825 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22827 when Pragma_Subtitle
=>
22829 Check_Arg_Count
(1);
22830 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
22831 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22838 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22840 when Pragma_Suppress
=>
22841 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
22847 -- pragma Suppress_All;
22849 -- The only check made here is that the pragma has no arguments.
22850 -- There are no placement rules, and the processing required (setting
22851 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22852 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22853 -- then creates and inserts a pragma Suppress (All_Checks).
22855 when Pragma_Suppress_All
=>
22857 Check_Arg_Count
(0);
22859 -------------------------
22860 -- Suppress_Debug_Info --
22861 -------------------------
22863 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22865 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
22866 Nam_Id
: Entity_Id
;
22870 Check_Arg_Count
(1);
22871 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22872 Check_Arg_Is_Local_Name
(Arg1
);
22874 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22876 -- A pragma that applies to a Ghost entity becomes Ghost for the
22877 -- purposes of legality checks and removal of ignored Ghost code.
22879 Mark_Ghost_Pragma
(N
, Nam_Id
);
22880 Set_Debug_Info_Off
(Nam_Id
);
22881 end Suppress_Debug_Info
;
22883 ----------------------------------
22884 -- Suppress_Exception_Locations --
22885 ----------------------------------
22887 -- pragma Suppress_Exception_Locations;
22889 when Pragma_Suppress_Exception_Locations
=>
22891 Check_Arg_Count
(0);
22892 Check_Valid_Configuration_Pragma
;
22893 Exception_Locations_Suppressed
:= True;
22895 -----------------------------
22896 -- Suppress_Initialization --
22897 -----------------------------
22899 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22901 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
22907 Check_Arg_Count
(1);
22908 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22909 Check_Arg_Is_Local_Name
(Arg1
);
22911 E_Id
:= Get_Pragma_Arg
(Arg1
);
22913 if Etype
(E_Id
) = Any_Type
then
22917 E
:= Entity
(E_Id
);
22919 -- A pragma that applies to a Ghost entity becomes Ghost for the
22920 -- purposes of legality checks and removal of ignored Ghost code.
22922 Mark_Ghost_Pragma
(N
, E
);
22924 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
22926 ("pragma% requires variable, type or subtype", Arg1
);
22929 if Rep_Item_Too_Early
(E
, N
)
22931 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
22936 -- For incomplete/private type, set flag on full view
22938 if Is_Incomplete_Or_Private_Type
(E
) then
22939 if No
(Full_View
(Base_Type
(E
))) then
22941 ("argument of pragma% cannot be an incomplete type", Arg1
);
22943 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
22946 -- For first subtype, set flag on base type
22948 elsif Is_First_Subtype
(E
) then
22949 Set_Suppress_Initialization
(Base_Type
(E
));
22951 -- For other than first subtype, set flag on subtype or variable
22954 Set_Suppress_Initialization
(E
);
22962 -- pragma System_Name (DIRECT_NAME);
22964 -- Syntax check: one argument, which must be the identifier GNAT or
22965 -- the identifier GCC, no other identifiers are acceptable.
22967 when Pragma_System_Name
=>
22969 Check_No_Identifiers
;
22970 Check_Arg_Count
(1);
22971 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
22973 -----------------------------
22974 -- Task_Dispatching_Policy --
22975 -----------------------------
22977 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22979 when Pragma_Task_Dispatching_Policy
=> declare
22983 Check_Ada_83_Warning
;
22984 Check_Arg_Count
(1);
22985 Check_No_Identifiers
;
22986 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22987 Check_Valid_Configuration_Pragma
;
22988 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22989 DP
:= Fold_Upper
(Name_Buffer
(1));
22991 if Task_Dispatching_Policy
/= ' '
22992 and then Task_Dispatching_Policy
/= DP
22994 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22996 ("task dispatching policy incompatible with policy#");
22998 -- Set new policy, but always preserve System_Location since we
22999 -- like the error message with the run time name.
23002 Task_Dispatching_Policy
:= DP
;
23004 if Task_Dispatching_Policy_Sloc
/= System_Location
then
23005 Task_Dispatching_Policy_Sloc
:= Loc
;
23014 -- pragma Task_Info (EXPRESSION);
23016 when Pragma_Task_Info
=> Task_Info
: declare
23017 P
: constant Node_Id
:= Parent
(N
);
23023 if Warn_On_Obsolescent_Feature
then
23025 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
23026 & "instead?j?", N
);
23029 if Nkind
(P
) /= N_Task_Definition
then
23030 Error_Pragma
("pragma% must appear in task definition");
23033 Check_No_Identifiers
;
23034 Check_Arg_Count
(1);
23036 Analyze_And_Resolve
23037 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
23039 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
23043 Ent
:= Defining_Identifier
(Parent
(P
));
23045 -- Check duplicate pragma before we chain the pragma in the Rep
23046 -- Item chain of Ent.
23049 (Ent
, Name_Task_Info
, Check_Parents
=> False)
23051 Error_Pragma
("duplicate pragma% not allowed");
23054 Record_Rep_Item
(Ent
, N
);
23061 -- pragma Task_Name (string_EXPRESSION);
23063 when Pragma_Task_Name
=> Task_Name
: declare
23064 P
: constant Node_Id
:= Parent
(N
);
23069 Check_No_Identifiers
;
23070 Check_Arg_Count
(1);
23072 Arg
:= Get_Pragma_Arg
(Arg1
);
23074 -- The expression is used in the call to Create_Task, and must be
23075 -- expanded there, not in the context of the current spec. It must
23076 -- however be analyzed to capture global references, in case it
23077 -- appears in a generic context.
23079 Preanalyze_And_Resolve
(Arg
, Standard_String
);
23081 if Nkind
(P
) /= N_Task_Definition
then
23085 Ent
:= Defining_Identifier
(Parent
(P
));
23087 -- Check duplicate pragma before we chain the pragma in the Rep
23088 -- Item chain of Ent.
23091 (Ent
, Name_Task_Name
, Check_Parents
=> False)
23093 Error_Pragma
("duplicate pragma% not allowed");
23096 Record_Rep_Item
(Ent
, N
);
23103 -- pragma Task_Storage (
23104 -- [Task_Type =>] LOCAL_NAME,
23105 -- [Top_Guard =>] static_integer_EXPRESSION);
23107 when Pragma_Task_Storage
=> Task_Storage
: declare
23108 Args
: Args_List
(1 .. 2);
23109 Names
: constant Name_List
(1 .. 2) := (
23113 Task_Type
: Node_Id
renames Args
(1);
23114 Top_Guard
: Node_Id
renames Args
(2);
23120 Gather_Associations
(Names
, Args
);
23122 if No
(Task_Type
) then
23124 ("missing task_type argument for pragma%");
23127 Check_Arg_Is_Local_Name
(Task_Type
);
23129 Ent
:= Entity
(Task_Type
);
23131 if not Is_Task_Type
(Ent
) then
23133 ("argument for pragma% must be task type", Task_Type
);
23136 if No
(Top_Guard
) then
23138 ("pragma% takes two arguments", Task_Type
);
23140 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
23143 Check_First_Subtype
(Task_Type
);
23145 if Rep_Item_Too_Late
(Ent
, N
) then
23154 -- pragma Test_Case
23155 -- ([Name =>] Static_String_EXPRESSION
23156 -- ,[Mode =>] MODE_TYPE
23157 -- [, Requires => Boolean_EXPRESSION]
23158 -- [, Ensures => Boolean_EXPRESSION]);
23160 -- MODE_TYPE ::= Nominal | Robustness
23162 -- Characteristics:
23164 -- * Analysis - The annotation undergoes initial checks to verify
23165 -- the legal placement and context. Secondary checks preanalyze the
23168 -- Analyze_Test_Case_In_Decl_Part
23170 -- * Expansion - None.
23172 -- * Template - The annotation utilizes the generic template of the
23173 -- related subprogram when it is:
23175 -- aspect on subprogram declaration
23177 -- The annotation must prepare its own template when it is:
23179 -- pragma on subprogram declaration
23181 -- * Globals - Capture of global references must occur after full
23184 -- * Instance - The annotation is instantiated automatically when
23185 -- the related generic subprogram is instantiated except for the
23186 -- "pragma on subprogram declaration" case. In that scenario the
23187 -- annotation must instantiate itself.
23189 when Pragma_Test_Case
=> Test_Case
: declare
23190 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
23191 -- Ensure that the contract of subprogram Subp_Id does not contain
23192 -- another Test_Case pragma with the same Name as the current one.
23194 -------------------------
23195 -- Check_Distinct_Name --
23196 -------------------------
23198 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
23199 Items
: constant Node_Id
:= Contract
(Subp_Id
);
23200 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
23204 -- Inspect all Test_Case pragma of the related subprogram
23205 -- looking for one with a duplicate "Name" argument.
23207 if Present
(Items
) then
23208 Prag
:= Contract_Test_Cases
(Items
);
23209 while Present
(Prag
) loop
23210 if Pragma_Name
(Prag
) = Name_Test_Case
23212 and then String_Equal
23213 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
23215 Error_Msg_Sloc
:= Sloc
(Prag
);
23216 Error_Pragma
("name for pragma % is already used #");
23219 Prag
:= Next_Pragma
(Prag
);
23222 end Check_Distinct_Name
;
23226 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
23229 Subp_Decl
: Node_Id
;
23230 Subp_Id
: Entity_Id
;
23232 -- Start of processing for Test_Case
23236 Check_At_Least_N_Arguments
(2);
23237 Check_At_Most_N_Arguments
(4);
23239 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
23243 Check_Optional_Identifier
(Arg1
, Name_Name
);
23244 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23248 Check_Optional_Identifier
(Arg2
, Name_Mode
);
23249 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
23251 -- Arguments "Requires" and "Ensures"
23253 if Present
(Arg3
) then
23254 if Present
(Arg4
) then
23255 Check_Identifier
(Arg3
, Name_Requires
);
23256 Check_Identifier
(Arg4
, Name_Ensures
);
23258 Check_Identifier_Is_One_Of
23259 (Arg3
, Name_Requires
, Name_Ensures
);
23263 -- Pragma Test_Case must be associated with a subprogram declared
23264 -- in a library-level package. First determine whether the current
23265 -- compilation unit is a legal context.
23267 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
23268 N_Generic_Package_Declaration
)
23272 -- Otherwise the placement is illegal
23276 ("pragma % must be specified within a package declaration");
23280 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
23282 -- Find the enclosing context
23284 Context
:= Parent
(Subp_Decl
);
23286 if Present
(Context
) then
23287 Context
:= Parent
(Context
);
23290 -- Verify the placement of the pragma
23292 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23294 ("pragma % cannot be applied to abstract subprogram");
23297 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
23298 Error_Pragma
("pragma % cannot be applied to entry");
23301 -- The context is a [generic] subprogram declared at the top level
23302 -- of the [generic] package unit.
23304 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
23305 N_Subprogram_Declaration
)
23306 and then Present
(Context
)
23307 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
23308 N_Package_Declaration
)
23312 -- Otherwise the placement is illegal
23316 ("pragma % must be applied to a library-level subprogram "
23321 Subp_Id
:= Defining_Entity
(Subp_Decl
);
23323 -- A pragma that applies to a Ghost entity becomes Ghost for the
23324 -- purposes of legality checks and removal of ignored Ghost code.
23326 Mark_Ghost_Pragma
(N
, Subp_Id
);
23328 -- Chain the pragma on the contract for further processing by
23329 -- Analyze_Test_Case_In_Decl_Part.
23331 Add_Contract_Item
(N
, Subp_Id
);
23333 -- Preanalyze the original aspect argument "Name" for ASIS or for
23334 -- a generic subprogram to properly capture global references.
23336 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
23337 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
23339 if Present
(Asp_Arg
) then
23341 -- The argument appears with an identifier in association
23344 if Nkind
(Asp_Arg
) = N_Component_Association
then
23345 Asp_Arg
:= Expression
(Asp_Arg
);
23348 Check_Expr_Is_OK_Static_Expression
23349 (Asp_Arg
, Standard_String
);
23353 -- Ensure that the all Test_Case pragmas of the related subprogram
23354 -- have distinct names.
23356 Check_Distinct_Name
(Subp_Id
);
23358 -- Fully analyze the pragma when it appears inside an entry
23359 -- or subprogram body because it cannot benefit from forward
23362 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
23364 N_Subprogram_Body_Stub
)
23366 -- The legality checks of pragma Test_Case are affected by the
23367 -- SPARK mode in effect and the volatility of the context.
23368 -- Analyze all pragmas in a specific order.
23370 Analyze_If_Present
(Pragma_SPARK_Mode
);
23371 Analyze_If_Present
(Pragma_Volatile_Function
);
23372 Analyze_Test_Case_In_Decl_Part
(N
);
23376 --------------------------
23377 -- Thread_Local_Storage --
23378 --------------------------
23380 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
23382 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
23388 Check_Arg_Count
(1);
23389 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23390 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23392 Id
:= Get_Pragma_Arg
(Arg1
);
23395 if not Is_Entity_Name
(Id
)
23396 or else Ekind
(Entity
(Id
)) /= E_Variable
23398 Error_Pragma_Arg
("local variable name required", Arg1
);
23403 -- A pragma that applies to a Ghost entity becomes Ghost for the
23404 -- purposes of legality checks and removal of ignored Ghost code.
23406 Mark_Ghost_Pragma
(N
, E
);
23408 if Rep_Item_Too_Early
(E
, N
)
23410 Rep_Item_Too_Late
(E
, N
)
23415 Set_Has_Pragma_Thread_Local_Storage
(E
);
23416 Set_Has_Gigi_Rep_Item
(E
);
23417 end Thread_Local_Storage
;
23423 -- pragma Time_Slice (static_duration_EXPRESSION);
23425 when Pragma_Time_Slice
=> Time_Slice
: declare
23431 Check_Arg_Count
(1);
23432 Check_No_Identifiers
;
23433 Check_In_Main_Program
;
23434 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
23436 if not Error_Posted
(Arg1
) then
23438 while Present
(Nod
) loop
23439 if Nkind
(Nod
) = N_Pragma
23440 and then Pragma_Name
(Nod
) = Name_Time_Slice
23442 Error_Msg_Name_1
:= Pname
;
23443 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
23450 -- Process only if in main unit
23452 if Get_Source_Unit
(Loc
) = Main_Unit
then
23453 Opt
.Time_Slice_Set
:= True;
23454 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
23456 if Val
<= Ureal_0
then
23457 Opt
.Time_Slice_Value
:= 0;
23459 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
23460 Opt
.Time_Slice_Value
:= 1_000_000_000
;
23463 Opt
.Time_Slice_Value
:=
23464 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
23473 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
23475 -- TITLING_OPTION ::=
23476 -- [Title =>] STRING_LITERAL
23477 -- | [Subtitle =>] STRING_LITERAL
23479 when Pragma_Title
=> Title
: declare
23480 Args
: Args_List
(1 .. 2);
23481 Names
: constant Name_List
(1 .. 2) := (
23487 Gather_Associations
(Names
, Args
);
23490 for J
in 1 .. 2 loop
23491 if Present
(Args
(J
)) then
23492 Check_Arg_Is_OK_Static_Expression
23493 (Args
(J
), Standard_String
);
23498 ----------------------------
23499 -- Type_Invariant[_Class] --
23500 ----------------------------
23502 -- pragma Type_Invariant[_Class]
23503 -- ([Entity =>] type_LOCAL_NAME,
23504 -- [Check =>] EXPRESSION);
23506 when Pragma_Type_Invariant
23507 | Pragma_Type_Invariant_Class
23509 Type_Invariant
: declare
23510 I_Pragma
: Node_Id
;
23513 Check_Arg_Count
(2);
23515 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
23516 -- setting Class_Present for the Type_Invariant_Class case.
23518 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
23519 I_Pragma
:= New_Copy
(N
);
23520 Set_Pragma_Identifier
23521 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
23522 Rewrite
(N
, I_Pragma
);
23523 Set_Analyzed
(N
, False);
23525 end Type_Invariant
;
23527 ---------------------
23528 -- Unchecked_Union --
23529 ---------------------
23531 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
23533 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
23534 Assoc
: constant Node_Id
:= Arg1
;
23535 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
23545 Check_No_Identifiers
;
23546 Check_Arg_Count
(1);
23547 Check_Arg_Is_Local_Name
(Arg1
);
23549 Find_Type
(Type_Id
);
23551 Typ
:= Entity
(Type_Id
);
23553 -- A pragma that applies to a Ghost entity becomes Ghost for the
23554 -- purposes of legality checks and removal of ignored Ghost code.
23556 Mark_Ghost_Pragma
(N
, Typ
);
23559 or else Rep_Item_Too_Early
(Typ
, N
)
23563 Typ
:= Underlying_Type
(Typ
);
23566 if Rep_Item_Too_Late
(Typ
, N
) then
23570 Check_First_Subtype
(Arg1
);
23572 -- Note remaining cases are references to a type in the current
23573 -- declarative part. If we find an error, we post the error on
23574 -- the relevant type declaration at an appropriate point.
23576 if not Is_Record_Type
(Typ
) then
23577 Error_Msg_N
("unchecked union must be record type", Typ
);
23580 elsif Is_Tagged_Type
(Typ
) then
23581 Error_Msg_N
("unchecked union must not be tagged", Typ
);
23584 elsif not Has_Discriminants
(Typ
) then
23586 ("unchecked union must have one discriminant", Typ
);
23589 -- Note: in previous versions of GNAT we used to check for limited
23590 -- types and give an error, but in fact the standard does allow
23591 -- Unchecked_Union on limited types, so this check was removed.
23593 -- Similarly, GNAT used to require that all discriminants have
23594 -- default values, but this is not mandated by the RM.
23596 -- Proceed with basic error checks completed
23599 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
23600 Clist
:= Component_List
(Tdef
);
23602 -- Check presence of component list and variant part
23604 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
23606 ("unchecked union must have variant part", Tdef
);
23610 -- Check components
23612 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
23613 while Present
(Comp
) loop
23614 Check_Component
(Comp
, Typ
);
23615 Next_Non_Pragma
(Comp
);
23618 -- Check variant part
23620 Vpart
:= Variant_Part
(Clist
);
23622 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
23623 while Present
(Variant
) loop
23624 Check_Variant
(Variant
, Typ
);
23625 Next_Non_Pragma
(Variant
);
23629 Set_Is_Unchecked_Union
(Typ
);
23630 Set_Convention
(Typ
, Convention_C
);
23631 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
23632 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
23633 end Unchecked_Union
;
23635 ----------------------------
23636 -- Unevaluated_Use_Of_Old --
23637 ----------------------------
23639 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23641 when Pragma_Unevaluated_Use_Of_Old
=>
23643 Check_Arg_Count
(1);
23644 Check_No_Identifiers
;
23645 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
23647 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23648 -- a declarative part or a package spec.
23650 if not Is_Configuration_Pragma
then
23651 Check_Is_In_Decl_Part_Or_Package_Spec
;
23654 -- Store proper setting of Uneval_Old
23656 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23657 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
23659 ------------------------
23660 -- Unimplemented_Unit --
23661 ------------------------
23663 -- pragma Unimplemented_Unit;
23665 -- Note: this only gives an error if we are generating code, or if
23666 -- we are in a generic library unit (where the pragma appears in the
23667 -- body, not in the spec).
23669 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
23670 Cunitent
: constant Entity_Id
:=
23671 Cunit_Entity
(Get_Source_Unit
(Loc
));
23672 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
23676 Check_Arg_Count
(0);
23678 if Operating_Mode
= Generate_Code
23679 or else Ent_Kind
= E_Generic_Function
23680 or else Ent_Kind
= E_Generic_Procedure
23681 or else Ent_Kind
= E_Generic_Package
23683 Get_Name_String
(Chars
(Cunitent
));
23684 Set_Casing
(Mixed_Case
);
23685 Write_Str
(Name_Buffer
(1 .. Name_Len
));
23686 Write_Str
(" is not supported in this configuration");
23688 raise Unrecoverable_Error
;
23690 end Unimplemented_Unit
;
23692 ------------------------
23693 -- Universal_Aliasing --
23694 ------------------------
23696 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23698 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
23704 Check_Arg_Count
(1);
23705 Check_Optional_Identifier
(Arg2
, Name_Entity
);
23706 Check_Arg_Is_Local_Name
(Arg1
);
23707 E_Id
:= Get_Pragma_Arg
(Arg1
);
23709 if Etype
(E_Id
) = Any_Type
then
23713 E
:= Entity
(E_Id
);
23715 if not Is_Type
(E
) then
23716 Error_Pragma_Arg
("pragma% requires type", Arg1
);
23719 -- A pragma that applies to a Ghost entity becomes Ghost for the
23720 -- purposes of legality checks and removal of ignored Ghost code.
23722 Mark_Ghost_Pragma
(N
, E
);
23723 Set_Universal_Aliasing
(Base_Type
(E
));
23724 Record_Rep_Item
(E
, N
);
23725 end Universal_Alias
;
23727 --------------------
23728 -- Universal_Data --
23729 --------------------
23731 -- pragma Universal_Data [(library_unit_NAME)];
23733 when Pragma_Universal_Data
=>
23735 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
23741 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23743 when Pragma_Unmodified
=>
23744 Analyze_Unmodified_Or_Unused
;
23750 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23752 -- or when used in a context clause:
23754 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23756 when Pragma_Unreferenced
=>
23757 Analyze_Unreferenced_Or_Unused
;
23759 --------------------------
23760 -- Unreferenced_Objects --
23761 --------------------------
23763 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23765 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
23767 Arg_Expr
: Node_Id
;
23768 Arg_Id
: Entity_Id
;
23770 Ghost_Error_Posted
: Boolean := False;
23771 -- Flag set when an error concerning the illegal mix of Ghost and
23772 -- non-Ghost types is emitted.
23774 Ghost_Id
: Entity_Id
:= Empty
;
23775 -- The entity of the first Ghost type encountered while processing
23776 -- the arguments of the pragma.
23780 Check_At_Least_N_Arguments
(1);
23783 while Present
(Arg
) loop
23784 Check_No_Identifier
(Arg
);
23785 Check_Arg_Is_Local_Name
(Arg
);
23786 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
23788 if Is_Entity_Name
(Arg_Expr
) then
23789 Arg_Id
:= Entity
(Arg_Expr
);
23791 if Is_Type
(Arg_Id
) then
23792 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
23794 -- A pragma that applies to a Ghost entity becomes Ghost
23795 -- for the purposes of legality checks and removal of
23796 -- ignored Ghost code.
23798 Mark_Ghost_Pragma
(N
, Arg_Id
);
23800 -- Capture the entity of the first Ghost type being
23801 -- processed for error detection purposes.
23803 if Is_Ghost_Entity
(Arg_Id
) then
23804 if No
(Ghost_Id
) then
23805 Ghost_Id
:= Arg_Id
;
23808 -- Otherwise the type is non-Ghost. It is illegal to mix
23809 -- references to Ghost and non-Ghost entities
23812 elsif Present
(Ghost_Id
)
23813 and then not Ghost_Error_Posted
23815 Ghost_Error_Posted
:= True;
23817 Error_Msg_Name_1
:= Pname
;
23819 ("pragma % cannot mention ghost and non-ghost types",
23822 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
23823 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
23825 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
23826 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
23830 ("argument for pragma% must be type or subtype", Arg
);
23834 ("argument for pragma% must be type or subtype", Arg
);
23839 end Unreferenced_Objects
;
23841 ------------------------------
23842 -- Unreserve_All_Interrupts --
23843 ------------------------------
23845 -- pragma Unreserve_All_Interrupts;
23847 when Pragma_Unreserve_All_Interrupts
=>
23849 Check_Arg_Count
(0);
23851 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
23852 Unreserve_All_Interrupts
:= True;
23859 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23861 when Pragma_Unsuppress
=>
23863 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
23869 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23871 when Pragma_Unused
=>
23872 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
23873 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
23875 -------------------
23876 -- Use_VADS_Size --
23877 -------------------
23879 -- pragma Use_VADS_Size;
23881 when Pragma_Use_VADS_Size
=>
23883 Check_Arg_Count
(0);
23884 Check_Valid_Configuration_Pragma
;
23885 Use_VADS_Size
:= True;
23887 ---------------------
23888 -- Validity_Checks --
23889 ---------------------
23891 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23893 when Pragma_Validity_Checks
=> Validity_Checks
: declare
23894 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23900 Check_Arg_Count
(1);
23901 Check_No_Identifiers
;
23903 -- Pragma always active unless in CodePeer or GNATprove modes,
23904 -- which use a fixed configuration of validity checks.
23906 if not (CodePeer_Mode
or GNATprove_Mode
) then
23907 if Nkind
(A
) = N_String_Literal
then
23911 Slen
: constant Natural := Natural (String_Length
(S
));
23912 Options
: String (1 .. Slen
);
23916 -- Couldn't we use a for loop here over Options'Range???
23920 C
:= Get_String_Char
(S
, Pos
(J
));
23922 -- This is a weird test, it skips setting validity
23923 -- checks entirely if any element of S is out of
23924 -- range of Character, what is that about ???
23926 exit when not In_Character_Range
(C
);
23927 Options
(J
) := Get_Character
(C
);
23930 Set_Validity_Check_Options
(Options
);
23938 elsif Nkind
(A
) = N_Identifier
then
23939 if Chars
(A
) = Name_All_Checks
then
23940 Set_Validity_Check_Options
("a");
23941 elsif Chars
(A
) = Name_On
then
23942 Validity_Checks_On
:= True;
23943 elsif Chars
(A
) = Name_Off
then
23944 Validity_Checks_On
:= False;
23948 end Validity_Checks
;
23954 -- pragma Volatile (LOCAL_NAME);
23956 when Pragma_Volatile
=>
23957 Process_Atomic_Independent_Shared_Volatile
;
23959 -------------------------
23960 -- Volatile_Components --
23961 -------------------------
23963 -- pragma Volatile_Components (array_LOCAL_NAME);
23965 -- Volatile is handled by the same circuit as Atomic_Components
23967 --------------------------
23968 -- Volatile_Full_Access --
23969 --------------------------
23971 -- pragma Volatile_Full_Access (LOCAL_NAME);
23973 when Pragma_Volatile_Full_Access
=>
23975 Process_Atomic_Independent_Shared_Volatile
;
23977 -----------------------
23978 -- Volatile_Function --
23979 -----------------------
23981 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23983 when Pragma_Volatile_Function
=> Volatile_Function
: declare
23984 Over_Id
: Entity_Id
;
23985 Spec_Id
: Entity_Id
;
23986 Subp_Decl
: Node_Id
;
23990 Check_No_Identifiers
;
23991 Check_At_Most_N_Arguments
(1);
23994 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23996 -- Generic subprogram
23998 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
24001 -- Body acts as spec
24003 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
24004 and then No
(Corresponding_Spec
(Subp_Decl
))
24008 -- Body stub acts as spec
24010 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
24011 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
24017 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
24025 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
24027 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
24032 -- A pragma that applies to a Ghost entity becomes Ghost for the
24033 -- purposes of legality checks and removal of ignored Ghost code.
24035 Mark_Ghost_Pragma
(N
, Spec_Id
);
24037 -- Chain the pragma on the contract for completeness
24039 Add_Contract_Item
(N
, Spec_Id
);
24041 -- The legality checks of pragma Volatile_Function are affected by
24042 -- the SPARK mode in effect. Analyze all pragmas in a specific
24045 Analyze_If_Present
(Pragma_SPARK_Mode
);
24047 -- A volatile function cannot override a non-volatile function
24048 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
24049 -- in New_Overloaded_Entity, however at that point the pragma has
24050 -- not been processed yet.
24052 Over_Id
:= Overridden_Operation
(Spec_Id
);
24054 if Present
(Over_Id
)
24055 and then not Is_Volatile_Function
(Over_Id
)
24058 ("incompatible volatile function values in effect", Spec_Id
);
24060 Error_Msg_Sloc
:= Sloc
(Over_Id
);
24062 ("\& declared # with Volatile_Function value False",
24065 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
24067 ("\overridden # with Volatile_Function value True",
24071 -- Analyze the Boolean expression (if any)
24073 if Present
(Arg1
) then
24074 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
24076 end Volatile_Function
;
24078 ----------------------
24079 -- Warning_As_Error --
24080 ----------------------
24082 -- pragma Warning_As_Error (static_string_EXPRESSION);
24084 when Pragma_Warning_As_Error
=>
24086 Check_Arg_Count
(1);
24087 Check_No_Identifiers
;
24088 Check_Valid_Configuration_Pragma
;
24090 if not Is_Static_String_Expression
(Arg1
) then
24092 ("argument of pragma% must be static string expression",
24095 -- OK static string expression
24098 Acquire_Warning_Match_String
(Arg1
);
24099 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
24100 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
24101 new String'(Name_Buffer (1 .. Name_Len));
24108 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
24110 -- DETAILS ::= On | Off
24111 -- DETAILS ::= On | Off, local_NAME
24112 -- DETAILS ::= static_string_EXPRESSION
24113 -- DETAILS ::= On | Off, static_string_EXPRESSION
24115 -- TOOL_NAME ::= GNAT | GNATProve
24117 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
24119 -- Note: If the first argument matches an allowed tool name, it is
24120 -- always considered to be a tool name, even if there is a string
24121 -- variable of that name.
24123 -- Note if the second argument of DETAILS is a local_NAME then the
24124 -- second form is always understood. If the intention is to use
24125 -- the fourth form, then you can write NAME & "" to force the
24126 -- intepretation as a static_string_EXPRESSION.
24128 when Pragma_Warnings => Warnings : declare
24129 Reason : String_Id;
24133 Check_At_Least_N_Arguments (1);
24135 -- See if last argument is labeled Reason. If so, make sure we
24136 -- have a string literal or a concatenation of string literals,
24137 -- and acquire the REASON string. Then remove the REASON argument
24138 -- by decreasing Num_Args by one; Remaining processing looks only
24139 -- at first Num_Args arguments).
24142 Last_Arg : constant Node_Id :=
24143 Last (Pragma_Argument_Associations (N));
24146 if Nkind (Last_Arg) = N_Pragma_Argument_Association
24147 and then Chars (Last_Arg) = Name_Reason
24150 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
24151 Reason := End_String;
24152 Arg_Count := Arg_Count - 1;
24154 -- Not allowed in compiler units (bootstrap issues)
24156 Check_Compiler_Unit ("Reason for pragma Warnings", N);
24158 -- No REASON string, set null string as reason
24161 Reason := Null_String_Id;
24165 -- Now proceed with REASON taken care of and eliminated
24167 Check_No_Identifiers;
24169 -- If debug flag -gnatd.i is set, pragma is ignored
24171 if Debug_Flag_Dot_I then
24175 -- Process various forms of the pragma
24178 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
24179 Shifted_Args : List_Id;
24182 -- See if first argument is a tool name, currently either
24183 -- GNAT or GNATprove. If so, either ignore the pragma if the
24184 -- tool used does not match, or continue as if no tool name
24185 -- was given otherwise, by shifting the arguments.
24187 if Nkind (Argx) = N_Identifier
24188 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
24190 if Chars (Argx) = Name_Gnat then
24191 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
24192 Rewrite (N, Make_Null_Statement (Loc));
24197 elsif Chars (Argx) = Name_Gnatprove then
24198 if not GNATprove_Mode then
24199 Rewrite (N, Make_Null_Statement (Loc));
24205 raise Program_Error;
24208 -- At this point, the pragma Warnings applies to the tool,
24209 -- so continue with shifted arguments.
24211 Arg_Count := Arg_Count - 1;
24213 if Arg_Count = 1 then
24214 Shifted_Args := New_List (New_Copy (Arg2));
24215 elsif Arg_Count = 2 then
24216 Shifted_Args := New_List (New_Copy (Arg2),
24218 elsif Arg_Count = 3 then
24219 Shifted_Args := New_List (New_Copy (Arg2),
24223 raise Program_Error;
24228 Chars => Name_Warnings,
24229 Pragma_Argument_Associations => Shifted_Args));
24234 -- One argument case
24236 if Arg_Count = 1 then
24238 -- On/Off one argument case was processed by parser
24240 if Nkind (Argx) = N_Identifier
24241 and then Nam_In (Chars (Argx), Name_On, Name_Off)
24245 -- One argument case must be ON/OFF or static string expr
24247 elsif not Is_Static_String_Expression (Arg1) then
24249 ("argument of pragma% must be On/Off or static string "
24250 & "expression", Arg1);
24252 -- One argument string expression case
24256 Lit : constant Node_Id := Expr_Value_S (Argx);
24257 Str : constant String_Id := Strval (Lit);
24258 Len : constant Nat := String_Length (Str);
24266 while J <= Len loop
24267 C := Get_String_Char (Str, J);
24268 OK := In_Character_Range (C);
24271 Chr := Get_Character (C);
24273 -- Dash case: only -Wxxx is accepted
24280 C := Get_String_Char (Str, J);
24281 Chr := Get_Character (C);
24282 exit when Chr = 'W
';
24287 elsif J < Len and then Chr = '.' then
24289 C := Get_String_Char (Str, J);
24290 Chr := Get_Character (C);
24292 if not Set_Dot_Warning_Switch (Chr) then
24294 ("invalid warning switch character "
24295 & '.' & Chr, Arg1);
24301 OK := Set_Warning_Switch (Chr);
24306 ("invalid warning switch character " & Chr,
24312 ("invalid wide character in warning switch ",
24321 -- Two or more arguments (must be two)
24324 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24325 Check_Arg_Count (2);
24333 E_Id := Get_Pragma_Arg (Arg2);
24336 -- In the expansion of an inlined body, a reference to
24337 -- the formal may be wrapped in a conversion if the
24338 -- actual is a conversion. Retrieve the real entity name.
24340 if (In_Instance_Body or In_Inlined_Body)
24341 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
24343 E_Id := Expression (E_Id);
24346 -- Entity name case
24348 if Is_Entity_Name (E_Id) then
24349 E := Entity (E_Id);
24356 (E, (Chars (Get_Pragma_Arg (Arg1)) =
24359 -- For OFF case, make entry in warnings off
24360 -- pragma table for later processing. But we do
24361 -- not do that within an instance, since these
24362 -- warnings are about what is needed in the
24363 -- template, not an instance of it.
24365 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
24366 and then Warn_On_Warnings_Off
24367 and then not In_Instance
24369 Warnings_Off_Pragmas.Append ((N, E, Reason));
24372 if Is_Enumeration_Type (E) then
24376 Lit := First_Literal (E);
24377 while Present (Lit) loop
24378 Set_Warnings_Off (Lit);
24379 Next_Literal (Lit);
24384 exit when No (Homonym (E));
24389 -- Error if not entity or static string expression case
24391 elsif not Is_Static_String_Expression (Arg2) then
24393 ("second argument of pragma% must be entity name "
24394 & "or static string expression", Arg2);
24396 -- Static string expression case
24399 Acquire_Warning_Match_String (Arg2);
24401 -- Note on configuration pragma case: If this is a
24402 -- configuration pragma, then for an OFF pragma, we
24403 -- just set Config True in the call, which is all
24404 -- that needs to be done. For the case of ON, this
24405 -- is normally an error, unless it is canceling the
24406 -- effect of a previous OFF pragma in the same file.
24407 -- In any other case, an error will be signalled (ON
24408 -- with no matching OFF).
24410 -- Note: We set Used if we are inside a generic to
24411 -- disable the test that the non-config case actually
24412 -- cancels a warning. That's because we can't be sure
24413 -- there isn't an instantiation in some other unit
24414 -- where a warning is suppressed.
24416 -- We could do a little better here by checking if the
24417 -- generic unit we are inside is public, but for now
24418 -- we don't bother with that refinement.
24420 if Chars (Argx) = Name_Off then
24421 Set_Specific_Warning_Off
24422 (Loc, Name_Buffer (1 .. Name_Len), Reason,
24423 Config => Is_Configuration_Pragma,
24424 Used => Inside_A_Generic or else In_Instance);
24426 elsif Chars (Argx) = Name_On then
24427 Set_Specific_Warning_On
24428 (Loc, Name_Buffer (1 .. Name_Len), Err);
24432 ("??pragma Warnings On with no matching "
24433 & "Warnings Off", Loc);
24442 -------------------
24443 -- Weak_External --
24444 -------------------
24446 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
24448 when Pragma_Weak_External => Weak_External : declare
24453 Check_Arg_Count (1);
24454 Check_Optional_Identifier (Arg1, Name_Entity);
24455 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24456 Ent := Entity (Get_Pragma_Arg (Arg1));
24458 if Rep_Item_Too_Early (Ent, N) then
24461 Ent := Underlying_Type (Ent);
24464 -- The only processing required is to link this item on to the
24465 -- list of rep items for the given entity. This is accomplished
24466 -- by the call to Rep_Item_Too_Late (when no error is detected
24467 -- and False is returned).
24469 if Rep_Item_Too_Late (Ent, N) then
24472 Set_Has_Gigi_Rep_Item (Ent);
24476 -----------------------------
24477 -- Wide_Character_Encoding --
24478 -----------------------------
24480 -- pragma Wide_Character_Encoding (IDENTIFIER);
24482 when Pragma_Wide_Character_Encoding =>
24485 -- Nothing to do, handled in parser. Note that we do not enforce
24486 -- configuration pragma placement, this pragma can appear at any
24487 -- place in the source, allowing mixed encodings within a single
24492 --------------------
24493 -- Unknown_Pragma --
24494 --------------------
24496 -- Should be impossible, since the case of an unknown pragma is
24497 -- separately processed before the case statement is entered.
24499 when Unknown_Pragma =>
24500 raise Program_Error;
24503 -- AI05-0144: detect dangerous order dependence. Disabled for now,
24504 -- until AI is formally approved.
24506 -- Check_Order_Dependence;
24509 when Pragma_Exit => null;
24510 end Analyze_Pragma;
24512 ---------------------------------------------
24513 -- Analyze_Pre_Post_Condition_In_Decl_Part --
24514 ---------------------------------------------
24516 -- WARNING: This routine manages Ghost regions. Return statements must be
24517 -- replaced by gotos which jump to the end of the routine and restore the
24520 procedure Analyze_Pre_Post_Condition_In_Decl_Part
24522 Freeze_Id : Entity_Id := Empty)
24524 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24525 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24527 Disp_Typ : Entity_Id;
24528 -- The dispatching type of the subprogram subject to the pre- or
24531 function Check_References (Nod : Node_Id) return Traverse_Result;
24532 -- Check that expression Nod does not mention non-primitives of the
24533 -- type, global objects of the type, or other illegalities described
24534 -- and implied by AI12-0113.
24536 ----------------------
24537 -- Check_References --
24538 ----------------------
24540 function Check_References (Nod : Node_Id) return Traverse_Result is
24542 if Nkind (Nod) = N_Function_Call
24543 and then Is_Entity_Name (Name (Nod))
24546 Func : constant Entity_Id := Entity (Name (Nod));
24550 -- An operation of the type must be a primitive
24552 if No (Find_Dispatching_Type (Func)) then
24553 Form := First_Formal (Func);
24554 while Present (Form) loop
24555 if Etype (Form) = Disp_Typ then
24557 ("operation in class-wide condition must be "
24558 & "primitive of &", Nod, Disp_Typ);
24561 Next_Formal (Form);
24564 -- A return object of the type is illegal as well
24566 if Etype (Func) = Disp_Typ
24567 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24570 ("operation in class-wide condition must be primitive "
24571 & "of &", Nod, Disp_Typ);
24574 -- Otherwise we have a call to an overridden primitive, and we
24575 -- will create a common class-wide clone for the body of
24576 -- original operation and its eventual inherited versions. If
24577 -- the original operation dispatches on result it is never
24578 -- inherited and there is no need for a clone. There is not
24579 -- need for a clone either in GNATprove mode, as cases that
24580 -- would require it are rejected (when an inherited primitive
24581 -- calls an overridden operation in a class-wide contract), and
24582 -- the clone would make proof impossible in some cases.
24584 elsif not Is_Abstract_Subprogram (Spec_Id)
24585 and then No (Class_Wide_Clone (Spec_Id))
24586 and then not Has_Controlling_Result (Spec_Id)
24587 and then not GNATprove_Mode
24589 Build_Class_Wide_Clone_Decl (Spec_Id);
24593 elsif Is_Entity_Name (Nod)
24595 (Etype (Nod) = Disp_Typ
24596 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24597 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24600 ("object in class-wide condition must be formal of type &",
24603 elsif Nkind (Nod) = N_Explicit_Dereference
24604 and then (Etype (Nod) = Disp_Typ
24605 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24606 and then (not Is_Entity_Name (Prefix (Nod))
24607 or else not Is_Formal (Entity (Prefix (Nod))))
24610 ("operation in class-wide condition must be primitive of &",
24615 end Check_References;
24617 procedure Check_Class_Wide_Condition is
24618 new Traverse_Proc (Check_References);
24622 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24623 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24624 -- Save the Ghost mode to restore on exit
24627 Restore_Scope : Boolean := False;
24629 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24632 -- Do not analyze the pragma multiple times
24634 if Is_Analyzed_Pragma (N) then
24638 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24639 -- analysis of the pragma, the Ghost mode at point of declaration and
24640 -- point of analysis may not necessarily be the same. Use the mode in
24641 -- effect at the point of declaration.
24643 Set_Ghost_Mode (N);
24645 -- Ensure that the subprogram and its formals are visible when analyzing
24646 -- the expression of the pragma.
24648 if not In_Open_Scopes (Spec_Id) then
24649 Restore_Scope := True;
24650 Push_Scope (Spec_Id);
24652 if Is_Generic_Subprogram (Spec_Id) then
24653 Install_Generic_Formals (Spec_Id);
24655 Install_Formals (Spec_Id);
24659 Errors := Serious_Errors_Detected;
24660 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24662 -- Emit a clarification message when the expression contains at least
24663 -- one undefined reference, possibly due to contract freezing.
24665 if Errors /= Serious_Errors_Detected
24666 and then Present (Freeze_Id)
24667 and then Has_Undefined_Reference (Expr)
24669 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24672 if Class_Present (N) then
24674 -- Verify that a class-wide condition is legal, i.e. the operation is
24675 -- a primitive of a tagged type. Note that a generic subprogram is
24676 -- not a primitive operation.
24678 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24680 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24681 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24683 if From_Aspect_Specification (N) then
24685 ("aspect % can only be specified for a primitive operation "
24686 & "of a tagged type", Corresponding_Aspect (N));
24688 -- The pragma is a source construct
24692 ("pragma % can only be specified for a primitive operation "
24693 & "of a tagged type", N);
24696 -- Remaining semantic checks require a full tree traversal
24699 Check_Class_Wide_Condition (Expr);
24704 if Restore_Scope then
24708 -- If analysis of the condition indicates that a class-wide clone
24709 -- has been created, build and analyze its declaration.
24711 if Is_Subprogram (Spec_Id)
24712 and then Present (Class_Wide_Clone (Spec_Id))
24714 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
24717 -- Currently it is not possible to inline pre/postconditions on a
24718 -- subprogram subject to pragma Inline_Always.
24720 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24721 Set_Is_Analyzed_Pragma (N);
24723 Restore_Ghost_Mode (Saved_GM);
24724 end Analyze_Pre_Post_Condition_In_Decl_Part;
24726 ------------------------------------------
24727 -- Analyze_Refined_Depends_In_Decl_Part --
24728 ------------------------------------------
24730 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24731 procedure Check_Dependency_Clause
24732 (Spec_Id : Entity_Id;
24733 Dep_Clause : Node_Id;
24734 Dep_States : Elist_Id;
24735 Refinements : List_Id;
24736 Matched_Items : in out Elist_Id);
24737 -- Try to match a single dependency clause Dep_Clause against one or
24738 -- more refinement clauses found in list Refinements. Each successful
24739 -- match eliminates at least one refinement clause from Refinements.
24740 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24741 -- denotes the entities of all abstract states which appear in pragma
24742 -- Depends. Matched_Items contains the entities of all successfully
24743 -- matched items found in pragma Depends.
24745 procedure Check_Output_States
24746 (Spec_Id : Entity_Id;
24747 Spec_Inputs : Elist_Id;
24748 Spec_Outputs : Elist_Id;
24749 Body_Inputs : Elist_Id;
24750 Body_Outputs : Elist_Id);
24751 -- Determine whether pragma Depends contains an output state with a
24752 -- visible refinement and if so, ensure that pragma Refined_Depends
24753 -- mentions all its constituents as outputs. Spec_Id is the entity of
24754 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24755 -- inputs and outputs of the subprogram spec synthesized from pragma
24756 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24757 -- of the subprogram body synthesized from pragma Refined_Depends.
24759 function Collect_States (Clauses : List_Id) return Elist_Id;
24760 -- Given a normalized list of dependencies obtained from calling
24761 -- Normalize_Clauses, return a list containing the entities of all
24762 -- states appearing in dependencies. It helps in checking refinements
24763 -- involving a state and a corresponding constituent which is not a
24764 -- direct constituent of the state.
24766 procedure Normalize_Clauses (Clauses : List_Id);
24767 -- Given a list of dependence or refinement clauses Clauses, normalize
24768 -- each clause by creating multiple dependencies with exactly one input
24771 procedure Remove_Extra_Clauses
24772 (Clauses : List_Id;
24773 Matched_Items : Elist_Id);
24774 -- Given a list of refinement clauses Clauses, remove all clauses whose
24775 -- inputs and/or outputs have been previously matched. See the body for
24776 -- all special cases. Matched_Items contains the entities of all matched
24777 -- items found in pragma Depends.
24779 procedure Report_Extra_Clauses
24780 (Spec_Id : Entity_Id;
24781 Clauses : List_Id);
24782 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24783 -- denotes the entity of the related subprogram.
24785 -----------------------------
24786 -- Check_Dependency_Clause --
24787 -----------------------------
24789 procedure Check_Dependency_Clause
24790 (Spec_Id : Entity_Id;
24791 Dep_Clause : Node_Id;
24792 Dep_States : Elist_Id;
24793 Refinements : List_Id;
24794 Matched_Items : in out Elist_Id)
24796 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24797 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24799 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24800 -- Determine whether dependency item Dep_Item has been matched in a
24801 -- previous clause.
24803 function Is_In_Out_State_Clause return Boolean;
24804 -- Determine whether dependence clause Dep_Clause denotes an abstract
24805 -- state that depends on itself (State => State).
24807 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24808 -- Determine whether item Item denotes an abstract state with visible
24809 -- null refinement.
24811 procedure Match_Items
24812 (Dep_Item : Node_Id;
24813 Ref_Item : Node_Id;
24814 Matched : out Boolean);
24815 -- Try to match dependence item Dep_Item against refinement item
24816 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24817 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24818 -- the following conformance scenarios is in effect:
24819 -- 1) Both items denote null
24820 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24821 -- 3) Both items denote attribute 'Result
24822 -- 4) Both items denote the same object
24823 -- 5) Both items denote the same formal parameter
24824 -- 6) Both items denote the same current instance of a type
24825 -- 7) Both items denote the same discriminant
24826 -- 8) Dep_Item is an abstract state with visible null refinement
24827 -- and Ref_Item denotes null.
24828 -- 9) Dep_Item is an abstract state with visible null refinement
24829 -- and Ref_Item is Empty (special case).
24830 -- 10) Dep_Item is an abstract state with full or partial visible
24831 -- non-null refinement and Ref_Item denotes one of its
24833 -- 11) Dep_Item is an abstract state without a full visible
24834 -- refinement and Ref_Item denotes the same state.
24835 -- When scenario 10 is in effect, the entity of the abstract state
24836 -- denoted by Dep_Item is added to list Refined_States.
24838 procedure Record_Item
(Item_Id
: Entity_Id
);
24839 -- Store the entity of an item denoted by Item_Id in Matched_Items
24841 ------------------------
24842 -- Is_Already_Matched --
24843 ------------------------
24845 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
24846 Item_Id
: Entity_Id
:= Empty
;
24849 -- When the dependency item denotes attribute 'Result, check for
24850 -- the entity of the related subprogram.
24852 if Is_Attribute_Result
(Dep_Item
) then
24853 Item_Id
:= Spec_Id
;
24855 elsif Is_Entity_Name
(Dep_Item
) then
24856 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24860 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
24861 end Is_Already_Matched
;
24863 ----------------------------
24864 -- Is_In_Out_State_Clause --
24865 ----------------------------
24867 function Is_In_Out_State_Clause
return Boolean is
24868 Dep_Input_Id
: Entity_Id
;
24869 Dep_Output_Id
: Entity_Id
;
24872 -- Detect the following clause:
24875 if Is_Entity_Name
(Dep_Input
)
24876 and then Is_Entity_Name
(Dep_Output
)
24878 -- Handle abstract views generated for limited with clauses
24880 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
24881 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
24884 Ekind
(Dep_Input_Id
) = E_Abstract_State
24885 and then Dep_Input_Id
= Dep_Output_Id
;
24889 end Is_In_Out_State_Clause
;
24891 ---------------------------
24892 -- Is_Null_Refined_State --
24893 ---------------------------
24895 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
24896 Item_Id
: Entity_Id
;
24899 if Is_Entity_Name
(Item
) then
24901 -- Handle abstract views generated for limited with clauses
24903 Item_Id
:= Available_View
(Entity_Of
(Item
));
24906 Ekind
(Item_Id
) = E_Abstract_State
24907 and then Has_Null_Visible_Refinement
(Item_Id
);
24911 end Is_Null_Refined_State
;
24917 procedure Match_Items
24918 (Dep_Item
: Node_Id
;
24919 Ref_Item
: Node_Id
;
24920 Matched
: out Boolean)
24922 Dep_Item_Id
: Entity_Id
;
24923 Ref_Item_Id
: Entity_Id
;
24926 -- Assume that the two items do not match
24930 -- A null matches null or Empty (special case)
24932 if Nkind
(Dep_Item
) = N_Null
24933 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24937 -- Attribute 'Result matches attribute 'Result
24939 elsif Is_Attribute_Result
(Dep_Item
)
24940 and then Is_Attribute_Result
(Ref_Item
)
24942 -- Put the entity of the related function on the list of
24943 -- matched items because attribute 'Result does not carry
24944 -- an entity similar to states and constituents.
24946 Record_Item
(Spec_Id
);
24949 -- Abstract states, current instances of concurrent types,
24950 -- discriminants, formal parameters and objects.
24952 elsif Is_Entity_Name
(Dep_Item
) then
24954 -- Handle abstract views generated for limited with clauses
24956 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24958 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
24960 -- An abstract state with visible null refinement matches
24961 -- null or Empty (special case).
24963 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
24964 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24966 Record_Item
(Dep_Item_Id
);
24969 -- An abstract state with visible non-null refinement
24970 -- matches one of its constituents, or itself for an
24971 -- abstract state with partial visible refinement.
24973 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
24974 if Is_Entity_Name
(Ref_Item
) then
24975 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
24977 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
24980 and then Present
(Encapsulating_State
(Ref_Item_Id
))
24981 and then Find_Encapsulating_State
24982 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
24984 Record_Item
(Dep_Item_Id
);
24987 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
24988 and then Ref_Item_Id
= Dep_Item_Id
24990 Record_Item
(Dep_Item_Id
);
24995 -- An abstract state without a visible refinement matches
24998 elsif Is_Entity_Name
(Ref_Item
)
24999 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
25001 Record_Item
(Dep_Item_Id
);
25005 -- A current instance of a concurrent type, discriminant,
25006 -- formal parameter or an object matches itself.
25008 elsif Is_Entity_Name
(Ref_Item
)
25009 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
25011 Record_Item
(Dep_Item_Id
);
25021 procedure Record_Item
(Item_Id
: Entity_Id
) is
25023 if No
(Matched_Items
) then
25024 Matched_Items
:= New_Elmt_List
;
25027 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
25032 Clause_Matched
: Boolean := False;
25033 Dummy
: Boolean := False;
25034 Inputs_Match
: Boolean;
25035 Next_Ref_Clause
: Node_Id
;
25036 Outputs_Match
: Boolean;
25037 Ref_Clause
: Node_Id
;
25038 Ref_Input
: Node_Id
;
25039 Ref_Output
: Node_Id
;
25041 -- Start of processing for Check_Dependency_Clause
25044 -- Do not perform this check in an instance because it was already
25045 -- performed successfully in the generic template.
25047 if Is_Generic_Instance
(Spec_Id
) then
25051 -- Examine all refinement clauses and compare them against the
25052 -- dependence clause.
25054 Ref_Clause
:= First
(Refinements
);
25055 while Present
(Ref_Clause
) loop
25056 Next_Ref_Clause
:= Next
(Ref_Clause
);
25058 -- Obtain the attributes of the current refinement clause
25060 Ref_Input
:= Expression
(Ref_Clause
);
25061 Ref_Output
:= First
(Choices
(Ref_Clause
));
25063 -- The current refinement clause matches the dependence clause
25064 -- when both outputs match and both inputs match. See routine
25065 -- Match_Items for all possible conformance scenarios.
25067 -- Depends Dep_Output => Dep_Input
25071 -- Refined_Depends Ref_Output => Ref_Input
25074 (Dep_Item
=> Dep_Input
,
25075 Ref_Item
=> Ref_Input
,
25076 Matched
=> Inputs_Match
);
25079 (Dep_Item
=> Dep_Output
,
25080 Ref_Item
=> Ref_Output
,
25081 Matched
=> Outputs_Match
);
25083 -- An In_Out state clause may be matched against a refinement with
25084 -- a null input or null output as long as the non-null side of the
25085 -- relation contains a valid constituent of the In_Out_State.
25087 if Is_In_Out_State_Clause
then
25089 -- Depends => (State => State)
25090 -- Refined_Depends => (null => Constit) -- OK
25093 and then not Outputs_Match
25094 and then Nkind
(Ref_Output
) = N_Null
25096 Outputs_Match
:= True;
25099 -- Depends => (State => State)
25100 -- Refined_Depends => (Constit => null) -- OK
25102 if not Inputs_Match
25103 and then Outputs_Match
25104 and then Nkind
(Ref_Input
) = N_Null
25106 Inputs_Match
:= True;
25110 -- The current refinement clause is legally constructed following
25111 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
25112 -- the pool of candidates. The seach continues because a single
25113 -- dependence clause may have multiple matching refinements.
25115 if Inputs_Match
and Outputs_Match
then
25116 Clause_Matched
:= True;
25117 Remove
(Ref_Clause
);
25120 Ref_Clause
:= Next_Ref_Clause
;
25123 -- Depending on the order or composition of refinement clauses, an
25124 -- In_Out state clause may not be directly refinable.
25126 -- Refined_State => (State => (Constit_1, Constit_2))
25127 -- Depends => ((Output, State) => (Input, State))
25128 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
25130 -- Matching normalized clause (State => State) fails because there is
25131 -- no direct refinement capable of satisfying this relation. Another
25132 -- similar case arises when clauses (Constit_1 => Input) and (Output
25133 -- => Constit_2) are matched first, leaving no candidates for clause
25134 -- (State => State). Both scenarios are legal as long as one of the
25135 -- previous clauses mentioned a valid constituent of State.
25137 if not Clause_Matched
25138 and then Is_In_Out_State_Clause
25139 and then Is_Already_Matched
(Dep_Input
)
25141 Clause_Matched
:= True;
25144 -- A clause where the input is an abstract state with visible null
25145 -- refinement or a 'Result attribute is implicitly matched when the
25146 -- output has already been matched in a previous clause.
25148 -- Refined_State => (State => null)
25149 -- Depends => (Output => State) -- implicitly OK
25150 -- Refined_Depends => (Output => ...)
25151 -- Depends => (...'Result => State) -- implicitly OK
25152 -- Refined_Depends => (...'Result => ...)
25154 if not Clause_Matched
25155 and then Is_Null_Refined_State
(Dep_Input
)
25156 and then Is_Already_Matched
(Dep_Output
)
25158 Clause_Matched
:= True;
25161 -- A clause where the output is an abstract state with visible null
25162 -- refinement is implicitly matched when the input has already been
25163 -- matched in a previous clause.
25165 -- Refined_State => (State => null)
25166 -- Depends => (State => Input) -- implicitly OK
25167 -- Refined_Depends => (... => Input)
25169 if not Clause_Matched
25170 and then Is_Null_Refined_State
(Dep_Output
)
25171 and then Is_Already_Matched
(Dep_Input
)
25173 Clause_Matched
:= True;
25176 -- At this point either all refinement clauses have been examined or
25177 -- pragma Refined_Depends contains a solitary null. Only an abstract
25178 -- state with null refinement can possibly match these cases.
25180 -- Refined_State => (State => null)
25181 -- Depends => (State => null)
25182 -- Refined_Depends => null -- OK
25184 if not Clause_Matched
then
25186 (Dep_Item
=> Dep_Input
,
25188 Matched
=> Inputs_Match
);
25191 (Dep_Item
=> Dep_Output
,
25193 Matched
=> Outputs_Match
);
25195 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
25198 -- If the contents of Refined_Depends are legal, then the current
25199 -- dependence clause should be satisfied either by an explicit match
25200 -- or by one of the special cases.
25202 if not Clause_Matched
then
25204 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
25205 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
25207 end Check_Dependency_Clause
;
25209 -------------------------
25210 -- Check_Output_States --
25211 -------------------------
25213 procedure Check_Output_States
25214 (Spec_Id
: Entity_Id
;
25215 Spec_Inputs
: Elist_Id
;
25216 Spec_Outputs
: Elist_Id
;
25217 Body_Inputs
: Elist_Id
;
25218 Body_Outputs
: Elist_Id
)
25220 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25221 -- Determine whether all constituents of state State_Id with full
25222 -- visible refinement are used as outputs in pragma Refined_Depends.
25223 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
25225 -----------------------------
25226 -- Check_Constituent_Usage --
25227 -----------------------------
25229 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25230 Constits
: constant Elist_Id
:=
25231 Partial_Refinement_Constituents
(State_Id
);
25232 Constit_Elmt
: Elmt_Id
;
25233 Constit_Id
: Entity_Id
;
25234 Only_Partial
: constant Boolean :=
25235 not Has_Visible_Refinement
(State_Id
);
25236 Posted
: Boolean := False;
25239 if Present
(Constits
) then
25240 Constit_Elmt
:= First_Elmt
(Constits
);
25241 while Present
(Constit_Elmt
) loop
25242 Constit_Id
:= Node
(Constit_Elmt
);
25244 -- Issue an error when a constituent of State_Id is used,
25245 -- and State_Id has only partial visible refinement
25246 -- (SPARK RM 7.2.4(3d)).
25248 if Only_Partial
then
25249 if (Present
(Body_Inputs
)
25250 and then Appears_In
(Body_Inputs
, Constit_Id
))
25252 (Present
(Body_Outputs
)
25253 and then Appears_In
(Body_Outputs
, Constit_Id
))
25255 Error_Msg_Name_1
:= Chars
(State_Id
);
25257 ("constituent & of state % cannot be used in "
25258 & "dependence refinement", N
, Constit_Id
);
25259 Error_Msg_Name_1
:= Chars
(State_Id
);
25260 SPARK_Msg_N
("\use state % instead", N
);
25263 -- The constituent acts as an input (SPARK RM 7.2.5(3))
25265 elsif Present
(Body_Inputs
)
25266 and then Appears_In
(Body_Inputs
, Constit_Id
)
25268 Error_Msg_Name_1
:= Chars
(State_Id
);
25270 ("constituent & of state % must act as output in "
25271 & "dependence refinement", N
, Constit_Id
);
25273 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25275 elsif No
(Body_Outputs
)
25276 or else not Appears_In
(Body_Outputs
, Constit_Id
)
25281 ("output state & must be replaced by all its "
25282 & "constituents in dependence refinement",
25287 ("\constituent & is missing in output list",
25291 Next_Elmt
(Constit_Elmt
);
25294 end Check_Constituent_Usage
;
25299 Item_Elmt
: Elmt_Id
;
25300 Item_Id
: Entity_Id
;
25302 -- Start of processing for Check_Output_States
25305 -- Do not perform this check in an instance because it was already
25306 -- performed successfully in the generic template.
25308 if Is_Generic_Instance
(Spec_Id
) then
25311 -- Inspect the outputs of pragma Depends looking for a state with a
25312 -- visible refinement.
25314 elsif Present
(Spec_Outputs
) then
25315 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
25316 while Present
(Item_Elmt
) loop
25317 Item
:= Node
(Item_Elmt
);
25319 -- Deal with the mixed nature of the input and output lists
25321 if Nkind
(Item
) = N_Defining_Identifier
then
25324 Item_Id
:= Available_View
(Entity_Of
(Item
));
25327 if Ekind
(Item_Id
) = E_Abstract_State
then
25329 -- The state acts as an input-output, skip it
25331 if Present
(Spec_Inputs
)
25332 and then Appears_In
(Spec_Inputs
, Item_Id
)
25336 -- Ensure that all of the constituents are utilized as
25337 -- outputs in pragma Refined_Depends.
25339 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25340 Check_Constituent_Usage
(Item_Id
);
25344 Next_Elmt
(Item_Elmt
);
25347 end Check_Output_States
;
25349 --------------------
25350 -- Collect_States --
25351 --------------------
25353 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
25354 procedure Collect_State
25356 States
: in out Elist_Id
);
25357 -- Add the entity of Item to list States when it denotes to a state
25359 -------------------
25360 -- Collect_State --
25361 -------------------
25363 procedure Collect_State
25365 States
: in out Elist_Id
)
25370 if Is_Entity_Name
(Item
) then
25371 Id
:= Entity_Of
(Item
);
25373 if Ekind
(Id
) = E_Abstract_State
then
25374 if No
(States
) then
25375 States
:= New_Elmt_List
;
25378 Append_Unique_Elmt
(Id
, States
);
25388 States
: Elist_Id
:= No_Elist
;
25390 -- Start of processing for Collect_States
25393 Clause
:= First
(Clauses
);
25394 while Present
(Clause
) loop
25395 Input
:= Expression
(Clause
);
25396 Output
:= First
(Choices
(Clause
));
25398 Collect_State
(Input
, States
);
25399 Collect_State
(Output
, States
);
25405 end Collect_States
;
25407 -----------------------
25408 -- Normalize_Clauses --
25409 -----------------------
25411 procedure Normalize_Clauses
(Clauses
: List_Id
) is
25412 procedure Normalize_Inputs
(Clause
: Node_Id
);
25413 -- Normalize clause Clause by creating multiple clauses for each
25414 -- input item of Clause. It is assumed that Clause has exactly one
25415 -- output. The transformation is as follows:
25417 -- Output => (Input_1, Input_2) -- original
25419 -- Output => Input_1 -- normalizations
25420 -- Output => Input_2
25422 procedure Normalize_Outputs
(Clause
: Node_Id
);
25423 -- Normalize clause Clause by creating multiple clause for each
25424 -- output item of Clause. The transformation is as follows:
25426 -- (Output_1, Output_2) => Input -- original
25428 -- Output_1 => Input -- normalization
25429 -- Output_2 => Input
25431 ----------------------
25432 -- Normalize_Inputs --
25433 ----------------------
25435 procedure Normalize_Inputs
(Clause
: Node_Id
) is
25436 Inputs
: constant Node_Id
:= Expression
(Clause
);
25437 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25438 Output
: constant List_Id
:= Choices
(Clause
);
25439 Last_Input
: Node_Id
;
25441 New_Clause
: Node_Id
;
25442 Next_Input
: Node_Id
;
25445 -- Normalization is performed only when the original clause has
25446 -- more than one input. Multiple inputs appear as an aggregate.
25448 if Nkind
(Inputs
) = N_Aggregate
then
25449 Last_Input
:= Last
(Expressions
(Inputs
));
25451 -- Create a new clause for each input
25453 Input
:= First
(Expressions
(Inputs
));
25454 while Present
(Input
) loop
25455 Next_Input
:= Next
(Input
);
25457 -- Unhook the current input from the original input list
25458 -- because it will be relocated to a new clause.
25462 -- Special processing for the last input. At this point the
25463 -- original aggregate has been stripped down to one element.
25464 -- Replace the aggregate by the element itself.
25466 if Input
= Last_Input
then
25467 Rewrite
(Inputs
, Input
);
25469 -- Generate a clause of the form:
25474 Make_Component_Association
(Loc
,
25475 Choices
=> New_Copy_List_Tree
(Output
),
25476 Expression
=> Input
);
25478 -- The new clause contains replicated content that has
25479 -- already been analyzed, mark the clause as analyzed.
25481 Set_Analyzed
(New_Clause
);
25482 Insert_After
(Clause
, New_Clause
);
25485 Input
:= Next_Input
;
25488 end Normalize_Inputs
;
25490 -----------------------
25491 -- Normalize_Outputs --
25492 -----------------------
25494 procedure Normalize_Outputs
(Clause
: Node_Id
) is
25495 Inputs
: constant Node_Id
:= Expression
(Clause
);
25496 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25497 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
25498 Last_Output
: Node_Id
;
25499 New_Clause
: Node_Id
;
25500 Next_Output
: Node_Id
;
25504 -- Multiple outputs appear as an aggregate. Nothing to do when
25505 -- the clause has exactly one output.
25507 if Nkind
(Outputs
) = N_Aggregate
then
25508 Last_Output
:= Last
(Expressions
(Outputs
));
25510 -- Create a clause for each output. Note that each time a new
25511 -- clause is created, the original output list slowly shrinks
25512 -- until there is one item left.
25514 Output
:= First
(Expressions
(Outputs
));
25515 while Present
(Output
) loop
25516 Next_Output
:= Next
(Output
);
25518 -- Unhook the output from the original output list as it
25519 -- will be relocated to a new clause.
25523 -- Special processing for the last output. At this point
25524 -- the original aggregate has been stripped down to one
25525 -- element. Replace the aggregate by the element itself.
25527 if Output
= Last_Output
then
25528 Rewrite
(Outputs
, Output
);
25531 -- Generate a clause of the form:
25532 -- (Output => Inputs)
25535 Make_Component_Association
(Loc
,
25536 Choices
=> New_List
(Output
),
25537 Expression
=> New_Copy_Tree
(Inputs
));
25539 -- The new clause contains replicated content that has
25540 -- already been analyzed. There is not need to reanalyze
25543 Set_Analyzed
(New_Clause
);
25544 Insert_After
(Clause
, New_Clause
);
25547 Output
:= Next_Output
;
25550 end Normalize_Outputs
;
25556 -- Start of processing for Normalize_Clauses
25559 Clause
:= First
(Clauses
);
25560 while Present
(Clause
) loop
25561 Normalize_Outputs
(Clause
);
25565 Clause
:= First
(Clauses
);
25566 while Present
(Clause
) loop
25567 Normalize_Inputs
(Clause
);
25570 end Normalize_Clauses
;
25572 --------------------------
25573 -- Remove_Extra_Clauses --
25574 --------------------------
25576 procedure Remove_Extra_Clauses
25577 (Clauses
: List_Id
;
25578 Matched_Items
: Elist_Id
)
25582 Input_Id
: Entity_Id
;
25583 Next_Clause
: Node_Id
;
25585 State_Id
: Entity_Id
;
25588 Clause
:= First
(Clauses
);
25589 while Present
(Clause
) loop
25590 Next_Clause
:= Next
(Clause
);
25592 Input
:= Expression
(Clause
);
25593 Output
:= First
(Choices
(Clause
));
25595 -- Recognize a clause of the form
25599 -- where Input is a constituent of a state which was already
25600 -- successfully matched. This clause must be removed because it
25601 -- simply indicates that some of the constituents of the state
25604 -- Refined_State => (State => (Constit_1, Constit_2))
25605 -- Depends => (Output => State)
25606 -- Refined_Depends => ((Output => Constit_1), -- State matched
25607 -- (null => Constit_2)) -- OK
25609 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
25611 -- Handle abstract views generated for limited with clauses
25613 Input_Id
:= Available_View
(Entity_Of
(Input
));
25615 -- The input must be a constituent of a state
25617 if Ekind_In
(Input_Id
, E_Abstract_State
,
25620 and then Present
(Encapsulating_State
(Input_Id
))
25622 State_Id
:= Encapsulating_State
(Input_Id
);
25624 -- The state must have a non-null visible refinement and be
25625 -- matched in a previous clause.
25627 if Has_Non_Null_Visible_Refinement
(State_Id
)
25628 and then Contains
(Matched_Items
, State_Id
)
25634 -- Recognize a clause of the form
25638 -- where Output is an arbitrary item. This clause must be removed
25639 -- because a null input legitimately matches anything.
25641 elsif Nkind
(Input
) = N_Null
then
25645 Clause
:= Next_Clause
;
25647 end Remove_Extra_Clauses
;
25649 --------------------------
25650 -- Report_Extra_Clauses --
25651 --------------------------
25653 procedure Report_Extra_Clauses
25654 (Spec_Id
: Entity_Id
;
25660 -- Do not perform this check in an instance because it was already
25661 -- performed successfully in the generic template.
25663 if Is_Generic_Instance
(Spec_Id
) then
25666 elsif Present
(Clauses
) then
25667 Clause
:= First
(Clauses
);
25668 while Present
(Clause
) loop
25670 ("unmatched or extra clause in dependence refinement",
25676 end Report_Extra_Clauses
;
25680 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25681 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25682 Errors
: constant Nat
:= Serious_Errors_Detected
;
25689 Body_Inputs
: Elist_Id
:= No_Elist
;
25690 Body_Outputs
: Elist_Id
:= No_Elist
;
25691 -- The inputs and outputs of the subprogram body synthesized from pragma
25692 -- Refined_Depends.
25694 Dependencies
: List_Id
:= No_List
;
25696 -- The corresponding Depends pragma along with its clauses
25698 Matched_Items
: Elist_Id
:= No_Elist
;
25699 -- A list containing the entities of all successfully matched items
25700 -- found in pragma Depends.
25702 Refinements
: List_Id
:= No_List
;
25703 -- The clauses of pragma Refined_Depends
25705 Spec_Id
: Entity_Id
;
25706 -- The entity of the subprogram subject to pragma Refined_Depends
25708 Spec_Inputs
: Elist_Id
:= No_Elist
;
25709 Spec_Outputs
: Elist_Id
:= No_Elist
;
25710 -- The inputs and outputs of the subprogram spec synthesized from pragma
25713 States
: Elist_Id
:= No_Elist
;
25714 -- A list containing the entities of all states whose constituents
25715 -- appear in pragma Depends.
25717 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25720 -- Do not analyze the pragma multiple times
25722 if Is_Analyzed_Pragma
(N
) then
25726 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25728 -- Use the anonymous object as the proper spec when Refined_Depends
25729 -- applies to the body of a single task type. The object carries the
25730 -- proper Chars as well as all non-refined versions of pragmas.
25732 if Is_Single_Concurrent_Type
(Spec_Id
) then
25733 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25736 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25738 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25739 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25741 if No
(Depends
) then
25743 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25744 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
25748 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25750 -- A null dependency relation renders the refinement useless because it
25751 -- cannot possibly mention abstract states with visible refinement. Note
25752 -- that the inverse is not true as states may be refined to null
25753 -- (SPARK RM 7.2.5(2)).
25755 if Nkind
(Deps
) = N_Null
then
25757 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25758 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
25762 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25763 -- This ensures that the categorization of all refined dependency items
25764 -- is consistent with their role.
25766 Analyze_Depends_In_Decl_Part
(N
);
25768 -- Do not match dependencies against refinements if Refined_Depends is
25769 -- illegal to avoid emitting misleading error.
25771 if Serious_Errors_Detected
= Errors
then
25773 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25774 -- the inputs and outputs of the subprogram spec and body to verify
25775 -- the use of states with visible refinement and their constituents.
25777 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
25778 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
25780 Collect_Subprogram_Inputs_Outputs
25781 (Subp_Id
=> Spec_Id
,
25782 Synthesize
=> True,
25783 Subp_Inputs
=> Spec_Inputs
,
25784 Subp_Outputs
=> Spec_Outputs
,
25785 Global_Seen
=> Dummy
);
25787 Collect_Subprogram_Inputs_Outputs
25788 (Subp_Id
=> Body_Id
,
25789 Synthesize
=> True,
25790 Subp_Inputs
=> Body_Inputs
,
25791 Subp_Outputs
=> Body_Outputs
,
25792 Global_Seen
=> Dummy
);
25794 -- For an output state with a visible refinement, ensure that all
25795 -- constituents appear as outputs in the dependency refinement.
25797 Check_Output_States
25798 (Spec_Id
=> Spec_Id
,
25799 Spec_Inputs
=> Spec_Inputs
,
25800 Spec_Outputs
=> Spec_Outputs
,
25801 Body_Inputs
=> Body_Inputs
,
25802 Body_Outputs
=> Body_Outputs
);
25805 -- Matching is disabled in ASIS because clauses are not normalized as
25806 -- this is a tree altering activity similar to expansion.
25812 -- Multiple dependency clauses appear as component associations of an
25813 -- aggregate. Note that the clauses are copied because the algorithm
25814 -- modifies them and this should not be visible in Depends.
25816 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
25817 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
25818 Normalize_Clauses
(Dependencies
);
25820 -- Gather all states which appear in Depends
25822 States
:= Collect_States
(Dependencies
);
25824 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
25826 if Nkind
(Refs
) = N_Null
then
25827 Refinements
:= No_List
;
25829 -- Multiple dependency clauses appear as component associations of an
25830 -- aggregate. Note that the clauses are copied because the algorithm
25831 -- modifies them and this should not be visible in Refined_Depends.
25833 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
25834 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
25835 Normalize_Clauses
(Refinements
);
25838 -- At this point the clauses of pragmas Depends and Refined_Depends
25839 -- have been normalized into simple dependencies between one output
25840 -- and one input. Examine all clauses of pragma Depends looking for
25841 -- matching clauses in pragma Refined_Depends.
25843 Clause
:= First
(Dependencies
);
25844 while Present
(Clause
) loop
25845 Check_Dependency_Clause
25846 (Spec_Id
=> Spec_Id
,
25847 Dep_Clause
=> Clause
,
25848 Dep_States
=> States
,
25849 Refinements
=> Refinements
,
25850 Matched_Items
=> Matched_Items
);
25855 -- Pragma Refined_Depends may contain multiple clarification clauses
25856 -- which indicate that certain constituents do not influence the data
25857 -- flow in any way. Such clauses must be removed as long as the state
25858 -- has been matched, otherwise they will be incorrectly flagged as
25861 -- Refined_State => (State => (Constit_1, Constit_2))
25862 -- Depends => (Output => State)
25863 -- Refined_Depends => ((Output => Constit_1), -- State matched
25864 -- (null => Constit_2)) -- must be removed
25866 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
25868 if Serious_Errors_Detected
= Errors
then
25869 Report_Extra_Clauses
(Spec_Id
, Refinements
);
25874 Set_Is_Analyzed_Pragma
(N
);
25875 end Analyze_Refined_Depends_In_Decl_Part
;
25877 -----------------------------------------
25878 -- Analyze_Refined_Global_In_Decl_Part --
25879 -----------------------------------------
25881 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
25883 -- The corresponding Global pragma
25885 Has_In_State
: Boolean := False;
25886 Has_In_Out_State
: Boolean := False;
25887 Has_Out_State
: Boolean := False;
25888 Has_Proof_In_State
: Boolean := False;
25889 -- These flags are set when the corresponding Global pragma has a state
25890 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25893 Has_Null_State
: Boolean := False;
25894 -- This flag is set when the corresponding Global pragma has at least
25895 -- one state with a null refinement.
25897 In_Constits
: Elist_Id
:= No_Elist
;
25898 In_Out_Constits
: Elist_Id
:= No_Elist
;
25899 Out_Constits
: Elist_Id
:= No_Elist
;
25900 Proof_In_Constits
: Elist_Id
:= No_Elist
;
25901 -- These lists contain the entities of all Input, In_Out, Output and
25902 -- Proof_In constituents that appear in Refined_Global and participate
25903 -- in state refinement.
25905 In_Items
: Elist_Id
:= No_Elist
;
25906 In_Out_Items
: Elist_Id
:= No_Elist
;
25907 Out_Items
: Elist_Id
:= No_Elist
;
25908 Proof_In_Items
: Elist_Id
:= No_Elist
;
25909 -- These lists contain the entities of all Input, In_Out, Output and
25910 -- Proof_In items defined in the corresponding Global pragma.
25912 Repeat_Items
: Elist_Id
:= No_Elist
;
25913 -- A list of all global items without full visible refinement found
25914 -- in pragma Global. These states should be repeated in the global
25915 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25916 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25918 Spec_Id
: Entity_Id
;
25919 -- The entity of the subprogram subject to pragma Refined_Global
25921 States
: Elist_Id
:= No_Elist
;
25922 -- A list of all states with full or partial visible refinement found in
25925 procedure Check_In_Out_States
;
25926 -- Determine whether the corresponding Global pragma mentions In_Out
25927 -- states with visible refinement and if so, ensure that one of the
25928 -- following completions apply to the constituents of the state:
25929 -- 1) there is at least one constituent of mode In_Out
25930 -- 2) there is at least one Input and one Output constituent
25931 -- 3) not all constituents are present and one of them is of mode
25933 -- This routine may remove elements from In_Constits, In_Out_Constits,
25934 -- Out_Constits and Proof_In_Constits.
25936 procedure Check_Input_States
;
25937 -- Determine whether the corresponding Global pragma mentions Input
25938 -- states with visible refinement and if so, ensure that at least one of
25939 -- its constituents appears as an Input item in Refined_Global.
25940 -- This routine may remove elements from In_Constits, In_Out_Constits,
25941 -- Out_Constits and Proof_In_Constits.
25943 procedure Check_Output_States
;
25944 -- Determine whether the corresponding Global pragma mentions Output
25945 -- states with visible refinement and if so, ensure that all of its
25946 -- constituents appear as Output items in Refined_Global.
25947 -- This routine may remove elements from In_Constits, In_Out_Constits,
25948 -- Out_Constits and Proof_In_Constits.
25950 procedure Check_Proof_In_States
;
25951 -- Determine whether the corresponding Global pragma mentions Proof_In
25952 -- states with visible refinement and if so, ensure that at least one of
25953 -- its constituents appears as a Proof_In item in Refined_Global.
25954 -- This routine may remove elements from In_Constits, In_Out_Constits,
25955 -- Out_Constits and Proof_In_Constits.
25957 procedure Check_Refined_Global_List
25959 Global_Mode
: Name_Id
:= Name_Input
);
25960 -- Verify the legality of a single global list declaration. Global_Mode
25961 -- denotes the current mode in effect.
25963 procedure Collect_Global_Items
25965 Mode
: Name_Id
:= Name_Input
);
25966 -- Gather all Input, In_Out, Output and Proof_In items from node List
25967 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25968 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25969 -- and Has_Proof_In_State are set when there is at least one abstract
25970 -- state with full or partial visible refinement available in the
25971 -- corresponding mode. Flag Has_Null_State is set when at least state
25972 -- has a null refinement. Mode denotes the current global mode in
25975 function Present_Then_Remove
25977 Item
: Entity_Id
) return Boolean;
25978 -- Search List for a particular entity Item. If Item has been found,
25979 -- remove it from List. This routine is used to strip lists In_Constits,
25980 -- In_Out_Constits and Out_Constits of valid constituents.
25982 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
25983 -- Same as function Present_Then_Remove, but do not report the presence
25984 -- of Item in List.
25986 procedure Report_Extra_Constituents
;
25987 -- Emit an error for each constituent found in lists In_Constits,
25988 -- In_Out_Constits and Out_Constits.
25990 procedure Report_Missing_Items
;
25991 -- Emit an error for each global item not repeated found in list
25994 -------------------------
25995 -- Check_In_Out_States --
25996 -------------------------
25998 procedure Check_In_Out_States
is
25999 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26000 -- Determine whether one of the following coverage scenarios is in
26002 -- 1) there is at least one constituent of mode In_Out or Output
26003 -- 2) there is at least one pair of constituents with modes Input
26004 -- and Output, or Proof_In and Output.
26005 -- 3) there is at least one constituent of mode Output and not all
26006 -- constituents are present.
26007 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
26009 -----------------------------
26010 -- Check_Constituent_Usage --
26011 -----------------------------
26013 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26014 Constits
: constant Elist_Id
:=
26015 Partial_Refinement_Constituents
(State_Id
);
26016 Constit_Elmt
: Elmt_Id
;
26017 Constit_Id
: Entity_Id
;
26018 Has_Missing
: Boolean := False;
26019 In_Out_Seen
: Boolean := False;
26020 Input_Seen
: Boolean := False;
26021 Output_Seen
: Boolean := False;
26022 Proof_In_Seen
: Boolean := False;
26025 -- Process all the constituents of the state and note their modes
26026 -- within the global refinement.
26028 if Present
(Constits
) then
26029 Constit_Elmt
:= First_Elmt
(Constits
);
26030 while Present
(Constit_Elmt
) loop
26031 Constit_Id
:= Node
(Constit_Elmt
);
26033 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26034 Input_Seen
:= True;
26036 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
26037 In_Out_Seen
:= True;
26039 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26040 Output_Seen
:= True;
26042 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26044 Proof_In_Seen
:= True;
26047 Has_Missing
:= True;
26050 Next_Elmt
(Constit_Elmt
);
26054 -- An In_Out constituent is a valid completion
26056 if In_Out_Seen
then
26059 -- A pair of one Input/Proof_In and one Output constituent is a
26060 -- valid completion.
26062 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
26065 elsif Output_Seen
then
26067 -- A single Output constituent is a valid completion only when
26068 -- some of the other constituents are missing.
26070 if Has_Missing
then
26073 -- Otherwise all constituents are of mode Output
26077 ("global refinement of state & must include at least one "
26078 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
26082 -- The state lacks a completion. When full refinement is visible,
26083 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
26084 -- refinement is visible, emit an error if the abstract state
26085 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
26086 -- both are utilized, Check_State_And_Constituent_Use. will issue
26089 elsif not Input_Seen
26090 and then not In_Out_Seen
26091 and then not Output_Seen
26092 and then not Proof_In_Seen
26094 if Has_Visible_Refinement
(State_Id
)
26095 or else Contains
(Repeat_Items
, State_Id
)
26098 ("missing global refinement of state &", N
, State_Id
);
26101 -- Otherwise the state has a malformed completion where at least
26102 -- one of the constituents has a different mode.
26106 ("global refinement of state & redefines the mode of its "
26107 & "constituents", N
, State_Id
);
26109 end Check_Constituent_Usage
;
26113 Item_Elmt
: Elmt_Id
;
26114 Item_Id
: Entity_Id
;
26116 -- Start of processing for Check_In_Out_States
26119 -- Do not perform this check in an instance because it was already
26120 -- performed successfully in the generic template.
26122 if Is_Generic_Instance
(Spec_Id
) then
26125 -- Inspect the In_Out items of the corresponding Global pragma
26126 -- looking for a state with a visible refinement.
26128 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
26129 Item_Elmt
:= First_Elmt
(In_Out_Items
);
26130 while Present
(Item_Elmt
) loop
26131 Item_Id
:= Node
(Item_Elmt
);
26133 -- Ensure that one of the three coverage variants is satisfied
26135 if Ekind
(Item_Id
) = E_Abstract_State
26136 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26138 Check_Constituent_Usage
(Item_Id
);
26141 Next_Elmt
(Item_Elmt
);
26144 end Check_In_Out_States
;
26146 ------------------------
26147 -- Check_Input_States --
26148 ------------------------
26150 procedure Check_Input_States
is
26151 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26152 -- Determine whether at least one constituent of state State_Id with
26153 -- full or partial visible refinement is used and has mode Input.
26154 -- Ensure that the remaining constituents do not have In_Out or
26155 -- Output modes. Emit an error if this is not the case
26156 -- (SPARK RM 7.2.4(5)).
26158 -----------------------------
26159 -- Check_Constituent_Usage --
26160 -----------------------------
26162 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26163 Constits
: constant Elist_Id
:=
26164 Partial_Refinement_Constituents
(State_Id
);
26165 Constit_Elmt
: Elmt_Id
;
26166 Constit_Id
: Entity_Id
;
26167 In_Seen
: Boolean := False;
26170 if Present
(Constits
) then
26171 Constit_Elmt
:= First_Elmt
(Constits
);
26172 while Present
(Constit_Elmt
) loop
26173 Constit_Id
:= Node
(Constit_Elmt
);
26175 -- At least one of the constituents appears as an Input
26177 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26180 -- A Proof_In constituent can refine an Input state as long
26181 -- as there is at least one Input constituent present.
26183 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26187 -- The constituent appears in the global refinement, but has
26188 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
26190 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26191 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26193 Error_Msg_Name_1
:= Chars
(State_Id
);
26195 ("constituent & of state % must have mode `Input` in "
26196 & "global refinement", N
, Constit_Id
);
26199 Next_Elmt
(Constit_Elmt
);
26203 -- Not one of the constituents appeared as Input. Always emit an
26204 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
26205 -- When only partial refinement is visible, emit an error if the
26206 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26207 -- the case where both are utilized, an error will be issued in
26208 -- Check_State_And_Constituent_Use.
26211 and then (Has_Visible_Refinement
(State_Id
)
26212 or else Contains
(Repeat_Items
, State_Id
))
26215 ("global refinement of state & must include at least one "
26216 & "constituent of mode `Input`", N
, State_Id
);
26218 end Check_Constituent_Usage
;
26222 Item_Elmt
: Elmt_Id
;
26223 Item_Id
: Entity_Id
;
26225 -- Start of processing for Check_Input_States
26228 -- Do not perform this check in an instance because it was already
26229 -- performed successfully in the generic template.
26231 if Is_Generic_Instance
(Spec_Id
) then
26234 -- Inspect the Input items of the corresponding Global pragma looking
26235 -- for a state with a visible refinement.
26237 elsif Has_In_State
and then Present
(In_Items
) then
26238 Item_Elmt
:= First_Elmt
(In_Items
);
26239 while Present
(Item_Elmt
) loop
26240 Item_Id
:= Node
(Item_Elmt
);
26242 -- When full refinement is visible, ensure that at least one of
26243 -- the constituents is utilized and is of mode Input. When only
26244 -- partial refinement is visible, ensure that either one of
26245 -- the constituents is utilized and is of mode Input, or the
26246 -- abstract state is repeated and no constituent is utilized.
26248 if Ekind
(Item_Id
) = E_Abstract_State
26249 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26251 Check_Constituent_Usage
(Item_Id
);
26254 Next_Elmt
(Item_Elmt
);
26257 end Check_Input_States
;
26259 -------------------------
26260 -- Check_Output_States --
26261 -------------------------
26263 procedure Check_Output_States
is
26264 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26265 -- Determine whether all constituents of state State_Id with full
26266 -- visible refinement are used and have mode Output. Emit an error
26267 -- if this is not the case (SPARK RM 7.2.4(5)).
26269 -----------------------------
26270 -- Check_Constituent_Usage --
26271 -----------------------------
26273 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26274 Constits
: constant Elist_Id
:=
26275 Partial_Refinement_Constituents
(State_Id
);
26276 Only_Partial
: constant Boolean :=
26277 not Has_Visible_Refinement
(State_Id
);
26278 Constit_Elmt
: Elmt_Id
;
26279 Constit_Id
: Entity_Id
;
26280 Posted
: Boolean := False;
26283 if Present
(Constits
) then
26284 Constit_Elmt
:= First_Elmt
(Constits
);
26285 while Present
(Constit_Elmt
) loop
26286 Constit_Id
:= Node
(Constit_Elmt
);
26288 -- Issue an error when a constituent of State_Id is utilized
26289 -- and State_Id has only partial visible refinement
26290 -- (SPARK RM 7.2.4(3d)).
26292 if Only_Partial
then
26293 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
26294 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
26296 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26298 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26300 Error_Msg_Name_1
:= Chars
(State_Id
);
26302 ("constituent & of state % cannot be used in global "
26303 & "refinement", N
, Constit_Id
);
26304 Error_Msg_Name_1
:= Chars
(State_Id
);
26305 SPARK_Msg_N
("\use state % instead", N
);
26308 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26311 -- The constituent appears in the global refinement, but has
26312 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
26314 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26315 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26316 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26318 Error_Msg_Name_1
:= Chars
(State_Id
);
26320 ("constituent & of state % must have mode `Output` in "
26321 & "global refinement", N
, Constit_Id
);
26323 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26329 ("`Output` state & must be replaced by all its "
26330 & "constituents in global refinement", N
, State_Id
);
26334 ("\constituent & is missing in output list",
26338 Next_Elmt
(Constit_Elmt
);
26341 end Check_Constituent_Usage
;
26345 Item_Elmt
: Elmt_Id
;
26346 Item_Id
: Entity_Id
;
26348 -- Start of processing for Check_Output_States
26351 -- Do not perform this check in an instance because it was already
26352 -- performed successfully in the generic template.
26354 if Is_Generic_Instance
(Spec_Id
) then
26357 -- Inspect the Output items of the corresponding Global pragma
26358 -- looking for a state with a visible refinement.
26360 elsif Has_Out_State
and then Present
(Out_Items
) then
26361 Item_Elmt
:= First_Elmt
(Out_Items
);
26362 while Present
(Item_Elmt
) loop
26363 Item_Id
:= Node
(Item_Elmt
);
26365 -- When full refinement is visible, ensure that all of the
26366 -- constituents are utilized and they have mode Output. When
26367 -- only partial refinement is visible, ensure that no
26368 -- constituent is utilized.
26370 if Ekind
(Item_Id
) = E_Abstract_State
26371 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26373 Check_Constituent_Usage
(Item_Id
);
26376 Next_Elmt
(Item_Elmt
);
26379 end Check_Output_States
;
26381 ---------------------------
26382 -- Check_Proof_In_States --
26383 ---------------------------
26385 procedure Check_Proof_In_States
is
26386 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26387 -- Determine whether at least one constituent of state State_Id with
26388 -- full or partial visible refinement is used and has mode Proof_In.
26389 -- Ensure that the remaining constituents do not have Input, In_Out,
26390 -- or Output modes. Emit an error if this is not the case
26391 -- (SPARK RM 7.2.4(5)).
26393 -----------------------------
26394 -- Check_Constituent_Usage --
26395 -----------------------------
26397 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26398 Constits
: constant Elist_Id
:=
26399 Partial_Refinement_Constituents
(State_Id
);
26400 Constit_Elmt
: Elmt_Id
;
26401 Constit_Id
: Entity_Id
;
26402 Proof_In_Seen
: Boolean := False;
26405 if Present
(Constits
) then
26406 Constit_Elmt
:= First_Elmt
(Constits
);
26407 while Present
(Constit_Elmt
) loop
26408 Constit_Id
:= Node
(Constit_Elmt
);
26410 -- At least one of the constituents appears as Proof_In
26412 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
26413 Proof_In_Seen
:= True;
26415 -- The constituent appears in the global refinement, but has
26416 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
26418 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26419 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26420 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26422 Error_Msg_Name_1
:= Chars
(State_Id
);
26424 ("constituent & of state % must have mode `Proof_In` "
26425 & "in global refinement", N
, Constit_Id
);
26428 Next_Elmt
(Constit_Elmt
);
26432 -- Not one of the constituents appeared as Proof_In. Always emit
26433 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
26434 -- When only partial refinement is visible, emit an error if the
26435 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26436 -- the case where both are utilized, an error will be issued by
26437 -- Check_State_And_Constituent_Use.
26439 if not Proof_In_Seen
26440 and then (Has_Visible_Refinement
(State_Id
)
26441 or else Contains
(Repeat_Items
, State_Id
))
26444 ("global refinement of state & must include at least one "
26445 & "constituent of mode `Proof_In`", N
, State_Id
);
26447 end Check_Constituent_Usage
;
26451 Item_Elmt
: Elmt_Id
;
26452 Item_Id
: Entity_Id
;
26454 -- Start of processing for Check_Proof_In_States
26457 -- Do not perform this check in an instance because it was already
26458 -- performed successfully in the generic template.
26460 if Is_Generic_Instance
(Spec_Id
) then
26463 -- Inspect the Proof_In items of the corresponding Global pragma
26464 -- looking for a state with a visible refinement.
26466 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
26467 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
26468 while Present
(Item_Elmt
) loop
26469 Item_Id
:= Node
(Item_Elmt
);
26471 -- Ensure that at least one of the constituents is utilized
26472 -- and is of mode Proof_In. When only partial refinement is
26473 -- visible, ensure that either one of the constituents is
26474 -- utilized and is of mode Proof_In, or the abstract state
26475 -- is repeated and no constituent is utilized.
26477 if Ekind
(Item_Id
) = E_Abstract_State
26478 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26480 Check_Constituent_Usage
(Item_Id
);
26483 Next_Elmt
(Item_Elmt
);
26486 end Check_Proof_In_States
;
26488 -------------------------------
26489 -- Check_Refined_Global_List --
26490 -------------------------------
26492 procedure Check_Refined_Global_List
26494 Global_Mode
: Name_Id
:= Name_Input
)
26496 procedure Check_Refined_Global_Item
26498 Global_Mode
: Name_Id
);
26499 -- Verify the legality of a single global item declaration. Parameter
26500 -- Global_Mode denotes the current mode in effect.
26502 -------------------------------
26503 -- Check_Refined_Global_Item --
26504 -------------------------------
26506 procedure Check_Refined_Global_Item
26508 Global_Mode
: Name_Id
)
26510 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
26512 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
26513 -- Issue a common error message for all mode mismatches. Expect
26514 -- denotes the expected mode.
26516 -----------------------------
26517 -- Inconsistent_Mode_Error --
26518 -----------------------------
26520 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
26523 ("global item & has inconsistent modes", Item
, Item_Id
);
26525 Error_Msg_Name_1
:= Global_Mode
;
26526 Error_Msg_Name_2
:= Expect
;
26527 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
26528 end Inconsistent_Mode_Error
;
26532 Enc_State
: Entity_Id
:= Empty
;
26533 -- Encapsulating state for constituent, Empty otherwise
26535 -- Start of processing for Check_Refined_Global_Item
26538 if Ekind_In
(Item_Id
, E_Abstract_State
,
26542 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
26545 -- When the state or object acts as a constituent of another
26546 -- state with a visible refinement, collect it for the state
26547 -- completeness checks performed later on. Note that the item
26548 -- acts as a constituent only when the encapsulating state is
26549 -- present in pragma Global.
26551 if Present
(Enc_State
)
26552 and then (Has_Visible_Refinement
(Enc_State
)
26553 or else Has_Partial_Visible_Refinement
(Enc_State
))
26554 and then Contains
(States
, Enc_State
)
26556 -- If the state has only partial visible refinement, remove it
26557 -- from the list of items that should be repeated from pragma
26560 if not Has_Visible_Refinement
(Enc_State
) then
26561 Present_Then_Remove
(Repeat_Items
, Enc_State
);
26564 if Global_Mode
= Name_Input
then
26565 Append_New_Elmt
(Item_Id
, In_Constits
);
26567 elsif Global_Mode
= Name_In_Out
then
26568 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
26570 elsif Global_Mode
= Name_Output
then
26571 Append_New_Elmt
(Item_Id
, Out_Constits
);
26573 elsif Global_Mode
= Name_Proof_In
then
26574 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
26577 -- When not a constituent, ensure that both occurrences of the
26578 -- item in pragmas Global and Refined_Global match. Also remove
26579 -- it when present from the list of items that should be repeated
26580 -- from pragma Global.
26583 Present_Then_Remove
(Repeat_Items
, Item_Id
);
26585 if Contains
(In_Items
, Item_Id
) then
26586 if Global_Mode
/= Name_Input
then
26587 Inconsistent_Mode_Error
(Name_Input
);
26590 elsif Contains
(In_Out_Items
, Item_Id
) then
26591 if Global_Mode
/= Name_In_Out
then
26592 Inconsistent_Mode_Error
(Name_In_Out
);
26595 elsif Contains
(Out_Items
, Item_Id
) then
26596 if Global_Mode
/= Name_Output
then
26597 Inconsistent_Mode_Error
(Name_Output
);
26600 elsif Contains
(Proof_In_Items
, Item_Id
) then
26603 -- The item does not appear in the corresponding Global pragma,
26604 -- it must be an extra (SPARK RM 7.2.4(3)).
26607 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
26610 end Check_Refined_Global_Item
;
26616 -- Start of processing for Check_Refined_Global_List
26619 -- Do not perform this check in an instance because it was already
26620 -- performed successfully in the generic template.
26622 if Is_Generic_Instance
(Spec_Id
) then
26625 elsif Nkind
(List
) = N_Null
then
26628 -- Single global item declaration
26630 elsif Nkind_In
(List
, N_Expanded_Name
,
26632 N_Selected_Component
)
26634 Check_Refined_Global_Item
(List
, Global_Mode
);
26636 -- Simple global list or moded global list declaration
26638 elsif Nkind
(List
) = N_Aggregate
then
26640 -- The declaration of a simple global list appear as a collection
26643 if Present
(Expressions
(List
)) then
26644 Item
:= First
(Expressions
(List
));
26645 while Present
(Item
) loop
26646 Check_Refined_Global_Item
(Item
, Global_Mode
);
26650 -- The declaration of a moded global list appears as a collection
26651 -- of component associations where individual choices denote
26654 elsif Present
(Component_Associations
(List
)) then
26655 Item
:= First
(Component_Associations
(List
));
26656 while Present
(Item
) loop
26657 Check_Refined_Global_List
26658 (List
=> Expression
(Item
),
26659 Global_Mode
=> Chars
(First
(Choices
(Item
))));
26667 raise Program_Error
;
26673 raise Program_Error
;
26675 end Check_Refined_Global_List
;
26677 --------------------------
26678 -- Collect_Global_Items --
26679 --------------------------
26681 procedure Collect_Global_Items
26683 Mode
: Name_Id
:= Name_Input
)
26685 procedure Collect_Global_Item
26687 Item_Mode
: Name_Id
);
26688 -- Add a single item to the appropriate list. Item_Mode denotes the
26689 -- current mode in effect.
26691 -------------------------
26692 -- Collect_Global_Item --
26693 -------------------------
26695 procedure Collect_Global_Item
26697 Item_Mode
: Name_Id
)
26699 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
26700 -- The above handles abstract views of variables and states built
26701 -- for limited with clauses.
26704 -- Signal that the global list contains at least one abstract
26705 -- state with a visible refinement. Note that the refinement may
26706 -- be null in which case there are no constituents.
26708 if Ekind
(Item_Id
) = E_Abstract_State
then
26709 if Has_Null_Visible_Refinement
(Item_Id
) then
26710 Has_Null_State
:= True;
26712 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26713 Append_New_Elmt
(Item_Id
, States
);
26715 if Item_Mode
= Name_Input
then
26716 Has_In_State
:= True;
26717 elsif Item_Mode
= Name_In_Out
then
26718 Has_In_Out_State
:= True;
26719 elsif Item_Mode
= Name_Output
then
26720 Has_Out_State
:= True;
26721 elsif Item_Mode
= Name_Proof_In
then
26722 Has_Proof_In_State
:= True;
26727 -- Record global items without full visible refinement found in
26728 -- pragma Global which should be repeated in the global refinement
26729 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26731 if Ekind
(Item_Id
) /= E_Abstract_State
26732 or else not Has_Visible_Refinement
(Item_Id
)
26734 Append_New_Elmt
(Item_Id
, Repeat_Items
);
26737 -- Add the item to the proper list
26739 if Item_Mode
= Name_Input
then
26740 Append_New_Elmt
(Item_Id
, In_Items
);
26741 elsif Item_Mode
= Name_In_Out
then
26742 Append_New_Elmt
(Item_Id
, In_Out_Items
);
26743 elsif Item_Mode
= Name_Output
then
26744 Append_New_Elmt
(Item_Id
, Out_Items
);
26745 elsif Item_Mode
= Name_Proof_In
then
26746 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
26748 end Collect_Global_Item
;
26754 -- Start of processing for Collect_Global_Items
26757 if Nkind
(List
) = N_Null
then
26760 -- Single global item declaration
26762 elsif Nkind_In
(List
, N_Expanded_Name
,
26764 N_Selected_Component
)
26766 Collect_Global_Item
(List
, Mode
);
26768 -- Single global list or moded global list declaration
26770 elsif Nkind
(List
) = N_Aggregate
then
26772 -- The declaration of a simple global list appear as a collection
26775 if Present
(Expressions
(List
)) then
26776 Item
:= First
(Expressions
(List
));
26777 while Present
(Item
) loop
26778 Collect_Global_Item
(Item
, Mode
);
26782 -- The declaration of a moded global list appears as a collection
26783 -- of component associations where individual choices denote mode.
26785 elsif Present
(Component_Associations
(List
)) then
26786 Item
:= First
(Component_Associations
(List
));
26787 while Present
(Item
) loop
26788 Collect_Global_Items
26789 (List
=> Expression
(Item
),
26790 Mode
=> Chars
(First
(Choices
(Item
))));
26798 raise Program_Error
;
26801 -- To accommodate partial decoration of disabled SPARK features, this
26802 -- routine may be called with illegal input. If this is the case, do
26803 -- not raise Program_Error.
26808 end Collect_Global_Items
;
26810 -------------------------
26811 -- Present_Then_Remove --
26812 -------------------------
26814 function Present_Then_Remove
26816 Item
: Entity_Id
) return Boolean
26821 if Present
(List
) then
26822 Elmt
:= First_Elmt
(List
);
26823 while Present
(Elmt
) loop
26824 if Node
(Elmt
) = Item
then
26825 Remove_Elmt
(List
, Elmt
);
26834 end Present_Then_Remove
;
26836 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
26839 Ignore
:= Present_Then_Remove
(List
, Item
);
26840 end Present_Then_Remove
;
26842 -------------------------------
26843 -- Report_Extra_Constituents --
26844 -------------------------------
26846 procedure Report_Extra_Constituents
is
26847 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
26848 -- Emit an error for every element of List
26850 ---------------------------------------
26851 -- Report_Extra_Constituents_In_List --
26852 ---------------------------------------
26854 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
26855 Constit_Elmt
: Elmt_Id
;
26858 if Present
(List
) then
26859 Constit_Elmt
:= First_Elmt
(List
);
26860 while Present
(Constit_Elmt
) loop
26861 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
26862 Next_Elmt
(Constit_Elmt
);
26865 end Report_Extra_Constituents_In_List
;
26867 -- Start of processing for Report_Extra_Constituents
26870 -- Do not perform this check in an instance because it was already
26871 -- performed successfully in the generic template.
26873 if Is_Generic_Instance
(Spec_Id
) then
26877 Report_Extra_Constituents_In_List
(In_Constits
);
26878 Report_Extra_Constituents_In_List
(In_Out_Constits
);
26879 Report_Extra_Constituents_In_List
(Out_Constits
);
26880 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
26882 end Report_Extra_Constituents
;
26884 --------------------------
26885 -- Report_Missing_Items --
26886 --------------------------
26888 procedure Report_Missing_Items
is
26889 Item_Elmt
: Elmt_Id
;
26890 Item_Id
: Entity_Id
;
26893 -- Do not perform this check in an instance because it was already
26894 -- performed successfully in the generic template.
26896 if Is_Generic_Instance
(Spec_Id
) then
26900 if Present
(Repeat_Items
) then
26901 Item_Elmt
:= First_Elmt
(Repeat_Items
);
26902 while Present
(Item_Elmt
) loop
26903 Item_Id
:= Node
(Item_Elmt
);
26904 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
26905 Next_Elmt
(Item_Elmt
);
26909 end Report_Missing_Items
;
26913 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26914 Errors
: constant Nat
:= Serious_Errors_Detected
;
26916 No_Constit
: Boolean;
26918 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26921 -- Do not analyze the pragma multiple times
26923 if Is_Analyzed_Pragma
(N
) then
26927 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26929 -- Use the anonymous object as the proper spec when Refined_Global
26930 -- applies to the body of a single task type. The object carries the
26931 -- proper Chars as well as all non-refined versions of pragmas.
26933 if Is_Single_Concurrent_Type
(Spec_Id
) then
26934 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26937 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
26938 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
26940 -- The subprogram declaration lacks pragma Global. This renders
26941 -- Refined_Global useless as there is nothing to refine.
26943 if No
(Global
) then
26945 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26946 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
26950 -- Extract all relevant items from the corresponding Global pragma
26952 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26954 -- Package and subprogram bodies are instantiated individually in
26955 -- a separate compiler pass. Due to this mode of instantiation, the
26956 -- refinement of a state may no longer be visible when a subprogram
26957 -- body contract is instantiated. Since the generic template is legal,
26958 -- do not perform this check in the instance to circumvent this oddity.
26960 if Is_Generic_Instance
(Spec_Id
) then
26963 -- Non-instance case
26966 -- The corresponding Global pragma must mention at least one
26967 -- state with a visible refinement at the point Refined_Global
26968 -- is processed. States with null refinements need Refined_Global
26969 -- pragma (SPARK RM 7.2.4(2)).
26971 if not Has_In_State
26972 and then not Has_In_Out_State
26973 and then not Has_Out_State
26974 and then not Has_Proof_In_State
26975 and then not Has_Null_State
26978 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26979 & "depend on abstract state with visible refinement"),
26983 -- The global refinement of inputs and outputs cannot be null when
26984 -- the corresponding Global pragma contains at least one item except
26985 -- in the case where we have states with null refinements.
26987 elsif Nkind
(Items
) = N_Null
26989 (Present
(In_Items
)
26990 or else Present
(In_Out_Items
)
26991 or else Present
(Out_Items
)
26992 or else Present
(Proof_In_Items
))
26993 and then not Has_Null_State
26996 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
26997 & "global items"), N
, Spec_Id
);
27002 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
27003 -- This ensures that the categorization of all refined global items is
27004 -- consistent with their role.
27006 Analyze_Global_In_Decl_Part
(N
);
27008 -- Perform all refinement checks with respect to completeness and mode
27011 if Serious_Errors_Detected
= Errors
then
27012 Check_Refined_Global_List
(Items
);
27015 -- Store the information that no constituent is used in the global
27016 -- refinement, prior to calling checking procedures which remove items
27017 -- from the list of constituents.
27021 and then No
(In_Out_Constits
)
27022 and then No
(Out_Constits
)
27023 and then No
(Proof_In_Constits
);
27025 -- For Input states with visible refinement, at least one constituent
27026 -- must be used as an Input in the global refinement.
27028 if Serious_Errors_Detected
= Errors
then
27029 Check_Input_States
;
27032 -- Verify all possible completion variants for In_Out states with
27033 -- visible refinement.
27035 if Serious_Errors_Detected
= Errors
then
27036 Check_In_Out_States
;
27039 -- For Output states with visible refinement, all constituents must be
27040 -- used as Outputs in the global refinement.
27042 if Serious_Errors_Detected
= Errors
then
27043 Check_Output_States
;
27046 -- For Proof_In states with visible refinement, at least one constituent
27047 -- must be used as Proof_In in the global refinement.
27049 if Serious_Errors_Detected
= Errors
then
27050 Check_Proof_In_States
;
27053 -- Emit errors for all constituents that belong to other states with
27054 -- visible refinement that do not appear in Global.
27056 if Serious_Errors_Detected
= Errors
then
27057 Report_Extra_Constituents
;
27060 -- Emit errors for all items in Global that are not repeated in the
27061 -- global refinement and for which there is no full visible refinement
27062 -- and, in the case of states with partial visible refinement, no
27063 -- constituent is mentioned in the global refinement.
27065 if Serious_Errors_Detected
= Errors
then
27066 Report_Missing_Items
;
27069 -- Emit an error if no constituent is used in the global refinement
27070 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
27071 -- one may be issued by the checking procedures. Do not perform this
27072 -- check in an instance because it was already performed successfully
27073 -- in the generic template.
27075 if Serious_Errors_Detected
= Errors
27076 and then not Is_Generic_Instance
(Spec_Id
)
27077 and then not Has_Null_State
27078 and then No_Constit
27080 SPARK_Msg_N
("missing refinement", N
);
27084 Set_Is_Analyzed_Pragma
(N
);
27085 end Analyze_Refined_Global_In_Decl_Part
;
27087 ----------------------------------------
27088 -- Analyze_Refined_State_In_Decl_Part --
27089 ----------------------------------------
27091 procedure Analyze_Refined_State_In_Decl_Part
27093 Freeze_Id
: Entity_Id
:= Empty
)
27095 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
27096 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
27097 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
27099 Available_States
: Elist_Id
:= No_Elist
;
27100 -- A list of all abstract states defined in the package declaration that
27101 -- are available for refinement. The list is used to report unrefined
27104 Body_States
: Elist_Id
:= No_Elist
;
27105 -- A list of all hidden states that appear in the body of the related
27106 -- package. The list is used to report unused hidden states.
27108 Constituents_Seen
: Elist_Id
:= No_Elist
;
27109 -- A list that contains all constituents processed so far. The list is
27110 -- used to detect multiple uses of the same constituent.
27112 Freeze_Posted
: Boolean := False;
27113 -- A flag that controls the output of a freezing-related error (see use
27116 Refined_States_Seen
: Elist_Id
:= No_Elist
;
27117 -- A list that contains all refined states processed so far. The list is
27118 -- used to detect duplicate refinements.
27120 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
27121 -- Perform full analysis of a single refinement clause
27123 procedure Report_Unrefined_States
(States
: Elist_Id
);
27124 -- Emit errors for all unrefined abstract states found in list States
27126 -------------------------------
27127 -- Analyze_Refinement_Clause --
27128 -------------------------------
27130 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
27131 AR_Constit
: Entity_Id
:= Empty
;
27132 AW_Constit
: Entity_Id
:= Empty
;
27133 ER_Constit
: Entity_Id
:= Empty
;
27134 EW_Constit
: Entity_Id
:= Empty
;
27135 -- The entities of external constituents that contain one of the
27136 -- following enabled properties: Async_Readers, Async_Writers,
27137 -- Effective_Reads and Effective_Writes.
27139 External_Constit_Seen
: Boolean := False;
27140 -- Flag used to mark when at least one external constituent is part
27141 -- of the state refinement.
27143 Non_Null_Seen
: Boolean := False;
27144 Null_Seen
: Boolean := False;
27145 -- Flags used to detect multiple uses of null in a single clause or a
27146 -- mixture of null and non-null constituents.
27148 Part_Of_Constits
: Elist_Id
:= No_Elist
;
27149 -- A list of all candidate constituents subject to indicator Part_Of
27150 -- where the encapsulating state is the current state.
27153 State_Id
: Entity_Id
;
27154 -- The current state being refined
27156 procedure Analyze_Constituent
(Constit
: Node_Id
);
27157 -- Perform full analysis of a single constituent
27159 procedure Check_External_Property
27160 (Prop_Nam
: Name_Id
;
27162 Constit
: Entity_Id
);
27163 -- Determine whether a property denoted by name Prop_Nam is present
27164 -- in the refined state. Emit an error if this is not the case. Flag
27165 -- Enabled should be set when the property applies to the refined
27166 -- state. Constit denotes the constituent (if any) which introduces
27167 -- the property in the refinement.
27169 procedure Match_State
;
27170 -- Determine whether the state being refined appears in list
27171 -- Available_States. Emit an error when attempting to re-refine the
27172 -- state or when the state is not defined in the package declaration,
27173 -- otherwise remove the state from Available_States.
27175 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
27176 -- Emit errors for all unused Part_Of constituents in list Constits
27178 -------------------------
27179 -- Analyze_Constituent --
27180 -------------------------
27182 procedure Analyze_Constituent
(Constit
: Node_Id
) is
27183 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
27184 -- Determine whether constituent Constit denoted by its entity
27185 -- Constit_Id appears in Body_States. Emit an error when the
27186 -- constituent is not a valid hidden state of the related package
27187 -- or when it is used more than once. Otherwise remove the
27188 -- constituent from Body_States.
27190 -----------------------
27191 -- Match_Constituent --
27192 -----------------------
27194 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
27195 procedure Collect_Constituent
;
27196 -- Verify the legality of constituent Constit_Id and add it to
27197 -- the refinements of State_Id.
27199 -------------------------
27200 -- Collect_Constituent --
27201 -------------------------
27203 procedure Collect_Constituent
is
27204 Constits
: Elist_Id
;
27207 -- The Ghost policy in effect at the point of abstract state
27208 -- declaration and constituent must match (SPARK RM 6.9(15))
27210 Check_Ghost_Refinement
27211 (State
, State_Id
, Constit
, Constit_Id
);
27213 -- A synchronized state must be refined by a synchronized
27214 -- object or another synchronized state (SPARK RM 9.6).
27216 if Is_Synchronized_State
(State_Id
)
27217 and then not Is_Synchronized_Object
(Constit_Id
)
27218 and then not Is_Synchronized_State
(Constit_Id
)
27221 ("constituent of synchronized state & must be "
27222 & "synchronized", Constit
, State_Id
);
27225 -- Add the constituent to the list of processed items to aid
27226 -- with the detection of duplicates.
27228 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
27230 -- Collect the constituent in the list of refinement items
27231 -- and establish a relation between the refined state and
27234 Constits
:= Refinement_Constituents
(State_Id
);
27236 if No
(Constits
) then
27237 Constits
:= New_Elmt_List
;
27238 Set_Refinement_Constituents
(State_Id
, Constits
);
27241 Append_Elmt
(Constit_Id
, Constits
);
27242 Set_Encapsulating_State
(Constit_Id
, State_Id
);
27244 -- The state has at least one legal constituent, mark the
27245 -- start of the refinement region. The region ends when the
27246 -- body declarations end (see routine Analyze_Declarations).
27248 Set_Has_Visible_Refinement
(State_Id
);
27250 -- When the constituent is external, save its relevant
27251 -- property for further checks.
27253 if Async_Readers_Enabled
(Constit_Id
) then
27254 AR_Constit
:= Constit_Id
;
27255 External_Constit_Seen
:= True;
27258 if Async_Writers_Enabled
(Constit_Id
) then
27259 AW_Constit
:= Constit_Id
;
27260 External_Constit_Seen
:= True;
27263 if Effective_Reads_Enabled
(Constit_Id
) then
27264 ER_Constit
:= Constit_Id
;
27265 External_Constit_Seen
:= True;
27268 if Effective_Writes_Enabled
(Constit_Id
) then
27269 EW_Constit
:= Constit_Id
;
27270 External_Constit_Seen
:= True;
27272 end Collect_Constituent
;
27276 State_Elmt
: Elmt_Id
;
27278 -- Start of processing for Match_Constituent
27281 -- Detect a duplicate use of a constituent
27283 if Contains
(Constituents_Seen
, Constit_Id
) then
27285 ("duplicate use of constituent &", Constit
, Constit_Id
);
27289 -- The constituent is subject to a Part_Of indicator
27291 if Present
(Encapsulating_State
(Constit_Id
)) then
27292 if Encapsulating_State
(Constit_Id
) = State_Id
then
27293 Remove
(Part_Of_Constits
, Constit_Id
);
27294 Collect_Constituent
;
27296 -- The constituent is part of another state and is used
27297 -- incorrectly in the refinement of the current state.
27300 Error_Msg_Name_1
:= Chars
(State_Id
);
27302 ("& cannot act as constituent of state %",
27303 Constit
, Constit_Id
);
27305 ("\Part_Of indicator specifies encapsulator &",
27306 Constit
, Encapsulating_State
(Constit_Id
));
27309 -- The only other source of legal constituents is the body
27310 -- state space of the related package.
27313 if Present
(Body_States
) then
27314 State_Elmt
:= First_Elmt
(Body_States
);
27315 while Present
(State_Elmt
) loop
27317 -- Consume a valid constituent to signal that it has
27318 -- been encountered.
27320 if Node
(State_Elmt
) = Constit_Id
then
27321 Remove_Elmt
(Body_States
, State_Elmt
);
27322 Collect_Constituent
;
27326 Next_Elmt
(State_Elmt
);
27330 -- Constants are part of the hidden state of a package, but
27331 -- the compiler cannot determine whether they have variable
27332 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
27333 -- hidden state. Accept the constant quietly even if it is
27334 -- a visible state or lacks a Part_Of indicator.
27336 if Ekind
(Constit_Id
) = E_Constant
then
27337 Collect_Constituent
;
27339 -- If we get here, then the constituent is not a hidden
27340 -- state of the related package and may not be used in a
27341 -- refinement (SPARK RM 7.2.2(9)).
27344 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27346 ("cannot use & in refinement, constituent is not a "
27347 & "hidden state of package %", Constit
, Constit_Id
);
27350 end Match_Constituent
;
27354 Constit_Id
: Entity_Id
;
27355 Constits
: Elist_Id
;
27357 -- Start of processing for Analyze_Constituent
27360 -- Detect multiple uses of null in a single refinement clause or a
27361 -- mixture of null and non-null constituents.
27363 if Nkind
(Constit
) = N_Null
then
27366 ("multiple null constituents not allowed", Constit
);
27368 elsif Non_Null_Seen
then
27370 ("cannot mix null and non-null constituents", Constit
);
27375 -- Collect the constituent in the list of refinement items
27377 Constits
:= Refinement_Constituents
(State_Id
);
27379 if No
(Constits
) then
27380 Constits
:= New_Elmt_List
;
27381 Set_Refinement_Constituents
(State_Id
, Constits
);
27384 Append_Elmt
(Constit
, Constits
);
27386 -- The state has at least one legal constituent, mark the
27387 -- start of the refinement region. The region ends when the
27388 -- body declarations end (see Analyze_Declarations).
27390 Set_Has_Visible_Refinement
(State_Id
);
27393 -- Non-null constituents
27396 Non_Null_Seen
:= True;
27400 ("cannot mix null and non-null constituents", Constit
);
27404 Resolve_State
(Constit
);
27406 -- Ensure that the constituent denotes a valid state or a
27407 -- whole object (SPARK RM 7.2.2(5)).
27409 if Is_Entity_Name
(Constit
) then
27410 Constit_Id
:= Entity_Of
(Constit
);
27412 -- When a constituent is declared after a subprogram body
27413 -- that caused freezing of the related contract where
27414 -- pragma Refined_State resides, the constituent appears
27415 -- undefined and carries Any_Id as its entity.
27417 -- package body Pack
27418 -- with Refined_State => (State => Constit)
27421 -- with Refined_Global => (Input => Constit)
27429 if Constit_Id
= Any_Id
then
27430 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
27432 -- Emit a specialized info message when the contract of
27433 -- the related package body was "frozen" by another body.
27434 -- Note that it is not possible to precisely identify why
27435 -- the constituent is undefined because it is not visible
27436 -- when pragma Refined_State is analyzed. This message is
27437 -- a reasonable approximation.
27439 if Present
(Freeze_Id
) and then not Freeze_Posted
then
27440 Freeze_Posted
:= True;
27442 Error_Msg_Name_1
:= Chars
(Body_Id
);
27443 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27445 ("body & declared # freezes the contract of %",
27448 ("\all constituents must be declared before body #",
27451 -- A misplaced constituent is a critical error because
27452 -- pragma Refined_Depends or Refined_Global depends on
27453 -- the proper link between a state and a constituent.
27454 -- Stop the compilation, as this leads to a multitude
27455 -- of misleading cascaded errors.
27457 raise Unrecoverable_Error
;
27460 -- The constituent is a valid state or object
27462 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
27466 Match_Constituent
(Constit_Id
);
27468 -- The variable may eventually become a constituent of a
27469 -- single protected/task type. Record the reference now
27470 -- and verify its legality when analyzing the contract of
27471 -- the variable (SPARK RM 9.3).
27473 if Ekind
(Constit_Id
) = E_Variable
then
27474 Record_Possible_Part_Of_Reference
27475 (Var_Id
=> Constit_Id
,
27479 -- Otherwise the constituent is illegal
27483 ("constituent & must denote object or state",
27484 Constit
, Constit_Id
);
27487 -- The constituent is illegal
27490 SPARK_Msg_N
("malformed constituent", Constit
);
27493 end Analyze_Constituent
;
27495 -----------------------------
27496 -- Check_External_Property --
27497 -----------------------------
27499 procedure Check_External_Property
27500 (Prop_Nam
: Name_Id
;
27502 Constit
: Entity_Id
)
27505 -- The property is missing in the declaration of the state, but
27506 -- a constituent is introducing it in the state refinement
27507 -- (SPARK RM 7.2.8(2)).
27509 if not Enabled
and then Present
(Constit
) then
27510 Error_Msg_Name_1
:= Prop_Nam
;
27511 Error_Msg_Name_2
:= Chars
(State_Id
);
27513 ("constituent & introduces external property % in refinement "
27514 & "of state %", State
, Constit
);
27516 Error_Msg_Sloc
:= Sloc
(State_Id
);
27518 ("\property is missing in abstract state declaration #",
27521 end Check_External_Property
;
27527 procedure Match_State
is
27528 State_Elmt
: Elmt_Id
;
27531 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
27533 if Contains
(Refined_States_Seen
, State_Id
) then
27535 ("duplicate refinement of state &", State
, State_Id
);
27539 -- Inspect the abstract states defined in the package declaration
27540 -- looking for a match.
27542 State_Elmt
:= First_Elmt
(Available_States
);
27543 while Present
(State_Elmt
) loop
27545 -- A valid abstract state is being refined in the body. Add
27546 -- the state to the list of processed refined states to aid
27547 -- with the detection of duplicate refinements. Remove the
27548 -- state from Available_States to signal that it has already
27551 if Node
(State_Elmt
) = State_Id
then
27552 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
27553 Remove_Elmt
(Available_States
, State_Elmt
);
27557 Next_Elmt
(State_Elmt
);
27560 -- If we get here, we are refining a state that is not defined in
27561 -- the package declaration.
27563 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27565 ("cannot refine state, & is not defined in package %",
27569 --------------------------------
27570 -- Report_Unused_Constituents --
27571 --------------------------------
27573 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
27574 Constit_Elmt
: Elmt_Id
;
27575 Constit_Id
: Entity_Id
;
27576 Posted
: Boolean := False;
27579 if Present
(Constits
) then
27580 Constit_Elmt
:= First_Elmt
(Constits
);
27581 while Present
(Constit_Elmt
) loop
27582 Constit_Id
:= Node
(Constit_Elmt
);
27584 -- Generate an error message of the form:
27586 -- state ... has unused Part_Of constituents
27587 -- abstract state ... defined at ...
27588 -- constant ... defined at ...
27589 -- variable ... defined at ...
27594 ("state & has unused Part_Of constituents",
27598 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
27600 if Ekind
(Constit_Id
) = E_Abstract_State
then
27602 ("\abstract state & defined #", State
, Constit_Id
);
27604 elsif Ekind
(Constit_Id
) = E_Constant
then
27606 ("\constant & defined #", State
, Constit_Id
);
27609 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
27610 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
27613 Next_Elmt
(Constit_Elmt
);
27616 end Report_Unused_Constituents
;
27618 -- Local declarations
27620 Body_Ref
: Node_Id
;
27621 Body_Ref_Elmt
: Elmt_Id
;
27623 Extra_State
: Node_Id
;
27625 -- Start of processing for Analyze_Refinement_Clause
27628 -- A refinement clause appears as a component association where the
27629 -- sole choice is the state and the expressions are the constituents.
27630 -- This is a syntax error, always report.
27632 if Nkind
(Clause
) /= N_Component_Association
then
27633 Error_Msg_N
("malformed state refinement clause", Clause
);
27637 -- Analyze the state name of a refinement clause
27639 State
:= First
(Choices
(Clause
));
27642 Resolve_State
(State
);
27644 -- Ensure that the state name denotes a valid abstract state that is
27645 -- defined in the spec of the related package.
27647 if Is_Entity_Name
(State
) then
27648 State_Id
:= Entity_Of
(State
);
27650 -- When the abstract state is undefined, it appears as Any_Id. Do
27651 -- not continue with the analysis of the clause.
27653 if State_Id
= Any_Id
then
27656 -- Catch any attempts to re-refine a state or refine a state that
27657 -- is not defined in the package declaration.
27659 elsif Ekind
(State_Id
) = E_Abstract_State
then
27663 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
27667 -- References to a state with visible refinement are illegal.
27668 -- When nested packages are involved, detecting such references is
27669 -- tricky because pragma Refined_State is analyzed later than the
27670 -- offending pragma Depends or Global. References that occur in
27671 -- such nested context are stored in a list. Emit errors for all
27672 -- references found in Body_References (SPARK RM 6.1.4(8)).
27674 if Present
(Body_References
(State_Id
)) then
27675 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
27676 while Present
(Body_Ref_Elmt
) loop
27677 Body_Ref
:= Node
(Body_Ref_Elmt
);
27679 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
27680 Error_Msg_Sloc
:= Sloc
(State
);
27681 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
27683 Next_Elmt
(Body_Ref_Elmt
);
27687 -- The state name is illegal. This is a syntax error, always report.
27690 Error_Msg_N
("malformed state name in refinement clause", State
);
27694 -- A refinement clause may only refine one state at a time
27696 Extra_State
:= Next
(State
);
27698 if Present
(Extra_State
) then
27700 ("refinement clause cannot cover multiple states", Extra_State
);
27703 -- Replicate the Part_Of constituents of the refined state because
27704 -- the algorithm will consume items.
27706 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
27708 -- Analyze all constituents of the refinement. Multiple constituents
27709 -- appear as an aggregate.
27711 Constit
:= Expression
(Clause
);
27713 if Nkind
(Constit
) = N_Aggregate
then
27714 if Present
(Component_Associations
(Constit
)) then
27716 ("constituents of refinement clause must appear in "
27717 & "positional form", Constit
);
27719 else pragma Assert
(Present
(Expressions
(Constit
)));
27720 Constit
:= First
(Expressions
(Constit
));
27721 while Present
(Constit
) loop
27722 Analyze_Constituent
(Constit
);
27727 -- Various forms of a single constituent. Note that these may include
27728 -- malformed constituents.
27731 Analyze_Constituent
(Constit
);
27734 -- Verify that external constituents do not introduce new external
27735 -- property in the state refinement (SPARK RM 7.2.8(2)).
27737 if Is_External_State
(State_Id
) then
27738 Check_External_Property
27739 (Prop_Nam
=> Name_Async_Readers
,
27740 Enabled
=> Async_Readers_Enabled
(State_Id
),
27741 Constit
=> AR_Constit
);
27743 Check_External_Property
27744 (Prop_Nam
=> Name_Async_Writers
,
27745 Enabled
=> Async_Writers_Enabled
(State_Id
),
27746 Constit
=> AW_Constit
);
27748 Check_External_Property
27749 (Prop_Nam
=> Name_Effective_Reads
,
27750 Enabled
=> Effective_Reads_Enabled
(State_Id
),
27751 Constit
=> ER_Constit
);
27753 Check_External_Property
27754 (Prop_Nam
=> Name_Effective_Writes
,
27755 Enabled
=> Effective_Writes_Enabled
(State_Id
),
27756 Constit
=> EW_Constit
);
27758 -- When a refined state is not external, it should not have external
27759 -- constituents (SPARK RM 7.2.8(1)).
27761 elsif External_Constit_Seen
then
27763 ("non-external state & cannot contain external constituents in "
27764 & "refinement", State
, State_Id
);
27767 -- Ensure that all Part_Of candidate constituents have been mentioned
27768 -- in the refinement clause.
27770 Report_Unused_Constituents
(Part_Of_Constits
);
27771 end Analyze_Refinement_Clause
;
27773 -----------------------------
27774 -- Report_Unrefined_States --
27775 -----------------------------
27777 procedure Report_Unrefined_States
(States
: Elist_Id
) is
27778 State_Elmt
: Elmt_Id
;
27781 if Present
(States
) then
27782 State_Elmt
:= First_Elmt
(States
);
27783 while Present
(State_Elmt
) loop
27785 ("abstract state & must be refined", Node
(State_Elmt
));
27787 Next_Elmt
(State_Elmt
);
27790 end Report_Unrefined_States
;
27792 -- Local declarations
27794 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
27797 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27800 -- Do not analyze the pragma multiple times
27802 if Is_Analyzed_Pragma
(N
) then
27806 -- Save the scenario for examination by the ABE Processing phase
27808 Record_Elaboration_Scenario
(N
);
27810 -- Replicate the abstract states declared by the package because the
27811 -- matching algorithm will consume states.
27813 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
27815 -- Gather all abstract states and objects declared in the visible
27816 -- state space of the package body. These items must be utilized as
27817 -- constituents in a state refinement.
27819 Body_States
:= Collect_Body_States
(Body_Id
);
27821 -- Multiple non-null state refinements appear as an aggregate
27823 if Nkind
(Clauses
) = N_Aggregate
then
27824 if Present
(Expressions
(Clauses
)) then
27826 ("state refinements must appear as component associations",
27829 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
27830 Clause
:= First
(Component_Associations
(Clauses
));
27831 while Present
(Clause
) loop
27832 Analyze_Refinement_Clause
(Clause
);
27837 -- Various forms of a single state refinement. Note that these may
27838 -- include malformed refinements.
27841 Analyze_Refinement_Clause
(Clauses
);
27844 -- List all abstract states that were left unrefined
27846 Report_Unrefined_States
(Available_States
);
27848 Set_Is_Analyzed_Pragma
(N
);
27849 end Analyze_Refined_State_In_Decl_Part
;
27851 ------------------------------------
27852 -- Analyze_Test_Case_In_Decl_Part --
27853 ------------------------------------
27855 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
27856 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27857 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27859 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
27860 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27861 -- denoted by Arg_Nam.
27863 ------------------------------
27864 -- Preanalyze_Test_Case_Arg --
27865 ------------------------------
27867 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
27871 -- Preanalyze the original aspect argument for ASIS or for a generic
27872 -- subprogram to properly capture global references.
27874 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
27878 Arg_Nam
=> Arg_Nam
,
27879 From_Aspect
=> True);
27881 if Present
(Arg
) then
27882 Preanalyze_Assert_Expression
27883 (Expression
(Arg
), Standard_Boolean
);
27887 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
27889 if Present
(Arg
) then
27890 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
27892 end Preanalyze_Test_Case_Arg
;
27896 Restore_Scope
: Boolean := False;
27898 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27901 -- Do not analyze the pragma multiple times
27903 if Is_Analyzed_Pragma
(N
) then
27907 -- Ensure that the formal parameters are visible when analyzing all
27908 -- clauses. This falls out of the general rule of aspects pertaining
27909 -- to subprogram declarations.
27911 if not In_Open_Scopes
(Spec_Id
) then
27912 Restore_Scope
:= True;
27913 Push_Scope
(Spec_Id
);
27915 if Is_Generic_Subprogram
(Spec_Id
) then
27916 Install_Generic_Formals
(Spec_Id
);
27918 Install_Formals
(Spec_Id
);
27922 Preanalyze_Test_Case_Arg
(Name_Requires
);
27923 Preanalyze_Test_Case_Arg
(Name_Ensures
);
27925 if Restore_Scope
then
27929 -- Currently it is not possible to inline pre/postconditions on a
27930 -- subprogram subject to pragma Inline_Always.
27932 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
27934 Set_Is_Analyzed_Pragma
(N
);
27935 end Analyze_Test_Case_In_Decl_Part
;
27941 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
27946 if Present
(List
) then
27947 Elmt
:= First_Elmt
(List
);
27948 while Present
(Elmt
) loop
27949 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
27952 Id
:= Entity_Of
(Node
(Elmt
));
27955 if Id
= Item_Id
then
27966 -----------------------------------
27967 -- Build_Pragma_Check_Equivalent --
27968 -----------------------------------
27970 function Build_Pragma_Check_Equivalent
27972 Subp_Id
: Entity_Id
:= Empty
;
27973 Inher_Id
: Entity_Id
:= Empty
;
27974 Keep_Pragma_Id
: Boolean := False) return Node_Id
27976 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
27977 -- Detect whether node N references a formal parameter subject to
27978 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27979 -- to False to suppress the generation of a reference when analyzing
27982 ------------------------
27983 -- Suppress_Reference --
27984 ------------------------
27986 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
27987 Formal
: Entity_Id
;
27990 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27991 Formal
:= Entity
(N
);
27993 -- The formal parameter is subject to pragma Unreferenced. Prevent
27994 -- the generation of references by resetting the Comes_From_Source
27997 if Is_Formal
(Formal
)
27998 and then Has_Pragma_Unreferenced
(Formal
)
28000 Set_Comes_From_Source
(N
, False);
28005 end Suppress_Reference
;
28007 procedure Suppress_References
is
28008 new Traverse_Proc
(Suppress_Reference
);
28012 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
28013 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28014 Check_Prag
: Node_Id
;
28018 Needs_Wrapper
: Boolean;
28019 pragma Unreferenced
(Needs_Wrapper
);
28021 -- Start of processing for Build_Pragma_Check_Equivalent
28024 -- When the pre- or postcondition is inherited, map the formals of the
28025 -- inherited subprogram to those of the current subprogram. In addition,
28026 -- map primitive operations of the parent type into the corresponding
28027 -- primitive operations of the descendant.
28029 if Present
(Inher_Id
) then
28030 pragma Assert
(Present
(Subp_Id
));
28032 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
28034 -- Use generic machinery to copy inherited pragma, as if it were an
28035 -- instantiation, resetting source locations appropriately, so that
28036 -- expressions inside the inherited pragma use chained locations.
28037 -- This is used in particular in GNATprove to locate precisely
28038 -- messages on a given inherited pragma.
28040 Set_Copied_Sloc_For_Inherited_Pragma
28041 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
28042 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28044 -- Build the inherited class-wide condition
28046 Build_Class_Wide_Expression
28047 (Prag
=> Check_Prag
,
28049 Par_Subp
=> Inher_Id
,
28050 Adjust_Sloc
=> True,
28051 Needs_Wrapper
=> Needs_Wrapper
);
28053 -- If not an inherited condition simply copy the original pragma
28056 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28059 -- Mark the pragma as being internally generated and reset the Analyzed
28062 Set_Analyzed
(Check_Prag
, False);
28063 Set_Comes_From_Source
(Check_Prag
, False);
28065 -- The tree of the original pragma may contain references to the
28066 -- formal parameters of the related subprogram. At the same time
28067 -- the corresponding body may mark the formals as unreferenced:
28069 -- procedure Proc (Formal : ...)
28070 -- with Pre => Formal ...;
28072 -- procedure Proc (Formal : ...) is
28073 -- pragma Unreferenced (Formal);
28076 -- This creates problems because all pragma Check equivalents are
28077 -- analyzed at the end of the body declarations. Since all source
28078 -- references have already been accounted for, reset any references
28079 -- to such formals in the generated pragma Check equivalent.
28081 Suppress_References
(Check_Prag
);
28083 if Present
(Corresponding_Aspect
(Prag
)) then
28084 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
28089 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
28090 -- the copied pragma in the newly created pragma, convert the copy into
28091 -- pragma Check by correcting the name and adding a check_kind argument.
28093 if not Keep_Pragma_Id
then
28094 Set_Class_Present
(Check_Prag
, False);
28096 Set_Pragma_Identifier
28097 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
28099 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
28100 Make_Pragma_Argument_Association
(Loc
,
28101 Expression
=> Make_Identifier
(Loc
, Nam
)));
28104 -- Update the error message when the pragma is inherited
28106 if Present
(Inher_Id
) then
28107 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
28109 if Chars
(Msg_Arg
) = Name_Message
then
28110 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
28112 -- Insert "inherited" to improve the error message
28114 if Name_Buffer
(1 .. 8) = "failed p" then
28115 Insert_Str_In_Name_Buffer
("inherited ", 8);
28116 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
28122 end Build_Pragma_Check_Equivalent
;
28124 -----------------------------
28125 -- Check_Applicable_Policy --
28126 -----------------------------
28128 procedure Check_Applicable_Policy
(N
: Node_Id
) is
28132 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
28135 -- No effect if not valid assertion kind name
28137 if not Is_Valid_Assertion_Kind
(Ename
) then
28141 -- Loop through entries in check policy list
28143 PP
:= Opt
.Check_Policy_List
;
28144 while Present
(PP
) loop
28146 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28147 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28151 or else Pnm
= Name_Assertion
28152 or else (Pnm
= Name_Statement_Assertions
28153 and then Nam_In
(Ename
, Name_Assert
,
28154 Name_Assert_And_Cut
,
28156 Name_Loop_Invariant
,
28157 Name_Loop_Variant
))
28159 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
28165 Set_Is_Ignored
(N
, True);
28166 Set_Is_Checked
(N
, False);
28171 Set_Is_Checked
(N
, True);
28172 Set_Is_Ignored
(N
, False);
28174 when Name_Disable
=>
28175 Set_Is_Ignored
(N
, True);
28176 Set_Is_Checked
(N
, False);
28177 Set_Is_Disabled
(N
, True);
28179 -- That should be exhaustive, the null here is a defence
28180 -- against a malformed tree from previous errors.
28189 PP
:= Next_Pragma
(PP
);
28193 -- If there are no specific entries that matched, then we let the
28194 -- setting of assertions govern. Note that this provides the needed
28195 -- compatibility with the RM for the cases of assertion, invariant,
28196 -- precondition, predicate, and postcondition.
28198 if Assertions_Enabled
then
28199 Set_Is_Checked
(N
, True);
28200 Set_Is_Ignored
(N
, False);
28202 Set_Is_Checked
(N
, False);
28203 Set_Is_Ignored
(N
, True);
28205 end Check_Applicable_Policy
;
28207 -------------------------------
28208 -- Check_External_Properties --
28209 -------------------------------
28211 procedure Check_External_Properties
28219 -- All properties enabled
28221 if AR
and AW
and ER
and EW
then
28224 -- Async_Readers + Effective_Writes
28225 -- Async_Readers + Async_Writers + Effective_Writes
28227 elsif AR
and EW
and not ER
then
28230 -- Async_Writers + Effective_Reads
28231 -- Async_Readers + Async_Writers + Effective_Reads
28233 elsif AW
and ER
and not EW
then
28236 -- Async_Readers + Async_Writers
28238 elsif AR
and AW
and not ER
and not EW
then
28243 elsif AR
and not AW
and not ER
and not EW
then
28248 elsif AW
and not AR
and not ER
and not EW
then
28253 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
28256 end Check_External_Properties
;
28262 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
28266 -- Loop through entries in check policy list
28268 PP
:= Opt
.Check_Policy_List
;
28269 while Present
(PP
) loop
28271 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28272 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28276 or else (Pnm
= Name_Assertion
28277 and then Is_Valid_Assertion_Kind
(Nam
))
28278 or else (Pnm
= Name_Statement_Assertions
28279 and then Nam_In
(Nam
, Name_Assert
,
28280 Name_Assert_And_Cut
,
28282 Name_Loop_Invariant
,
28283 Name_Loop_Variant
))
28285 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
28294 return Name_Ignore
;
28296 when Name_Disable
=>
28297 return Name_Disable
;
28300 raise Program_Error
;
28304 PP
:= Next_Pragma
(PP
);
28309 -- If there are no specific entries that matched, then we let the
28310 -- setting of assertions govern. Note that this provides the needed
28311 -- compatibility with the RM for the cases of assertion, invariant,
28312 -- precondition, predicate, and postcondition.
28314 if Assertions_Enabled
then
28317 return Name_Ignore
;
28321 ---------------------------
28322 -- Check_Missing_Part_Of --
28323 ---------------------------
28325 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
28326 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
28327 -- Determine whether a package denoted by Pack_Id declares at least one
28330 -----------------------
28331 -- Has_Visible_State --
28332 -----------------------
28334 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
28335 Item_Id
: Entity_Id
;
28338 -- Traverse the entity chain of the package trying to find at least
28339 -- one visible abstract state, variable or a package [instantiation]
28340 -- that declares a visible state.
28342 Item_Id
:= First_Entity
(Pack_Id
);
28343 while Present
(Item_Id
)
28344 and then not In_Private_Part
(Item_Id
)
28346 -- Do not consider internally generated items
28348 if not Comes_From_Source
(Item_Id
) then
28351 -- A visible state has been found
28353 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
28356 -- Recursively peek into nested packages and instantiations
28358 elsif Ekind
(Item_Id
) = E_Package
28359 and then Has_Visible_State
(Item_Id
)
28364 Next_Entity
(Item_Id
);
28368 end Has_Visible_State
;
28372 Pack_Id
: Entity_Id
;
28373 Placement
: State_Space_Kind
;
28375 -- Start of processing for Check_Missing_Part_Of
28378 -- Do not consider abstract states, variables or package instantiations
28379 -- coming from an instance as those always inherit the Part_Of indicator
28380 -- of the instance itself.
28382 if In_Instance
then
28385 -- Do not consider internally generated entities as these can never
28386 -- have a Part_Of indicator.
28388 elsif not Comes_From_Source
(Item_Id
) then
28391 -- Perform these checks only when SPARK_Mode is enabled as they will
28392 -- interfere with standard Ada rules and produce false positives.
28394 elsif SPARK_Mode
/= On
then
28397 -- Do not consider constants, because the compiler cannot accurately
28398 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
28399 -- act as a hidden state of a package.
28401 elsif Ekind
(Item_Id
) = E_Constant
then
28405 -- Find where the abstract state, variable or package instantiation
28406 -- lives with respect to the state space.
28408 Find_Placement_In_State_Space
28409 (Item_Id
=> Item_Id
,
28410 Placement
=> Placement
,
28411 Pack_Id
=> Pack_Id
);
28413 -- Items that appear in a non-package construct (subprogram, block, etc)
28414 -- do not require a Part_Of indicator because they can never act as a
28417 if Placement
= Not_In_Package
then
28420 -- An item declared in the body state space of a package always act as a
28421 -- constituent and does not need explicit Part_Of indicator.
28423 elsif Placement
= Body_State_Space
then
28426 -- In general an item declared in the visible state space of a package
28427 -- does not require a Part_Of indicator. The only exception is when the
28428 -- related package is a private child unit in which case Part_Of must
28429 -- denote a state in the parent unit or in one of its descendants.
28431 elsif Placement
= Visible_State_Space
then
28432 if Is_Child_Unit
(Pack_Id
)
28433 and then Is_Private_Descendant
(Pack_Id
)
28435 -- A package instantiation does not need a Part_Of indicator when
28436 -- the related generic template has no visible state.
28438 if Ekind
(Item_Id
) = E_Package
28439 and then Is_Generic_Instance
(Item_Id
)
28440 and then not Has_Visible_State
(Item_Id
)
28444 -- All other cases require Part_Of
28448 ("indicator Part_Of is required in this context "
28449 & "(SPARK RM 7.2.6(3))", Item_Id
);
28450 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28452 ("\& is declared in the visible part of private child "
28453 & "unit %", Item_Id
);
28457 -- When the item appears in the private state space of a package, it
28458 -- must be a part of some state declared by the said package.
28460 else pragma Assert
(Placement
= Private_State_Space
);
28462 -- The related package does not declare a state, the item cannot act
28463 -- as a Part_Of constituent.
28465 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
28468 -- A package instantiation does not need a Part_Of indicator when the
28469 -- related generic template has no visible state.
28471 elsif Ekind
(Pack_Id
) = E_Package
28472 and then Is_Generic_Instance
(Pack_Id
)
28473 and then not Has_Visible_State
(Pack_Id
)
28477 -- All other cases require Part_Of
28481 ("indicator Part_Of is required in this context "
28482 & "(SPARK RM 7.2.6(2))", Item_Id
);
28483 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28485 ("\& is declared in the private part of package %", Item_Id
);
28488 end Check_Missing_Part_Of
;
28490 ---------------------------------------------------
28491 -- Check_Postcondition_Use_In_Inlined_Subprogram --
28492 ---------------------------------------------------
28494 procedure Check_Postcondition_Use_In_Inlined_Subprogram
28496 Spec_Id
: Entity_Id
)
28499 if Warn_On_Redundant_Constructs
28500 and then Has_Pragma_Inline_Always
(Spec_Id
)
28501 and then Assertions_Enabled
28503 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28505 if From_Aspect_Specification
(Prag
) then
28507 ("aspect % not enforced on inlined subprogram &?r?",
28508 Corresponding_Aspect
(Prag
), Spec_Id
);
28511 ("pragma % not enforced on inlined subprogram &?r?",
28515 end Check_Postcondition_Use_In_Inlined_Subprogram
;
28517 -------------------------------------
28518 -- Check_State_And_Constituent_Use --
28519 -------------------------------------
28521 procedure Check_State_And_Constituent_Use
28522 (States
: Elist_Id
;
28523 Constits
: Elist_Id
;
28526 Constit_Elmt
: Elmt_Id
;
28527 Constit_Id
: Entity_Id
;
28528 State_Id
: Entity_Id
;
28531 -- Nothing to do if there are no states or constituents
28533 if No
(States
) or else No
(Constits
) then
28537 -- Inspect the list of constituents and try to determine whether its
28538 -- encapsulating state is in list States.
28540 Constit_Elmt
:= First_Elmt
(Constits
);
28541 while Present
(Constit_Elmt
) loop
28542 Constit_Id
:= Node
(Constit_Elmt
);
28544 -- Determine whether the constituent is part of an encapsulating
28545 -- state that appears in the same context and if this is the case,
28546 -- emit an error (SPARK RM 7.2.6(7)).
28548 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
28550 if Present
(State_Id
) then
28551 Error_Msg_Name_1
:= Chars
(Constit_Id
);
28553 ("cannot mention state & and its constituent % in the same "
28554 & "context", Context
, State_Id
);
28558 Next_Elmt
(Constit_Elmt
);
28560 end Check_State_And_Constituent_Use
;
28562 ---------------------------------------------
28563 -- Collect_Inherited_Class_Wide_Conditions --
28564 ---------------------------------------------
28566 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
28567 Parent_Subp
: constant Entity_Id
:=
28568 Ultimate_Alias
(Overridden_Operation
(Subp
));
28569 -- The Overridden_Operation may itself be inherited and as such have no
28570 -- explicit contract.
28572 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
28573 In_Spec_Expr
: Boolean;
28574 Installed
: Boolean;
28576 New_Prag
: Node_Id
;
28579 Installed
:= False;
28581 -- Iterate over the contract of the overridden subprogram to find all
28582 -- inherited class-wide pre- and postconditions.
28584 if Present
(Prags
) then
28585 Prag
:= Pre_Post_Conditions
(Prags
);
28587 while Present
(Prag
) loop
28588 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
28589 Name_Precondition
, Name_Postcondition
)
28590 and then Class_Present
(Prag
)
28592 -- The generated pragma must be analyzed in the context of
28593 -- the subprogram, to make its formals visible. In addition,
28594 -- we must inhibit freezing and full analysis because the
28595 -- controlling type of the subprogram is not frozen yet, and
28596 -- may have further primitives.
28598 if not Installed
then
28601 Install_Formals
(Subp
);
28602 In_Spec_Expr
:= In_Spec_Expression
;
28603 In_Spec_Expression
:= True;
28607 Build_Pragma_Check_Equivalent
28608 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
28610 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
28611 Preanalyze
(New_Prag
);
28613 -- Prevent further analysis in subsequent processing of the
28614 -- current list of declarations
28616 Set_Analyzed
(New_Prag
);
28619 Prag
:= Next_Pragma
(Prag
);
28623 In_Spec_Expression
:= In_Spec_Expr
;
28627 end Collect_Inherited_Class_Wide_Conditions
;
28629 ---------------------------------------
28630 -- Collect_Subprogram_Inputs_Outputs --
28631 ---------------------------------------
28633 procedure Collect_Subprogram_Inputs_Outputs
28634 (Subp_Id
: Entity_Id
;
28635 Synthesize
: Boolean := False;
28636 Subp_Inputs
: in out Elist_Id
;
28637 Subp_Outputs
: in out Elist_Id
;
28638 Global_Seen
: out Boolean)
28640 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
28641 -- Collect all relevant items from a dependency clause
28643 procedure Collect_Global_List
28645 Mode
: Name_Id
:= Name_Input
);
28646 -- Collect all relevant items from a global list
28648 -------------------------------
28649 -- Collect_Dependency_Clause --
28650 -------------------------------
28652 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
28653 procedure Collect_Dependency_Item
28655 Is_Input
: Boolean);
28656 -- Add an item to the proper subprogram input or output collection
28658 -----------------------------
28659 -- Collect_Dependency_Item --
28660 -----------------------------
28662 procedure Collect_Dependency_Item
28664 Is_Input
: Boolean)
28669 -- Nothing to collect when the item is null
28671 if Nkind
(Item
) = N_Null
then
28674 -- Ditto for attribute 'Result
28676 elsif Is_Attribute_Result
(Item
) then
28679 -- Multiple items appear as an aggregate
28681 elsif Nkind
(Item
) = N_Aggregate
then
28682 Extra
:= First
(Expressions
(Item
));
28683 while Present
(Extra
) loop
28684 Collect_Dependency_Item
(Extra
, Is_Input
);
28688 -- Otherwise this is a solitary item
28692 Append_New_Elmt
(Item
, Subp_Inputs
);
28694 Append_New_Elmt
(Item
, Subp_Outputs
);
28697 end Collect_Dependency_Item
;
28699 -- Start of processing for Collect_Dependency_Clause
28702 if Nkind
(Clause
) = N_Null
then
28705 -- A dependency clause appears as component association
28707 elsif Nkind
(Clause
) = N_Component_Association
then
28708 Collect_Dependency_Item
28709 (Item
=> Expression
(Clause
),
28712 Collect_Dependency_Item
28713 (Item
=> First
(Choices
(Clause
)),
28714 Is_Input
=> False);
28716 -- To accommodate partial decoration of disabled SPARK features, this
28717 -- routine may be called with illegal input. If this is the case, do
28718 -- not raise Program_Error.
28723 end Collect_Dependency_Clause
;
28725 -------------------------
28726 -- Collect_Global_List --
28727 -------------------------
28729 procedure Collect_Global_List
28731 Mode
: Name_Id
:= Name_Input
)
28733 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
28734 -- Add an item to the proper subprogram input or output collection
28736 -------------------------
28737 -- Collect_Global_Item --
28738 -------------------------
28740 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
28742 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
28743 Append_New_Elmt
(Item
, Subp_Inputs
);
28746 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
28747 Append_New_Elmt
(Item
, Subp_Outputs
);
28749 end Collect_Global_Item
;
28756 -- Start of processing for Collect_Global_List
28759 if Nkind
(List
) = N_Null
then
28762 -- Single global item declaration
28764 elsif Nkind_In
(List
, N_Expanded_Name
,
28766 N_Selected_Component
)
28768 Collect_Global_Item
(List
, Mode
);
28770 -- Simple global list or moded global list declaration
28772 elsif Nkind
(List
) = N_Aggregate
then
28773 if Present
(Expressions
(List
)) then
28774 Item
:= First
(Expressions
(List
));
28775 while Present
(Item
) loop
28776 Collect_Global_Item
(Item
, Mode
);
28781 Assoc
:= First
(Component_Associations
(List
));
28782 while Present
(Assoc
) loop
28783 Collect_Global_List
28784 (List
=> Expression
(Assoc
),
28785 Mode
=> Chars
(First
(Choices
(Assoc
))));
28790 -- To accommodate partial decoration of disabled SPARK features, this
28791 -- routine may be called with illegal input. If this is the case, do
28792 -- not raise Program_Error.
28797 end Collect_Global_List
;
28804 Formal
: Entity_Id
;
28806 Spec_Id
: Entity_Id
:= Empty
;
28807 Subp_Decl
: Node_Id
;
28810 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28813 Global_Seen
:= False;
28815 -- Process all formal parameters of entries, [generic] subprograms, and
28818 if Ekind_In
(Subp_Id
, E_Entry
,
28821 E_Generic_Function
,
28822 E_Generic_Procedure
,
28826 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
28827 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28829 -- Process all formal parameters
28831 Formal
:= First_Entity
(Spec_Id
);
28832 while Present
(Formal
) loop
28833 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
28834 Append_New_Elmt
(Formal
, Subp_Inputs
);
28837 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
28838 Append_New_Elmt
(Formal
, Subp_Outputs
);
28840 -- Out parameters can act as inputs when the related type is
28841 -- tagged, unconstrained array, unconstrained record, or record
28842 -- with unconstrained components.
28844 if Ekind
(Formal
) = E_Out_Parameter
28845 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
28847 Append_New_Elmt
(Formal
, Subp_Inputs
);
28851 Next_Entity
(Formal
);
28854 -- Otherwise the input denotes a task type, a task body, or the
28855 -- anonymous object created for a single task type.
28857 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
28858 or else Is_Single_Task_Object
(Subp_Id
)
28860 Subp_Decl
:= Declaration_Node
(Subp_Id
);
28861 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28864 -- When processing an entry, subprogram or task body, look for pragmas
28865 -- Refined_Depends and Refined_Global as they specify the inputs and
28868 if Is_Entry_Body
(Subp_Id
)
28869 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
28871 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
28872 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
28874 -- Subprogram declaration or stand-alone body case, look for pragmas
28875 -- Depends and Global
28878 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
28879 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28882 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28883 -- because it provides finer granularity of inputs and outputs.
28885 if Present
(Global
) then
28886 Global_Seen
:= True;
28887 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28889 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28890 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28891 -- the inputs and outputs from [Refined_]Depends.
28893 elsif Synthesize
and then Present
(Depends
) then
28894 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
28896 -- Multiple dependency clauses appear as an aggregate
28898 if Nkind
(Clauses
) = N_Aggregate
then
28899 Clause
:= First
(Component_Associations
(Clauses
));
28900 while Present
(Clause
) loop
28901 Collect_Dependency_Clause
(Clause
);
28905 -- Otherwise this is a single dependency clause
28908 Collect_Dependency_Clause
(Clauses
);
28912 -- The current instance of a protected type acts as a formal parameter
28913 -- of mode IN for functions and IN OUT for entries and procedures
28914 -- (SPARK RM 6.1.4).
28916 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
28917 Typ
:= Scope
(Spec_Id
);
28919 -- Use the anonymous object when the type is single protected
28921 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28922 Typ
:= Anonymous_Object
(Typ
);
28925 Append_New_Elmt
(Typ
, Subp_Inputs
);
28927 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
28928 Append_New_Elmt
(Typ
, Subp_Outputs
);
28931 -- The current instance of a task type acts as a formal parameter of
28932 -- mode IN OUT (SPARK RM 6.1.4).
28934 elsif Ekind
(Spec_Id
) = E_Task_Type
then
28937 -- Use the anonymous object when the type is single task
28939 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28940 Typ
:= Anonymous_Object
(Typ
);
28943 Append_New_Elmt
(Typ
, Subp_Inputs
);
28944 Append_New_Elmt
(Typ
, Subp_Outputs
);
28946 elsif Is_Single_Task_Object
(Spec_Id
) then
28947 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
28948 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
28950 end Collect_Subprogram_Inputs_Outputs
;
28952 ---------------------------
28953 -- Contract_Freeze_Error --
28954 ---------------------------
28956 procedure Contract_Freeze_Error
28957 (Contract_Id
: Entity_Id
;
28958 Freeze_Id
: Entity_Id
)
28961 Error_Msg_Name_1
:= Chars
(Contract_Id
);
28962 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28965 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
28967 ("\all contractual items must be declared before body #", Contract_Id
);
28968 end Contract_Freeze_Error
;
28970 ---------------------------------
28971 -- Delay_Config_Pragma_Analyze --
28972 ---------------------------------
28974 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
28976 return Nam_In
(Pragma_Name_Unmapped
(N
),
28977 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
28978 end Delay_Config_Pragma_Analyze
;
28980 -----------------------
28981 -- Duplication_Error --
28982 -----------------------
28984 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
28985 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
28986 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
28989 Error_Msg_Sloc
:= Sloc
(Prev
);
28990 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28992 -- Emit a precise message to distinguish between source pragmas and
28993 -- pragmas generated from aspects. The ordering of the two pragmas is
28997 -- Prag -- duplicate
28999 -- No error is emitted when both pragmas come from aspects because this
29000 -- is already detected by the general aspect analysis mechanism.
29002 if Prag_From_Asp
and Prev_From_Asp
then
29004 elsif Prag_From_Asp
then
29005 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
29006 elsif Prev_From_Asp
then
29007 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
29009 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
29011 end Duplication_Error
;
29013 ------------------------------
29014 -- Find_Encapsulating_State --
29015 ------------------------------
29017 function Find_Encapsulating_State
29018 (States
: Elist_Id
;
29019 Constit_Id
: Entity_Id
) return Entity_Id
29021 State_Id
: Entity_Id
;
29024 -- Since a constituent may be part of a larger constituent set, climb
29025 -- the encapsulating state chain looking for a state that appears in
29028 State_Id
:= Encapsulating_State
(Constit_Id
);
29029 while Present
(State_Id
) loop
29030 if Contains
(States
, State_Id
) then
29034 State_Id
:= Encapsulating_State
(State_Id
);
29038 end Find_Encapsulating_State
;
29040 --------------------------
29041 -- Find_Related_Context --
29042 --------------------------
29044 function Find_Related_Context
29046 Do_Checks
: Boolean := False) return Node_Id
29051 Stmt
:= Prev
(Prag
);
29052 while Present
(Stmt
) loop
29054 -- Skip prior pragmas, but check for duplicates
29056 if Nkind
(Stmt
) = N_Pragma
then
29058 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
29065 -- Skip internally generated code
29067 elsif not Comes_From_Source
(Stmt
) then
29069 -- The anonymous object created for a single concurrent type is a
29070 -- suitable context.
29072 if Nkind
(Stmt
) = N_Object_Declaration
29073 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29078 -- Return the current source construct
29088 end Find_Related_Context
;
29090 --------------------------------------
29091 -- Find_Related_Declaration_Or_Body --
29092 --------------------------------------
29094 function Find_Related_Declaration_Or_Body
29096 Do_Checks
: Boolean := False) return Node_Id
29098 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
29100 procedure Expression_Function_Error
;
29101 -- Emit an error concerning pragma Prag that illegaly applies to an
29102 -- expression function.
29104 -------------------------------
29105 -- Expression_Function_Error --
29106 -------------------------------
29108 procedure Expression_Function_Error
is
29110 Error_Msg_Name_1
:= Prag_Nam
;
29112 -- Emit a precise message to distinguish between source pragmas and
29113 -- pragmas generated from aspects.
29115 if From_Aspect_Specification
(Prag
) then
29117 ("aspect % cannot apply to a stand alone expression function",
29121 ("pragma % cannot apply to a stand alone expression function",
29124 end Expression_Function_Error
;
29128 Context
: constant Node_Id
:= Parent
(Prag
);
29131 Look_For_Body
: constant Boolean :=
29132 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
29133 Name_Refined_Global
,
29135 Name_Refined_State
);
29136 -- Refinement pragmas must be associated with a subprogram body [stub]
29138 -- Start of processing for Find_Related_Declaration_Or_Body
29141 Stmt
:= Prev
(Prag
);
29142 while Present
(Stmt
) loop
29144 -- Skip prior pragmas, but check for duplicates. Pragmas produced
29145 -- by splitting a complex pre/postcondition are not considered to
29148 if Nkind
(Stmt
) = N_Pragma
then
29150 and then not Split_PPC
(Stmt
)
29151 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
29158 -- Emit an error when a refinement pragma appears on an expression
29159 -- function without a completion.
29162 and then Look_For_Body
29163 and then Nkind
(Stmt
) = N_Subprogram_Declaration
29164 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
29165 and then not Has_Completion
(Defining_Entity
(Stmt
))
29167 Expression_Function_Error
;
29170 -- The refinement pragma applies to a subprogram body stub
29172 elsif Look_For_Body
29173 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
29177 -- Skip internally generated code
29179 elsif not Comes_From_Source
(Stmt
) then
29181 -- The anonymous object created for a single concurrent type is a
29182 -- suitable context.
29184 if Nkind
(Stmt
) = N_Object_Declaration
29185 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29189 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
29191 -- The subprogram declaration is an internally generated spec
29192 -- for an expression function.
29194 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29197 -- The subprogram is actually an instance housed within an
29198 -- anonymous wrapper package.
29200 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29205 -- Return the current construct which is either a subprogram body,
29206 -- a subprogram declaration or is illegal.
29215 -- If we fall through, then the pragma was either the first declaration
29216 -- or it was preceded by other pragmas and no source constructs.
29218 -- The pragma is associated with a library-level subprogram
29220 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
29221 return Unit
(Parent
(Context
));
29223 -- The pragma appears inside the declarations of an entry body
29225 elsif Nkind
(Context
) = N_Entry_Body
then
29228 -- The pragma appears inside the statements of a subprogram body. This
29229 -- placement is the result of subprogram contract expansion.
29231 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
29232 return Parent
(Context
);
29234 -- The pragma appears inside the declarative part of a package body
29236 elsif Nkind
(Context
) = N_Package_Body
then
29239 -- The pragma appears inside the declarative part of a subprogram body
29241 elsif Nkind
(Context
) = N_Subprogram_Body
then
29244 -- The pragma appears inside the declarative part of a task body
29246 elsif Nkind
(Context
) = N_Task_Body
then
29249 -- The pragma appears inside the visible part of a package specification
29251 elsif Nkind
(Context
) = N_Package_Specification
then
29252 return Parent
(Context
);
29254 -- The pragma is a byproduct of aspect expansion, return the related
29255 -- context of the original aspect. This case has a lower priority as
29256 -- the above circuitry pinpoints precisely the related context.
29258 elsif Present
(Corresponding_Aspect
(Prag
)) then
29259 return Parent
(Corresponding_Aspect
(Prag
));
29261 -- No candidate subprogram [body] found
29266 end Find_Related_Declaration_Or_Body
;
29268 ----------------------------------
29269 -- Find_Related_Package_Or_Body --
29270 ----------------------------------
29272 function Find_Related_Package_Or_Body
29274 Do_Checks
: Boolean := False) return Node_Id
29276 Context
: constant Node_Id
:= Parent
(Prag
);
29277 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29281 Stmt
:= Prev
(Prag
);
29282 while Present
(Stmt
) loop
29284 -- Skip prior pragmas, but check for duplicates
29286 if Nkind
(Stmt
) = N_Pragma
then
29287 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
29293 -- Skip internally generated code
29295 elsif not Comes_From_Source
(Stmt
) then
29296 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
29298 -- The subprogram declaration is an internally generated spec
29299 -- for an expression function.
29301 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29304 -- The subprogram is actually an instance housed within an
29305 -- anonymous wrapper package.
29307 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29312 -- Return the current source construct which is illegal
29321 -- If we fall through, then the pragma was either the first declaration
29322 -- or it was preceded by other pragmas and no source constructs.
29324 -- The pragma is associated with a package. The immediate context in
29325 -- this case is the specification of the package.
29327 if Nkind
(Context
) = N_Package_Specification
then
29328 return Parent
(Context
);
29330 -- The pragma appears in the declarations of a package body
29332 elsif Nkind
(Context
) = N_Package_Body
then
29335 -- The pragma appears in the statements of a package body
29337 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
29338 and then Nkind
(Parent
(Context
)) = N_Package_Body
29340 return Parent
(Context
);
29342 -- The pragma is a byproduct of aspect expansion, return the related
29343 -- context of the original aspect. This case has a lower priority as
29344 -- the above circuitry pinpoints precisely the related context.
29346 elsif Present
(Corresponding_Aspect
(Prag
)) then
29347 return Parent
(Corresponding_Aspect
(Prag
));
29349 -- No candidate package [body] found
29354 end Find_Related_Package_Or_Body
;
29360 function Get_Argument
29362 Context_Id
: Entity_Id
:= Empty
) return Node_Id
29364 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
29367 -- Use the expression of the original aspect when compiling for ASIS or
29368 -- when analyzing the template of a generic unit. In both cases the
29369 -- aspect's tree must be decorated to allow for ASIS queries or to save
29370 -- the global references in the generic context.
29372 if From_Aspect_Specification
(Prag
)
29373 and then (ASIS_Mode
or else (Present
(Context_Id
)
29374 and then Is_Generic_Unit
(Context_Id
)))
29376 return Corresponding_Aspect
(Prag
);
29378 -- Otherwise use the expression of the pragma
29380 elsif Present
(Args
) then
29381 return First
(Args
);
29388 -------------------------
29389 -- Get_Base_Subprogram --
29390 -------------------------
29392 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
29393 Result
: Entity_Id
;
29396 -- Follow subprogram renaming chain
29400 if Is_Subprogram
(Result
)
29402 Nkind
(Parent
(Declaration_Node
(Result
))) =
29403 N_Subprogram_Renaming_Declaration
29404 and then Present
(Alias
(Result
))
29406 Result
:= Alias
(Result
);
29410 end Get_Base_Subprogram
;
29412 -----------------------
29413 -- Get_SPARK_Mode_Type --
29414 -----------------------
29416 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
29418 if N
= Name_On
then
29420 elsif N
= Name_Off
then
29423 -- Any other argument is illegal. Assume that no SPARK mode applies to
29424 -- avoid potential cascaded errors.
29429 end Get_SPARK_Mode_Type
;
29431 ------------------------------------
29432 -- Get_SPARK_Mode_From_Annotation --
29433 ------------------------------------
29435 function Get_SPARK_Mode_From_Annotation
29436 (N
: Node_Id
) return SPARK_Mode_Type
29441 if Nkind
(N
) = N_Aspect_Specification
then
29442 Mode
:= Expression
(N
);
29444 else pragma Assert
(Nkind
(N
) = N_Pragma
);
29445 Mode
:= First
(Pragma_Argument_Associations
(N
));
29447 if Present
(Mode
) then
29448 Mode
:= Get_Pragma_Arg
(Mode
);
29452 -- Aspect or pragma SPARK_Mode specifies an explicit mode
29454 if Present
(Mode
) then
29455 if Nkind
(Mode
) = N_Identifier
then
29456 return Get_SPARK_Mode_Type
(Chars
(Mode
));
29458 -- In case of a malformed aspect or pragma, return the default None
29464 -- Otherwise the lack of an expression defaults SPARK_Mode to On
29469 end Get_SPARK_Mode_From_Annotation
;
29471 ---------------------------
29472 -- Has_Extra_Parentheses --
29473 ---------------------------
29475 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
29479 -- The aggregate should not have an expression list because a clause
29480 -- is always interpreted as a component association. The only way an
29481 -- expression list can sneak in is by adding extra parentheses around
29482 -- the individual clauses:
29484 -- Depends (Output => Input) -- proper form
29485 -- Depends ((Output => Input)) -- extra parentheses
29487 -- Since the extra parentheses are not allowed by the syntax of the
29488 -- pragma, flag them now to avoid emitting misleading errors down the
29491 if Nkind
(Clause
) = N_Aggregate
29492 and then Present
(Expressions
(Clause
))
29494 Expr
:= First
(Expressions
(Clause
));
29495 while Present
(Expr
) loop
29497 -- A dependency clause surrounded by extra parentheses appears
29498 -- as an aggregate of component associations with an optional
29499 -- Paren_Count set.
29501 if Nkind
(Expr
) = N_Aggregate
29502 and then Present
(Component_Associations
(Expr
))
29505 ("dependency clause contains extra parentheses", Expr
);
29507 -- Otherwise the expression is a malformed construct
29510 SPARK_Msg_N
("malformed dependency clause", Expr
);
29520 end Has_Extra_Parentheses
;
29526 procedure Initialize
is
29537 Dummy
:= Dummy
+ 1;
29540 -----------------------------
29541 -- Is_Config_Static_String --
29542 -----------------------------
29544 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29546 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
29547 -- This is an internal recursive function that is just like the outer
29548 -- function except that it adds the string to the name buffer rather
29549 -- than placing the string in the name buffer.
29551 ------------------------------
29552 -- Add_Config_Static_String --
29553 ------------------------------
29555 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29562 if Nkind
(N
) = N_Op_Concat
then
29563 if Add_Config_Static_String
(Left_Opnd
(N
)) then
29564 N
:= Right_Opnd
(N
);
29570 if Nkind
(N
) /= N_String_Literal
then
29571 Error_Msg_N
("string literal expected for pragma argument", N
);
29575 for J
in 1 .. String_Length
(Strval
(N
)) loop
29576 C
:= Get_String_Char
(Strval
(N
), J
);
29578 if not In_Character_Range
(C
) then
29580 ("string literal contains invalid wide character",
29581 Sloc
(N
) + 1 + Source_Ptr
(J
));
29585 Add_Char_To_Name_Buffer
(Get_Character
(C
));
29590 end Add_Config_Static_String
;
29592 -- Start of processing for Is_Config_Static_String
29597 return Add_Config_Static_String
(Arg
);
29598 end Is_Config_Static_String
;
29600 -------------------------------
29601 -- Is_Elaboration_SPARK_Mode --
29602 -------------------------------
29604 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
29607 (Nkind
(N
) = N_Pragma
29608 and then Pragma_Name
(N
) = Name_SPARK_Mode
29609 and then Is_List_Member
(N
));
29611 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29612 -- appears in the statement part of the body.
29615 Present
(Parent
(N
))
29616 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
29617 and then List_Containing
(N
) = Statements
(Parent
(N
))
29618 and then Present
(Parent
(Parent
(N
)))
29619 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
29620 end Is_Elaboration_SPARK_Mode
;
29622 -----------------------
29623 -- Is_Enabled_Pragma --
29624 -----------------------
29626 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
29630 if Present
(Prag
) then
29631 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29633 if Present
(Arg
) then
29634 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
29636 -- The lack of a Boolean argument automatically enables the pragma
29642 -- The pragma is missing, therefore it is not enabled
29647 end Is_Enabled_Pragma
;
29649 -----------------------------------------
29650 -- Is_Non_Significant_Pragma_Reference --
29651 -----------------------------------------
29653 -- This function makes use of the following static table which indicates
29654 -- whether appearance of some name in a given pragma is to be considered
29655 -- as a reference for the purposes of warnings about unreferenced objects.
29657 -- -1 indicates that appearence in any argument is significant
29658 -- 0 indicates that appearance in any argument is not significant
29659 -- +n indicates that appearance as argument n is significant, but all
29660 -- other arguments are not significant
29661 -- 9n arguments from n on are significant, before n insignificant
29663 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
29664 (Pragma_Abort_Defer
=> -1,
29665 Pragma_Abstract_State
=> -1,
29666 Pragma_Ada_83
=> -1,
29667 Pragma_Ada_95
=> -1,
29668 Pragma_Ada_05
=> -1,
29669 Pragma_Ada_2005
=> -1,
29670 Pragma_Ada_12
=> -1,
29671 Pragma_Ada_2012
=> -1,
29672 Pragma_Ada_2020
=> -1,
29673 Pragma_All_Calls_Remote
=> -1,
29674 Pragma_Allow_Integer_Address
=> -1,
29675 Pragma_Annotate
=> 93,
29676 Pragma_Assert
=> -1,
29677 Pragma_Assert_And_Cut
=> -1,
29678 Pragma_Assertion_Policy
=> 0,
29679 Pragma_Assume
=> -1,
29680 Pragma_Assume_No_Invalid_Values
=> 0,
29681 Pragma_Async_Readers
=> 0,
29682 Pragma_Async_Writers
=> 0,
29683 Pragma_Asynchronous
=> 0,
29684 Pragma_Atomic
=> 0,
29685 Pragma_Atomic_Components
=> 0,
29686 Pragma_Attach_Handler
=> -1,
29687 Pragma_Attribute_Definition
=> 92,
29688 Pragma_Check
=> -1,
29689 Pragma_Check_Float_Overflow
=> 0,
29690 Pragma_Check_Name
=> 0,
29691 Pragma_Check_Policy
=> 0,
29692 Pragma_CPP_Class
=> 0,
29693 Pragma_CPP_Constructor
=> 0,
29694 Pragma_CPP_Virtual
=> 0,
29695 Pragma_CPP_Vtable
=> 0,
29697 Pragma_C_Pass_By_Copy
=> 0,
29698 Pragma_Comment
=> -1,
29699 Pragma_Common_Object
=> 0,
29700 Pragma_Compile_Time_Error
=> -1,
29701 Pragma_Compile_Time_Warning
=> -1,
29702 Pragma_Compiler_Unit
=> -1,
29703 Pragma_Compiler_Unit_Warning
=> -1,
29704 Pragma_Complete_Representation
=> 0,
29705 Pragma_Complex_Representation
=> 0,
29706 Pragma_Component_Alignment
=> 0,
29707 Pragma_Constant_After_Elaboration
=> 0,
29708 Pragma_Contract_Cases
=> -1,
29709 Pragma_Controlled
=> 0,
29710 Pragma_Convention
=> 0,
29711 Pragma_Convention_Identifier
=> 0,
29712 Pragma_Deadline_Floor
=> -1,
29713 Pragma_Debug
=> -1,
29714 Pragma_Debug_Policy
=> 0,
29715 Pragma_Detect_Blocking
=> 0,
29716 Pragma_Default_Initial_Condition
=> -1,
29717 Pragma_Default_Scalar_Storage_Order
=> 0,
29718 Pragma_Default_Storage_Pool
=> 0,
29719 Pragma_Depends
=> -1,
29720 Pragma_Disable_Atomic_Synchronization
=> 0,
29721 Pragma_Discard_Names
=> 0,
29722 Pragma_Dispatching_Domain
=> -1,
29723 Pragma_Effective_Reads
=> 0,
29724 Pragma_Effective_Writes
=> 0,
29725 Pragma_Elaborate
=> 0,
29726 Pragma_Elaborate_All
=> 0,
29727 Pragma_Elaborate_Body
=> 0,
29728 Pragma_Elaboration_Checks
=> 0,
29729 Pragma_Eliminate
=> 0,
29730 Pragma_Enable_Atomic_Synchronization
=> 0,
29731 Pragma_Export
=> -1,
29732 Pragma_Export_Function
=> -1,
29733 Pragma_Export_Object
=> -1,
29734 Pragma_Export_Procedure
=> -1,
29735 Pragma_Export_Value
=> -1,
29736 Pragma_Export_Valued_Procedure
=> -1,
29737 Pragma_Extend_System
=> -1,
29738 Pragma_Extensions_Allowed
=> 0,
29739 Pragma_Extensions_Visible
=> 0,
29740 Pragma_External
=> -1,
29741 Pragma_Favor_Top_Level
=> 0,
29742 Pragma_External_Name_Casing
=> 0,
29743 Pragma_Fast_Math
=> 0,
29744 Pragma_Finalize_Storage_Only
=> 0,
29746 Pragma_Global
=> -1,
29747 Pragma_Ident
=> -1,
29748 Pragma_Ignore_Pragma
=> 0,
29749 Pragma_Implementation_Defined
=> -1,
29750 Pragma_Implemented
=> -1,
29751 Pragma_Implicit_Packing
=> 0,
29752 Pragma_Import
=> 93,
29753 Pragma_Import_Function
=> 0,
29754 Pragma_Import_Object
=> 0,
29755 Pragma_Import_Procedure
=> 0,
29756 Pragma_Import_Valued_Procedure
=> 0,
29757 Pragma_Independent
=> 0,
29758 Pragma_Independent_Components
=> 0,
29759 Pragma_Initial_Condition
=> -1,
29760 Pragma_Initialize_Scalars
=> 0,
29761 Pragma_Initializes
=> -1,
29762 Pragma_Inline
=> 0,
29763 Pragma_Inline_Always
=> 0,
29764 Pragma_Inline_Generic
=> 0,
29765 Pragma_Inspection_Point
=> -1,
29766 Pragma_Interface
=> 92,
29767 Pragma_Interface_Name
=> 0,
29768 Pragma_Interrupt_Handler
=> -1,
29769 Pragma_Interrupt_Priority
=> -1,
29770 Pragma_Interrupt_State
=> -1,
29771 Pragma_Invariant
=> -1,
29772 Pragma_Keep_Names
=> 0,
29773 Pragma_License
=> 0,
29774 Pragma_Link_With
=> -1,
29775 Pragma_Linker_Alias
=> -1,
29776 Pragma_Linker_Constructor
=> -1,
29777 Pragma_Linker_Destructor
=> -1,
29778 Pragma_Linker_Options
=> -1,
29779 Pragma_Linker_Section
=> -1,
29781 Pragma_Lock_Free
=> 0,
29782 Pragma_Locking_Policy
=> 0,
29783 Pragma_Loop_Invariant
=> -1,
29784 Pragma_Loop_Optimize
=> 0,
29785 Pragma_Loop_Variant
=> -1,
29786 Pragma_Machine_Attribute
=> -1,
29788 Pragma_Main_Storage
=> -1,
29789 Pragma_Max_Queue_Length
=> 0,
29790 Pragma_Memory_Size
=> 0,
29791 Pragma_No_Return
=> 0,
29792 Pragma_No_Body
=> 0,
29793 Pragma_No_Component_Reordering
=> -1,
29794 Pragma_No_Elaboration_Code_All
=> 0,
29795 Pragma_No_Heap_Finalization
=> 0,
29796 Pragma_No_Inline
=> 0,
29797 Pragma_No_Run_Time
=> -1,
29798 Pragma_No_Strict_Aliasing
=> -1,
29799 Pragma_No_Tagged_Streams
=> 0,
29800 Pragma_Normalize_Scalars
=> 0,
29801 Pragma_Obsolescent
=> 0,
29802 Pragma_Optimize
=> 0,
29803 Pragma_Optimize_Alignment
=> 0,
29804 Pragma_Overflow_Mode
=> 0,
29805 Pragma_Overriding_Renamings
=> 0,
29806 Pragma_Ordered
=> 0,
29809 Pragma_Part_Of
=> 0,
29810 Pragma_Partition_Elaboration_Policy
=> 0,
29811 Pragma_Passive
=> 0,
29812 Pragma_Persistent_BSS
=> 0,
29813 Pragma_Polling
=> 0,
29814 Pragma_Prefix_Exception_Messages
=> 0,
29816 Pragma_Postcondition
=> -1,
29817 Pragma_Post_Class
=> -1,
29819 Pragma_Precondition
=> -1,
29820 Pragma_Predicate
=> -1,
29821 Pragma_Predicate_Failure
=> -1,
29822 Pragma_Preelaborable_Initialization
=> -1,
29823 Pragma_Preelaborate
=> 0,
29824 Pragma_Pre_Class
=> -1,
29825 Pragma_Priority
=> -1,
29826 Pragma_Priority_Specific_Dispatching
=> 0,
29827 Pragma_Profile
=> 0,
29828 Pragma_Profile_Warnings
=> 0,
29829 Pragma_Propagate_Exceptions
=> 0,
29830 Pragma_Provide_Shift_Operators
=> 0,
29831 Pragma_Psect_Object
=> 0,
29833 Pragma_Pure_Function
=> 0,
29834 Pragma_Queuing_Policy
=> 0,
29835 Pragma_Rational
=> 0,
29836 Pragma_Ravenscar
=> 0,
29837 Pragma_Refined_Depends
=> -1,
29838 Pragma_Refined_Global
=> -1,
29839 Pragma_Refined_Post
=> -1,
29840 Pragma_Refined_State
=> -1,
29841 Pragma_Relative_Deadline
=> 0,
29842 Pragma_Rename_Pragma
=> 0,
29843 Pragma_Remote_Access_Type
=> -1,
29844 Pragma_Remote_Call_Interface
=> -1,
29845 Pragma_Remote_Types
=> -1,
29846 Pragma_Restricted_Run_Time
=> 0,
29847 Pragma_Restriction_Warnings
=> 0,
29848 Pragma_Restrictions
=> 0,
29849 Pragma_Reviewable
=> -1,
29850 Pragma_Secondary_Stack_Size
=> -1,
29851 Pragma_Short_Circuit_And_Or
=> 0,
29852 Pragma_Share_Generic
=> 0,
29853 Pragma_Shared
=> 0,
29854 Pragma_Shared_Passive
=> 0,
29855 Pragma_Short_Descriptors
=> 0,
29856 Pragma_Simple_Storage_Pool_Type
=> 0,
29857 Pragma_Source_File_Name
=> 0,
29858 Pragma_Source_File_Name_Project
=> 0,
29859 Pragma_Source_Reference
=> 0,
29860 Pragma_SPARK_Mode
=> 0,
29861 Pragma_Storage_Size
=> -1,
29862 Pragma_Storage_Unit
=> 0,
29863 Pragma_Static_Elaboration_Desired
=> 0,
29864 Pragma_Stream_Convert
=> 0,
29865 Pragma_Style_Checks
=> 0,
29866 Pragma_Subtitle
=> 0,
29867 Pragma_Suppress
=> 0,
29868 Pragma_Suppress_Exception_Locations
=> 0,
29869 Pragma_Suppress_All
=> 0,
29870 Pragma_Suppress_Debug_Info
=> 0,
29871 Pragma_Suppress_Initialization
=> 0,
29872 Pragma_System_Name
=> 0,
29873 Pragma_Task_Dispatching_Policy
=> 0,
29874 Pragma_Task_Info
=> -1,
29875 Pragma_Task_Name
=> -1,
29876 Pragma_Task_Storage
=> -1,
29877 Pragma_Test_Case
=> -1,
29878 Pragma_Thread_Local_Storage
=> -1,
29879 Pragma_Time_Slice
=> -1,
29881 Pragma_Type_Invariant
=> -1,
29882 Pragma_Type_Invariant_Class
=> -1,
29883 Pragma_Unchecked_Union
=> 0,
29884 Pragma_Unevaluated_Use_Of_Old
=> 0,
29885 Pragma_Unimplemented_Unit
=> 0,
29886 Pragma_Universal_Aliasing
=> 0,
29887 Pragma_Universal_Data
=> 0,
29888 Pragma_Unmodified
=> 0,
29889 Pragma_Unreferenced
=> 0,
29890 Pragma_Unreferenced_Objects
=> 0,
29891 Pragma_Unreserve_All_Interrupts
=> 0,
29892 Pragma_Unsuppress
=> 0,
29893 Pragma_Unused
=> 0,
29894 Pragma_Use_VADS_Size
=> 0,
29895 Pragma_Validity_Checks
=> 0,
29896 Pragma_Volatile
=> 0,
29897 Pragma_Volatile_Components
=> 0,
29898 Pragma_Volatile_Full_Access
=> 0,
29899 Pragma_Volatile_Function
=> 0,
29900 Pragma_Warning_As_Error
=> 0,
29901 Pragma_Warnings
=> 0,
29902 Pragma_Weak_External
=> 0,
29903 Pragma_Wide_Character_Encoding
=> 0,
29904 Unknown_Pragma
=> 0);
29906 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
29912 function Arg_No
return Nat
;
29913 -- Returns an integer showing what argument we are in. A value of
29914 -- zero means we are not in any of the arguments.
29920 function Arg_No
return Nat
is
29925 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
29939 -- Start of processing for Non_Significant_Pragma_Reference
29944 if Nkind
(P
) /= N_Pragma_Argument_Association
then
29948 Id
:= Get_Pragma_Id
(Parent
(P
));
29949 C
:= Sig_Flags
(Id
);
29964 return AN
< (C
- 90);
29970 end Is_Non_Significant_Pragma_Reference
;
29972 ------------------------------
29973 -- Is_Pragma_String_Literal --
29974 ------------------------------
29976 -- This function returns true if the corresponding pragma argument is a
29977 -- static string expression. These are the only cases in which string
29978 -- literals can appear as pragma arguments. We also allow a string literal
29979 -- as the first argument to pragma Assert (although it will of course
29980 -- always generate a type error).
29982 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
29983 Pragn
: constant Node_Id
:= Parent
(Par
);
29984 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
29985 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
29991 N
:= First
(Assoc
);
29998 if Pname
= Name_Assert
then
30001 elsif Pname
= Name_Export
then
30004 elsif Pname
= Name_Ident
then
30007 elsif Pname
= Name_Import
then
30010 elsif Pname
= Name_Interface_Name
then
30013 elsif Pname
= Name_Linker_Alias
then
30016 elsif Pname
= Name_Linker_Section
then
30019 elsif Pname
= Name_Machine_Attribute
then
30022 elsif Pname
= Name_Source_File_Name
then
30025 elsif Pname
= Name_Source_Reference
then
30028 elsif Pname
= Name_Title
then
30031 elsif Pname
= Name_Subtitle
then
30037 end Is_Pragma_String_Literal
;
30039 ---------------------------
30040 -- Is_Private_SPARK_Mode --
30041 ---------------------------
30043 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
30046 (Nkind
(N
) = N_Pragma
30047 and then Pragma_Name
(N
) = Name_SPARK_Mode
30048 and then Is_List_Member
(N
));
30050 -- For pragma SPARK_Mode to be private, it has to appear in the private
30051 -- declarations of a package.
30054 Present
(Parent
(N
))
30055 and then Nkind
(Parent
(N
)) = N_Package_Specification
30056 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
30057 end Is_Private_SPARK_Mode
;
30059 -------------------------------------
30060 -- Is_Unconstrained_Or_Tagged_Item --
30061 -------------------------------------
30063 function Is_Unconstrained_Or_Tagged_Item
30064 (Item
: Entity_Id
) return Boolean
30066 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
30067 -- Determine whether record type Typ has at least one unconstrained
30070 ---------------------------------
30071 -- Has_Unconstrained_Component --
30072 ---------------------------------
30074 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
30078 Comp
:= First_Component
(Typ
);
30079 while Present
(Comp
) loop
30080 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
30084 Next_Component
(Comp
);
30088 end Has_Unconstrained_Component
;
30092 Typ
: constant Entity_Id
:= Etype
(Item
);
30094 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
30097 if Is_Tagged_Type
(Typ
) then
30100 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
30103 elsif Is_Record_Type
(Typ
) then
30104 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
30107 return Has_Unconstrained_Component
(Typ
);
30110 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
30116 end Is_Unconstrained_Or_Tagged_Item
;
30118 -----------------------------
30119 -- Is_Valid_Assertion_Kind --
30120 -----------------------------
30122 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
30129 | Name_Assertion_Policy
30130 | Name_Static_Predicate
30131 | Name_Dynamic_Predicate
30136 | Name_Type_Invariant
30137 | Name_uType_Invariant
30141 | Name_Assert_And_Cut
30143 | Name_Contract_Cases
30145 | Name_Default_Initial_Condition
30147 | Name_Initial_Condition
30150 | Name_Loop_Invariant
30151 | Name_Loop_Variant
30152 | Name_Postcondition
30153 | Name_Precondition
30155 | Name_Refined_Post
30156 | Name_Statement_Assertions
30163 end Is_Valid_Assertion_Kind
;
30165 --------------------------------------
30166 -- Process_Compilation_Unit_Pragmas --
30167 --------------------------------------
30169 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
30171 -- A special check for pragma Suppress_All, a very strange DEC pragma,
30172 -- strange because it comes at the end of the unit. Rational has the
30173 -- same name for a pragma, but treats it as a program unit pragma, In
30174 -- GNAT we just decide to allow it anywhere at all. If it appeared then
30175 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
30176 -- node, and we insert a pragma Suppress (All_Checks) at the start of
30177 -- the context clause to ensure the correct processing.
30179 if Has_Pragma_Suppress_All
(N
) then
30180 Prepend_To
(Context_Items
(N
),
30181 Make_Pragma
(Sloc
(N
),
30182 Chars
=> Name_Suppress
,
30183 Pragma_Argument_Associations
=> New_List
(
30184 Make_Pragma_Argument_Association
(Sloc
(N
),
30185 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
30188 -- Nothing else to do at the current time
30190 end Process_Compilation_Unit_Pragmas
;
30192 -------------------------------------------
30193 -- Process_Compile_Time_Warning_Or_Error --
30194 -------------------------------------------
30196 procedure Process_Compile_Time_Warning_Or_Error
30200 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
30201 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
30202 Arg2
: constant Node_Id
:= Next
(Arg1
);
30205 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
30207 if Compile_Time_Known_Value
(Arg1x
) then
30208 if Is_True
(Expr_Value
(Arg1x
)) then
30210 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
30211 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
30212 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
30213 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
30214 Str_Len
: constant Nat
:= String_Length
(Str
);
30216 Force
: constant Boolean :=
30217 Prag_Id
= Pragma_Compile_Time_Warning
30218 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
30219 and then (Ekind
(Cent
) /= E_Package
30220 or else not In_Private_Part
(Cent
));
30221 -- Set True if this is the warning case, and we are in the
30222 -- visible part of a package spec, or in a subprogram spec,
30223 -- in which case we want to force the client to see the
30224 -- warning, even though it is not in the main unit.
30232 -- Loop through segments of message separated by line feeds.
30233 -- We output these segments as separate messages with
30234 -- continuation marks for all but the first.
30239 Error_Msg_Strlen
:= 0;
30241 -- Loop to copy characters from argument to error message
30245 exit when Ptr
> Str_Len
;
30246 CC
:= Get_String_Char
(Str
, Ptr
);
30249 -- Ignore wide chars ??? else store character
30251 if In_Character_Range
(CC
) then
30252 C
:= Get_Character
(CC
);
30253 exit when C
= ASCII
.LF
;
30254 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
30255 Error_Msg_String
(Error_Msg_Strlen
) := C
;
30259 -- Here with one line ready to go
30261 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
30263 -- If this is a warning in a spec, then we want clients
30264 -- to see the warning, so mark the message with the
30265 -- special sequence !! to force the warning. In the case
30266 -- of a package spec, we do not force this if we are in
30267 -- the private part of the spec.
30270 if Cont
= False then
30271 Error_Msg
("<<~!!", Eloc
);
30274 Error_Msg
("\<<~!!", Eloc
);
30277 -- Error, rather than warning, or in a body, so we do not
30278 -- need to force visibility for client (error will be
30279 -- output in any case, and this is the situation in which
30280 -- we do not want a client to get a warning, since the
30281 -- warning is in the body or the spec private part).
30284 if Cont
= False then
30285 Error_Msg
("<<~", Eloc
);
30288 Error_Msg
("\<<~", Eloc
);
30292 exit when Ptr
> Str_Len
;
30297 end Process_Compile_Time_Warning_Or_Error
;
30299 ------------------------------------
30300 -- Record_Possible_Body_Reference --
30301 ------------------------------------
30303 procedure Record_Possible_Body_Reference
30304 (State_Id
: Entity_Id
;
30308 Spec_Id
: Entity_Id
;
30311 -- Ensure that we are dealing with a reference to a state
30313 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
30315 -- Climb the tree starting from the reference looking for a package body
30316 -- whose spec declares the referenced state. This criteria automatically
30317 -- excludes references in package specs which are legal. Note that it is
30318 -- not wise to emit an error now as the package body may lack pragma
30319 -- Refined_State or the referenced state may not be mentioned in the
30320 -- refinement. This approach avoids the generation of misleading errors.
30323 while Present
(Context
) loop
30324 if Nkind
(Context
) = N_Package_Body
then
30325 Spec_Id
:= Corresponding_Spec
(Context
);
30327 if Present
(Abstract_States
(Spec_Id
))
30328 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
30330 if No
(Body_References
(State_Id
)) then
30331 Set_Body_References
(State_Id
, New_Elmt_List
);
30334 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
30339 Context
:= Parent
(Context
);
30341 end Record_Possible_Body_Reference
;
30343 ------------------------------------------
30344 -- Relocate_Pragmas_To_Anonymous_Object --
30345 ------------------------------------------
30347 procedure Relocate_Pragmas_To_Anonymous_Object
30348 (Typ_Decl
: Node_Id
;
30349 Obj_Decl
: Node_Id
)
30353 Next_Decl
: Node_Id
;
30356 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
30357 Def
:= Protected_Definition
(Typ_Decl
);
30359 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
30360 Def
:= Task_Definition
(Typ_Decl
);
30363 -- The concurrent definition has a visible declaration list. Inspect it
30364 -- and relocate all canidate pragmas.
30366 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
30367 Decl
:= First
(Visible_Declarations
(Def
));
30368 while Present
(Decl
) loop
30370 -- Preserve the following declaration for iteration purposes due
30371 -- to possible relocation of a pragma.
30373 Next_Decl
:= Next
(Decl
);
30375 if Nkind
(Decl
) = N_Pragma
30376 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
30379 Insert_After
(Obj_Decl
, Decl
);
30381 -- Skip internally generated code
30383 elsif not Comes_From_Source
(Decl
) then
30386 -- No candidate pragmas are available for relocation
30395 end Relocate_Pragmas_To_Anonymous_Object
;
30397 ------------------------------
30398 -- Relocate_Pragmas_To_Body --
30399 ------------------------------
30401 procedure Relocate_Pragmas_To_Body
30402 (Subp_Body
: Node_Id
;
30403 Target_Body
: Node_Id
:= Empty
)
30405 procedure Relocate_Pragma
(Prag
: Node_Id
);
30406 -- Remove a single pragma from its current list and add it to the
30407 -- declarations of the proper body (either Subp_Body or Target_Body).
30409 ---------------------
30410 -- Relocate_Pragma --
30411 ---------------------
30413 procedure Relocate_Pragma
(Prag
: Node_Id
) is
30418 -- When subprogram stubs or expression functions are involves, the
30419 -- destination declaration list belongs to the proper body.
30421 if Present
(Target_Body
) then
30422 Target
:= Target_Body
;
30424 Target
:= Subp_Body
;
30427 Decls
:= Declarations
(Target
);
30431 Set_Declarations
(Target
, Decls
);
30434 -- Unhook the pragma from its current list
30437 Prepend
(Prag
, Decls
);
30438 end Relocate_Pragma
;
30442 Body_Id
: constant Entity_Id
:=
30443 Defining_Unit_Name
(Specification
(Subp_Body
));
30444 Next_Stmt
: Node_Id
;
30447 -- Start of processing for Relocate_Pragmas_To_Body
30450 -- Do not process a body that comes from a separate unit as no construct
30451 -- can possibly follow it.
30453 if not Is_List_Member
(Subp_Body
) then
30456 -- Do not relocate pragmas that follow a stub if the stub does not have
30459 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
30460 and then No
(Target_Body
)
30464 -- Do not process internally generated routine _Postconditions
30466 elsif Ekind
(Body_Id
) = E_Procedure
30467 and then Chars
(Body_Id
) = Name_uPostconditions
30472 -- Look at what is following the body. We are interested in certain kind
30473 -- of pragmas (either from source or byproducts of expansion) that can
30474 -- apply to a body [stub].
30476 Stmt
:= Next
(Subp_Body
);
30477 while Present
(Stmt
) loop
30479 -- Preserve the following statement for iteration purposes due to a
30480 -- possible relocation of a pragma.
30482 Next_Stmt
:= Next
(Stmt
);
30484 -- Move a candidate pragma following the body to the declarations of
30487 if Nkind
(Stmt
) = N_Pragma
30488 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
30491 -- If a source pragma Warnings follows the body, it applies to
30492 -- following statements and does not belong in the body.
30494 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
30495 and then Comes_From_Source
(Stmt
)
30499 Relocate_Pragma
(Stmt
);
30502 -- Skip internally generated code
30504 elsif not Comes_From_Source
(Stmt
) then
30507 -- No candidate pragmas are available for relocation
30515 end Relocate_Pragmas_To_Body
;
30517 -------------------
30518 -- Resolve_State --
30519 -------------------
30521 procedure Resolve_State
(N
: Node_Id
) is
30526 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30527 Func
:= Entity
(N
);
30529 -- Handle overloading of state names by functions. Traverse the
30530 -- homonym chain looking for an abstract state.
30532 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
30533 pragma Assert
(Is_Overloaded
(N
));
30535 State
:= Homonym
(Func
);
30536 while Present
(State
) loop
30537 if Ekind
(State
) = E_Abstract_State
then
30539 -- Resolve the overloading by setting the proper entity of
30540 -- the reference to that of the state.
30542 Set_Etype
(N
, Standard_Void_Type
);
30543 Set_Entity
(N
, State
);
30544 Set_Is_Overloaded
(N
, False);
30546 Generate_Reference
(State
, N
);
30550 State
:= Homonym
(State
);
30553 -- A function can never act as a state. If the homonym chain does
30554 -- not contain a corresponding state, then something went wrong in
30555 -- the overloading mechanism.
30557 raise Program_Error
;
30562 ----------------------------
30563 -- Rewrite_Assertion_Kind --
30564 ----------------------------
30566 procedure Rewrite_Assertion_Kind
30568 From_Policy
: Boolean := False)
30574 if Nkind
(N
) = N_Attribute_Reference
30575 and then Attribute_Name
(N
) = Name_Class
30576 and then Nkind
(Prefix
(N
)) = N_Identifier
30578 case Chars
(Prefix
(N
)) is
30585 when Name_Type_Invariant
=>
30586 Nam
:= Name_uType_Invariant
;
30588 when Name_Invariant
=>
30589 Nam
:= Name_uInvariant
;
30595 -- Recommend standard use of aspect names Pre/Post
30597 elsif Nkind
(N
) = N_Identifier
30598 and then From_Policy
30599 and then Serious_Errors_Detected
= 0
30600 and then not ASIS_Mode
30602 if Chars
(N
) = Name_Precondition
30603 or else Chars
(N
) = Name_Postcondition
30605 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
30607 ("\use Assertion_Policy and aspect names Pre/Post for "
30608 & "Ada2012 conformance?", N
);
30614 if Nam
/= No_Name
then
30615 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
30617 end Rewrite_Assertion_Kind
;
30625 Dummy
:= Dummy
+ 1;
30628 --------------------------------
30629 -- Set_Encoded_Interface_Name --
30630 --------------------------------
30632 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
30633 Str
: constant String_Id
:= Strval
(S
);
30634 Len
: constant Nat
:= String_Length
(Str
);
30639 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
30642 -- Stores encoded value of character code CC. The encoding we use an
30643 -- underscore followed by four lower case hex digits.
30649 procedure Encode
is
30651 Store_String_Char
(Get_Char_Code
('_'));
30653 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
30655 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
30657 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
30659 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
30662 -- Start of processing for Set_Encoded_Interface_Name
30665 -- If first character is asterisk, this is a link name, and we leave it
30666 -- completely unmodified. We also ignore null strings (the latter case
30667 -- happens only in error cases).
30670 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
30672 Set_Interface_Name
(E
, S
);
30677 CC
:= Get_String_Char
(Str
, J
);
30679 exit when not In_Character_Range
(CC
);
30681 C
:= Get_Character
(CC
);
30683 exit when C
/= '_' and then C
/= '$'
30684 and then C
not in '0' .. '9'
30685 and then C
not in 'a' .. 'z'
30686 and then C
not in 'A' .. 'Z';
30689 Set_Interface_Name
(E
, S
);
30697 -- Here we need to encode. The encoding we use as follows:
30698 -- three underscores + four hex digits (lower case)
30702 for J
in 1 .. String_Length
(Str
) loop
30703 CC
:= Get_String_Char
(Str
, J
);
30705 if not In_Character_Range
(CC
) then
30708 C
:= Get_Character
(CC
);
30710 if C
= '_' or else C
= '$'
30711 or else C
in '0' .. '9'
30712 or else C
in 'a' .. 'z'
30713 or else C
in 'A' .. 'Z'
30715 Store_String_Char
(CC
);
30722 Set_Interface_Name
(E
,
30723 Make_String_Literal
(Sloc
(S
),
30724 Strval
=> End_String
));
30726 end Set_Encoded_Interface_Name
;
30728 ------------------------
30729 -- Set_Elab_Unit_Name --
30730 ------------------------
30732 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
30737 if Nkind
(N
) = N_Identifier
30738 and then Nkind
(With_Item
) = N_Identifier
30740 Set_Entity
(N
, Entity
(With_Item
));
30742 elsif Nkind
(N
) = N_Selected_Component
then
30743 Change_Selected_Component_To_Expanded_Name
(N
);
30744 Set_Entity
(N
, Entity
(With_Item
));
30745 Set_Entity
(Selector_Name
(N
), Entity
(N
));
30747 Pref
:= Prefix
(N
);
30748 Scop
:= Scope
(Entity
(N
));
30749 while Nkind
(Pref
) = N_Selected_Component
loop
30750 Change_Selected_Component_To_Expanded_Name
(Pref
);
30751 Set_Entity
(Selector_Name
(Pref
), Scop
);
30752 Set_Entity
(Pref
, Scop
);
30753 Pref
:= Prefix
(Pref
);
30754 Scop
:= Scope
(Scop
);
30757 Set_Entity
(Pref
, Scop
);
30760 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
30761 end Set_Elab_Unit_Name
;
30763 -------------------
30764 -- Test_Case_Arg --
30765 -------------------
30767 function Test_Case_Arg
30770 From_Aspect
: Boolean := False) return Node_Id
30772 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
30777 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
30782 -- The caller requests the aspect argument
30784 if From_Aspect
then
30785 if Present
(Aspect
)
30786 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
30788 Args
:= Expression
(Aspect
);
30790 -- "Name" and "Mode" may appear without an identifier as a
30791 -- positional association.
30793 if Present
(Expressions
(Args
)) then
30794 Arg
:= First
(Expressions
(Args
));
30796 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30804 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30809 -- Some or all arguments may appear as component associatons
30811 if Present
(Component_Associations
(Args
)) then
30812 Arg
:= First
(Component_Associations
(Args
));
30813 while Present
(Arg
) loop
30814 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
30823 -- Otherwise retrieve the argument directly from the pragma
30826 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30828 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30832 -- Skip argument "Name"
30836 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30840 -- Skip argument "Mode"
30844 -- Arguments "Requires" and "Ensures" are optional and may not be
30847 while Present
(Arg
) loop
30848 if Chars
(Arg
) = Arg_Nam
then