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_Elim
; use Sem_Elim
;
68 with Sem_Eval
; use Sem_Eval
;
69 with Sem_Intr
; use Sem_Intr
;
70 with Sem_Mech
; use Sem_Mech
;
71 with Sem_Res
; use Sem_Res
;
72 with Sem_Type
; use Sem_Type
;
73 with Sem_Util
; use Sem_Util
;
74 with Sem_Warn
; use Sem_Warn
;
75 with Stand
; use Stand
;
76 with Sinfo
; use Sinfo
;
77 with Sinfo
.CN
; use Sinfo
.CN
;
78 with Sinput
; use Sinput
;
79 with Stringt
; use Stringt
;
80 with Stylesw
; use Stylesw
;
82 with Targparm
; use Targparm
;
83 with Tbuild
; use Tbuild
;
85 with Uintp
; use Uintp
;
86 with Uname
; use Uname
;
87 with Urealp
; use Urealp
;
88 with Validsw
; use Validsw
;
89 with Warnsw
; use Warnsw
;
91 with System
.Case_Util
;
93 package body Sem_Prag
is
95 ----------------------------------------------
96 -- Common Handling of Import-Export Pragmas --
97 ----------------------------------------------
99 -- In the following section, a number of Import_xxx and Export_xxx pragmas
100 -- are defined by GNAT. These are compatible with the DEC pragmas of the
101 -- same name, and all have the following common form and processing:
104 -- [Internal =>] LOCAL_NAME
105 -- [, [External =>] EXTERNAL_SYMBOL]
106 -- [, other optional parameters ]);
109 -- [Internal =>] LOCAL_NAME
110 -- [, [External =>] EXTERNAL_SYMBOL]
111 -- [, other optional parameters ]);
113 -- EXTERNAL_SYMBOL ::=
115 -- | static_string_EXPRESSION
117 -- The internal LOCAL_NAME designates the entity that is imported or
118 -- exported, and must refer to an entity in the current declarative
119 -- part (as required by the rules for LOCAL_NAME).
121 -- The external linker name is designated by the External parameter if
122 -- given, or the Internal parameter if not (if there is no External
123 -- parameter, the External parameter is a copy of the Internal name).
125 -- If the External parameter is given as a string, then this string is
126 -- treated as an external name (exactly as though it had been given as an
127 -- External_Name parameter for a normal Import pragma).
129 -- If the External parameter is given as an identifier (or there is no
130 -- External parameter, so that the Internal identifier is used), then
131 -- the external name is the characters of the identifier, translated
132 -- to all lower case letters.
134 -- Note: the external name specified or implied by any of these special
135 -- Import_xxx or Export_xxx pragmas override an external or link name
136 -- specified in a previous Import or Export pragma.
138 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
139 -- named notation, following the standard rules for subprogram calls, i.e.
140 -- parameters can be given in any order if named notation is used, and
141 -- positional and named notation can be mixed, subject to the rule that all
142 -- positional parameters must appear first.
144 -- Note: All these pragmas are implemented exactly following the DEC design
145 -- and implementation and are intended to be fully compatible with the use
146 -- of these pragmas in the DEC Ada compiler.
148 --------------------------------------------
149 -- Checking for Duplicated External Names --
150 --------------------------------------------
152 -- It is suspicious if two separate Export pragmas use the same external
153 -- name. The following table is used to diagnose this situation so that
154 -- an appropriate warning can be issued.
156 -- The Node_Id stored is for the N_String_Literal node created to hold
157 -- the value of the external name. The Sloc of this node is used to
158 -- cross-reference the location of the duplication.
160 package Externals
is new Table
.Table
(
161 Table_Component_Type
=> Node_Id
,
162 Table_Index_Type
=> Int
,
163 Table_Low_Bound
=> 0,
164 Table_Initial
=> 100,
165 Table_Increment
=> 100,
166 Table_Name
=> "Name_Externals");
168 -------------------------------------
169 -- Local Subprograms and Variables --
170 -------------------------------------
172 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
173 -- This routine is used for possible casing adjustment of an explicit
174 -- external name supplied as a string literal (the node N), according to
175 -- the casing requirement of Opt.External_Name_Casing. If this is set to
176 -- As_Is, then the string literal is returned unchanged, but if it is set
177 -- to Uppercase or Lowercase, then a new string literal with appropriate
178 -- casing is constructed.
180 procedure Analyze_Part_Of
184 Encap_Id
: out Entity_Id
;
185 Legal
: out Boolean);
186 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
187 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
188 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
189 -- package instantiation. Encap denotes the encapsulating state or single
190 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
191 -- the indicator is legal.
193 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
194 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
195 -- Query whether a particular item appears in a mixed list of nodes and
196 -- entities. It is assumed that all nodes in the list have entities.
198 procedure Check_Postcondition_Use_In_Inlined_Subprogram
200 Spec_Id
: Entity_Id
);
201 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
202 -- Precondition, Refined_Post, and Test_Case. Emit a warning when pragma
203 -- Prag is associated with subprogram Spec_Id subject to Inline_Always,
204 -- and assertions are enabled.
206 procedure Check_State_And_Constituent_Use
210 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
211 -- Global and Initializes. Determine whether a state from list States and a
212 -- corresponding constituent from list Constits (if any) appear in the same
213 -- context denoted by Context. If this is the case, emit an error.
215 procedure Contract_Freeze_Error
216 (Contract_Id
: Entity_Id
;
217 Freeze_Id
: Entity_Id
);
218 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
219 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
220 -- of a body which caused contract "freezing" and Contract_Id denotes the
221 -- entity of the affected contstruct.
223 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
224 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
225 -- Prag that duplicates previous pragma Prev.
227 function Find_Encapsulating_State
229 Constit_Id
: Entity_Id
) return Entity_Id
;
230 -- Given the entity of a constituent Constit_Id, find the corresponding
231 -- encapsulating state which appears in States. The routine returns Empty
232 -- if no such state is found.
234 function Find_Related_Context
236 Do_Checks
: Boolean := False) return Node_Id
;
237 -- Subsidiary to the analysis of pragmas
240 -- Constant_After_Elaboration
244 -- Find the first source declaration or statement found while traversing
245 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
246 -- set, the routine reports duplicate pragmas. The routine returns Empty
247 -- when reaching the start of the node chain.
249 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
250 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
251 -- original one, following the renaming chain) is returned. Otherwise the
252 -- entity is returned unchanged. Should be in Einfo???
254 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
255 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
256 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
257 -- value of type SPARK_Mode_Type.
259 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
260 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
261 -- Determine whether dependency clause Clause is surrounded by extra
262 -- parentheses. If this is the case, issue an error message.
264 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
265 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
266 -- pragma Depends. Determine whether the type of dependency item Item is
267 -- tagged, unconstrained array, unconstrained record or a record with at
268 -- least one unconstrained component.
270 procedure Record_Possible_Body_Reference
271 (State_Id
: Entity_Id
;
273 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
274 -- Global. Given an abstract state denoted by State_Id and a reference Ref
275 -- to it, determine whether the reference appears in a package body that
276 -- will eventually refine the state. If this is the case, record the
277 -- reference for future checks (see Analyze_Refined_State_In_Decls).
279 procedure Resolve_State
(N
: Node_Id
);
280 -- Handle the overloading of state names by functions. When N denotes a
281 -- function, this routine finds the corresponding state and sets the entity
282 -- of N to that of the state.
284 procedure Rewrite_Assertion_Kind
286 From_Policy
: Boolean := False);
287 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
288 -- then it is rewritten as an identifier with the corresponding special
289 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
290 -- and Check_Policy. If the names are Precondition or Postcondition, this
291 -- combination is deprecated in favor of Assertion_Policy and Ada2012
292 -- Aspect names. The parameter From_Policy indicates that the pragma
293 -- is the old non-standard Check_Policy and not a rewritten pragma.
295 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
296 -- Place semantic information on the argument of an Elaborate/Elaborate_All
297 -- pragma. Entity name for unit and its parents is taken from item in
298 -- previous with_clause that mentions the unit.
300 Dummy
: Integer := 0;
301 pragma Volatile
(Dummy
);
302 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
305 pragma No_Inline
(ip
);
306 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
307 -- is just to help debugging the front end. If a pragma Inspection_Point
308 -- is added to a source program, then breaking on ip will get you to that
309 -- point in the program.
312 pragma No_Inline
(rv
);
313 -- This is a dummy function called by the processing for pragma Reviewable.
314 -- It is there for assisting front end debugging. By placing a Reviewable
315 -- pragma in the source program, a breakpoint on rv catches this place in
316 -- the source, allowing convenient stepping to the point of interest.
318 -------------------------------
319 -- Adjust_External_Name_Case --
320 -------------------------------
322 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
326 -- Adjust case of literal if required
328 if Opt
.External_Name_Exp_Casing
= As_Is
then
332 -- Copy existing string
338 for J
in 1 .. String_Length
(Strval
(N
)) loop
339 CC
:= Get_String_Char
(Strval
(N
), J
);
341 if Opt
.External_Name_Exp_Casing
= Uppercase
342 and then CC
>= Get_Char_Code
('a')
343 and then CC
<= Get_Char_Code
('z')
345 Store_String_Char
(CC
- 32);
347 elsif Opt
.External_Name_Exp_Casing
= Lowercase
348 and then CC
>= Get_Char_Code
('A')
349 and then CC
<= Get_Char_Code
('Z')
351 Store_String_Char
(CC
+ 32);
354 Store_String_Char
(CC
);
359 Make_String_Literal
(Sloc
(N
),
360 Strval
=> End_String
);
362 end Adjust_External_Name_Case
;
364 -----------------------------------------
365 -- Analyze_Contract_Cases_In_Decl_Part --
366 -----------------------------------------
368 -- WARNING: This routine manages Ghost regions. Return statements must be
369 -- replaced by gotos which jump to the end of the routine and restore the
372 procedure Analyze_Contract_Cases_In_Decl_Part
374 Freeze_Id
: Entity_Id
:= Empty
)
376 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
377 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
379 Others_Seen
: Boolean := False;
380 -- This flag is set when an "others" choice is encountered. It is used
381 -- to detect multiple illegal occurrences of "others".
383 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
384 -- Verify the legality of a single contract case
386 ---------------------------
387 -- Analyze_Contract_Case --
388 ---------------------------
390 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
391 Case_Guard
: Node_Id
;
394 Extra_Guard
: Node_Id
;
397 if Nkind
(CCase
) = N_Component_Association
then
398 Case_Guard
:= First
(Choices
(CCase
));
399 Conseq
:= Expression
(CCase
);
401 -- Each contract case must have exactly one case guard
403 Extra_Guard
:= Next
(Case_Guard
);
405 if Present
(Extra_Guard
) then
407 ("contract case must have exactly one case guard",
411 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
413 if Nkind
(Case_Guard
) = N_Others_Choice
then
416 ("only one others choice allowed in contract cases",
422 elsif Others_Seen
then
424 ("others must be the last choice in contract cases", N
);
427 -- Preanalyze the case guard and consequence
429 if Nkind
(Case_Guard
) /= N_Others_Choice
then
430 Errors
:= Serious_Errors_Detected
;
431 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
433 -- Emit a clarification message when the case guard contains
434 -- at least one undefined reference, possibly due to contract
437 if Errors
/= Serious_Errors_Detected
438 and then Present
(Freeze_Id
)
439 and then Has_Undefined_Reference
(Case_Guard
)
441 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
445 Errors
:= Serious_Errors_Detected
;
446 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
448 -- Emit a clarification message when the consequence contains
449 -- at least one undefined reference, possibly due to contract
452 if Errors
/= Serious_Errors_Detected
453 and then Present
(Freeze_Id
)
454 and then Has_Undefined_Reference
(Conseq
)
456 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
459 -- The contract case is malformed
462 Error_Msg_N
("wrong syntax in contract case", CCase
);
464 end Analyze_Contract_Case
;
468 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
470 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
471 -- Save the Ghost mode to restore on exit
474 Restore_Scope
: Boolean := False;
476 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
479 -- Do not analyze the pragma multiple times
481 if Is_Analyzed_Pragma
(N
) then
485 -- Set the Ghost mode in effect from the pragma. Due to the delayed
486 -- analysis of the pragma, the Ghost mode at point of declaration and
487 -- point of analysis may not necessarily be the same. Use the mode in
488 -- effect at the point of declaration.
492 -- Single and multiple contract cases must appear in aggregate form. If
493 -- this is not the case, then either the parser of the analysis of the
494 -- pragma failed to produce an aggregate.
496 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
498 if Present
(Component_Associations
(CCases
)) then
500 -- Ensure that the formal parameters are visible when analyzing all
501 -- clauses. This falls out of the general rule of aspects pertaining
502 -- to subprogram declarations.
504 if not In_Open_Scopes
(Spec_Id
) then
505 Restore_Scope
:= True;
506 Push_Scope
(Spec_Id
);
508 if Is_Generic_Subprogram
(Spec_Id
) then
509 Install_Generic_Formals
(Spec_Id
);
511 Install_Formals
(Spec_Id
);
515 CCase
:= First
(Component_Associations
(CCases
));
516 while Present
(CCase
) loop
517 Analyze_Contract_Case
(CCase
);
521 if Restore_Scope
then
525 -- Currently it is not possible to inline pre/postconditions on a
526 -- subprogram subject to pragma Inline_Always.
528 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
530 -- Otherwise the pragma is illegal
533 Error_Msg_N
("wrong syntax for constract cases", N
);
536 Set_Is_Analyzed_Pragma
(N
);
538 Restore_Ghost_Mode
(Saved_GM
);
539 end Analyze_Contract_Cases_In_Decl_Part
;
541 ----------------------------------
542 -- Analyze_Depends_In_Decl_Part --
543 ----------------------------------
545 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
546 Loc
: constant Source_Ptr
:= Sloc
(N
);
547 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
548 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
550 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
551 -- A list containing the entities of all the inputs processed so far.
552 -- The list is populated with unique entities because the same input
553 -- may appear in multiple input lists.
555 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
556 -- A list containing the entities of all the outputs processed so far.
557 -- The list is populated with unique entities because output items are
558 -- unique in a dependence relation.
560 Constits_Seen
: Elist_Id
:= No_Elist
;
561 -- A list containing the entities of all constituents processed so far.
562 -- It aids in detecting illegal usage of a state and a corresponding
563 -- constituent in pragma [Refinde_]Depends.
565 Global_Seen
: Boolean := False;
566 -- A flag set when pragma Global has been processed
568 Null_Output_Seen
: Boolean := False;
569 -- A flag used to track the legality of a null output
571 Result_Seen
: Boolean := False;
572 -- A flag set when Spec_Id'Result is processed
574 States_Seen
: Elist_Id
:= No_Elist
;
575 -- A list containing the entities of all states processed so far. It
576 -- helps in detecting illegal usage of a state and a corresponding
577 -- constituent in pragma [Refined_]Depends.
579 Subp_Inputs
: Elist_Id
:= No_Elist
;
580 Subp_Outputs
: Elist_Id
:= No_Elist
;
581 -- Two lists containing the full set of inputs and output of the related
582 -- subprograms. Note that these lists contain both nodes and entities.
584 Task_Input_Seen
: Boolean := False;
585 Task_Output_Seen
: Boolean := False;
586 -- Flags used to track the implicit dependence of a task unit on itself
588 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
589 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
590 -- to the name buffer. The individual kinds are as follows:
591 -- E_Abstract_State - "state"
592 -- E_Constant - "constant"
593 -- E_Generic_In_Out_Parameter - "generic parameter"
594 -- E_Generic_In_Parameter - "generic parameter"
595 -- E_In_Parameter - "parameter"
596 -- E_In_Out_Parameter - "parameter"
597 -- E_Loop_Parameter - "loop parameter"
598 -- E_Out_Parameter - "parameter"
599 -- E_Protected_Type - "current instance of protected type"
600 -- E_Task_Type - "current instance of task type"
601 -- E_Variable - "global"
603 procedure Analyze_Dependency_Clause
606 -- Verify the legality of a single dependency clause. Flag Is_Last
607 -- denotes whether Clause is the last clause in the relation.
609 procedure Check_Function_Return
;
610 -- Verify that Funtion'Result appears as one of the outputs
611 -- (SPARK RM 6.1.5(10)).
618 -- Ensure that an item fulfills its designated input and/or output role
619 -- as specified by pragma Global (if any) or the enclosing context. If
620 -- this is not the case, emit an error. Item and Item_Id denote the
621 -- attributes of an item. Flag Is_Input should be set when item comes
622 -- from an input list. Flag Self_Ref should be set when the item is an
623 -- output and the dependency clause has operator "+".
625 procedure Check_Usage
626 (Subp_Items
: Elist_Id
;
627 Used_Items
: Elist_Id
;
629 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
630 -- error if this is not the case.
632 procedure Normalize_Clause
(Clause
: Node_Id
);
633 -- Remove a self-dependency "+" from the input list of a clause
635 -----------------------------
636 -- Add_Item_To_Name_Buffer --
637 -----------------------------
639 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
641 if Ekind
(Item_Id
) = E_Abstract_State
then
642 Add_Str_To_Name_Buffer
("state");
644 elsif Ekind
(Item_Id
) = E_Constant
then
645 Add_Str_To_Name_Buffer
("constant");
647 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
648 E_Generic_In_Parameter
)
650 Add_Str_To_Name_Buffer
("generic parameter");
652 elsif Is_Formal
(Item_Id
) then
653 Add_Str_To_Name_Buffer
("parameter");
655 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
656 Add_Str_To_Name_Buffer
("loop parameter");
658 elsif Ekind
(Item_Id
) = E_Protected_Type
659 or else Is_Single_Protected_Object
(Item_Id
)
661 Add_Str_To_Name_Buffer
("current instance of protected type");
663 elsif Ekind
(Item_Id
) = E_Task_Type
664 or else Is_Single_Task_Object
(Item_Id
)
666 Add_Str_To_Name_Buffer
("current instance of task type");
668 elsif Ekind
(Item_Id
) = E_Variable
then
669 Add_Str_To_Name_Buffer
("global");
671 -- The routine should not be called with non-SPARK items
676 end Add_Item_To_Name_Buffer
;
678 -------------------------------
679 -- Analyze_Dependency_Clause --
680 -------------------------------
682 procedure Analyze_Dependency_Clause
686 procedure Analyze_Input_List
(Inputs
: Node_Id
);
687 -- Verify the legality of a single input list
689 procedure Analyze_Input_Output
694 Seen
: in out Elist_Id
;
695 Null_Seen
: in out Boolean;
696 Non_Null_Seen
: in out Boolean);
697 -- Verify the legality of a single input or output item. Flag
698 -- Is_Input should be set whenever Item is an input, False when it
699 -- denotes an output. Flag Self_Ref should be set when the item is an
700 -- output and the dependency clause has a "+". Flag Top_Level should
701 -- be set whenever Item appears immediately within an input or output
702 -- list. Seen is a collection of all abstract states, objects and
703 -- formals processed so far. Flag Null_Seen denotes whether a null
704 -- input or output has been encountered. Flag Non_Null_Seen denotes
705 -- whether a non-null input or output has been encountered.
707 ------------------------
708 -- Analyze_Input_List --
709 ------------------------
711 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
712 Inputs_Seen
: Elist_Id
:= No_Elist
;
713 -- A list containing the entities of all inputs that appear in the
714 -- current input list.
716 Non_Null_Input_Seen
: Boolean := False;
717 Null_Input_Seen
: Boolean := False;
718 -- Flags used to check the legality of an input list
723 -- Multiple inputs appear as an aggregate
725 if Nkind
(Inputs
) = N_Aggregate
then
726 if Present
(Component_Associations
(Inputs
)) then
728 ("nested dependency relations not allowed", Inputs
);
730 elsif Present
(Expressions
(Inputs
)) then
731 Input
:= First
(Expressions
(Inputs
));
732 while Present
(Input
) loop
739 Null_Seen
=> Null_Input_Seen
,
740 Non_Null_Seen
=> Non_Null_Input_Seen
);
745 -- Syntax error, always report
748 Error_Msg_N
("malformed input dependency list", Inputs
);
751 -- Process a solitary input
760 Null_Seen
=> Null_Input_Seen
,
761 Non_Null_Seen
=> Non_Null_Input_Seen
);
764 -- Detect an illegal dependency clause of the form
768 if Null_Output_Seen
and then Null_Input_Seen
then
770 ("null dependency clause cannot have a null input list",
773 end Analyze_Input_List
;
775 --------------------------
776 -- Analyze_Input_Output --
777 --------------------------
779 procedure Analyze_Input_Output
784 Seen
: in out Elist_Id
;
785 Null_Seen
: in out Boolean;
786 Non_Null_Seen
: in out Boolean)
788 procedure Current_Task_Instance_Seen
;
789 -- Set the appropriate global flag when the current instance of a
790 -- task unit is encountered.
792 --------------------------------
793 -- Current_Task_Instance_Seen --
794 --------------------------------
796 procedure Current_Task_Instance_Seen
is
799 Task_Input_Seen
:= True;
801 Task_Output_Seen
:= True;
803 end Current_Task_Instance_Seen
;
807 Is_Output
: constant Boolean := not Is_Input
;
811 -- Start of processing for Analyze_Input_Output
814 -- Multiple input or output items appear as an aggregate
816 if Nkind
(Item
) = N_Aggregate
then
817 if not Top_Level
then
818 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
820 elsif Present
(Component_Associations
(Item
)) then
822 ("nested dependency relations not allowed", Item
);
824 -- Recursively analyze the grouped items
826 elsif Present
(Expressions
(Item
)) then
827 Grouped
:= First
(Expressions
(Item
));
828 while Present
(Grouped
) loop
831 Is_Input
=> Is_Input
,
832 Self_Ref
=> Self_Ref
,
835 Null_Seen
=> Null_Seen
,
836 Non_Null_Seen
=> Non_Null_Seen
);
841 -- Syntax error, always report
844 Error_Msg_N
("malformed dependency list", Item
);
847 -- Process attribute 'Result in the context of a dependency clause
849 elsif Is_Attribute_Result
(Item
) then
850 Non_Null_Seen
:= True;
854 -- Attribute 'Result is allowed to appear on the output side of
855 -- a dependency clause (SPARK RM 6.1.5(6)).
858 SPARK_Msg_N
("function result cannot act as input", Item
);
862 ("cannot mix null and non-null dependency items", Item
);
868 -- Detect multiple uses of null in a single dependency list or
869 -- throughout the whole relation. Verify the placement of a null
870 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
872 elsif Nkind
(Item
) = N_Null
then
875 ("multiple null dependency relations not allowed", Item
);
877 elsif Non_Null_Seen
then
879 ("cannot mix null and non-null dependency items", Item
);
887 ("null output list must be the last clause in a "
888 & "dependency relation", Item
);
890 -- Catch a useless dependence of the form:
895 ("useless dependence, null depends on itself", Item
);
903 Non_Null_Seen
:= True;
906 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
910 Resolve_State
(Item
);
912 -- Find the entity of the item. If this is a renaming, climb
913 -- the renaming chain to reach the root object. Renamings of
914 -- non-entire objects do not yield an entity (Empty).
916 Item_Id
:= Entity_Of
(Item
);
918 if Present
(Item_Id
) then
922 if Ekind_In
(Item_Id
, E_Constant
, E_Loop_Parameter
)
925 -- Current instances of concurrent types
927 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
932 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
933 E_Generic_In_Parameter
,
941 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
943 -- The item denotes a concurrent type. Note that single
944 -- protected/task types are not considered here because
945 -- they behave as objects in the context of pragma
946 -- [Refined_]Depends.
948 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
950 -- This use is legal as long as the concurrent type is
951 -- the current instance of an enclosing type.
953 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
955 -- The dependence of a task unit on itself is
956 -- implicit and may or may not be explicitly
957 -- specified (SPARK RM 6.1.4).
959 if Ekind
(Item_Id
) = E_Task_Type
then
960 Current_Task_Instance_Seen
;
963 -- Otherwise this is not the current instance
967 ("invalid use of subtype mark in dependency "
971 -- The dependency of a task unit on itself is implicit
972 -- and may or may not be explicitly specified
975 elsif Is_Single_Task_Object
(Item_Id
)
976 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
978 Current_Task_Instance_Seen
;
981 -- Ensure that the item fulfills its role as input and/or
982 -- output as specified by pragma Global or the enclosing
985 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
987 -- Detect multiple uses of the same state, variable or
988 -- formal parameter. If this is not the case, add the
989 -- item to the list of processed relations.
991 if Contains
(Seen
, Item_Id
) then
993 ("duplicate use of item &", Item
, Item_Id
);
995 Append_New_Elmt
(Item_Id
, Seen
);
998 -- Detect illegal use of an input related to a null
999 -- output. Such input items cannot appear in other
1000 -- input lists (SPARK RM 6.1.5(13)).
1003 and then Null_Output_Seen
1004 and then Contains
(All_Inputs_Seen
, Item_Id
)
1007 ("input of a null output list cannot appear in "
1008 & "multiple input lists", Item
);
1011 -- Add an input or a self-referential output to the list
1012 -- of all processed inputs.
1014 if Is_Input
or else Self_Ref
then
1015 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1018 -- State related checks (SPARK RM 6.1.5(3))
1020 if Ekind
(Item_Id
) = E_Abstract_State
then
1022 -- Package and subprogram bodies are instantiated
1023 -- individually in a separate compiler pass. Due to
1024 -- this mode of instantiation, the refinement of a
1025 -- state may no longer be visible when a subprogram
1026 -- body contract is instantiated. Since the generic
1027 -- template is legal, do not perform this check in
1028 -- the instance to circumvent this oddity.
1030 if Is_Generic_Instance
(Spec_Id
) then
1033 -- An abstract state with visible refinement cannot
1034 -- appear in pragma [Refined_]Depends as its place
1035 -- must be taken by some of its constituents
1036 -- (SPARK RM 6.1.4(7)).
1038 elsif Has_Visible_Refinement
(Item_Id
) then
1040 ("cannot mention state & in dependence relation",
1042 SPARK_Msg_N
("\use its constituents instead", Item
);
1045 -- If the reference to the abstract state appears in
1046 -- an enclosing package body that will eventually
1047 -- refine the state, record the reference for future
1051 Record_Possible_Body_Reference
1052 (State_Id
=> Item_Id
,
1057 -- When the item renames an entire object, replace the
1058 -- item with a reference to the object.
1060 if Entity
(Item
) /= Item_Id
then
1062 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1066 -- Add the entity of the current item to the list of
1069 if Ekind
(Item_Id
) = E_Abstract_State
then
1070 Append_New_Elmt
(Item_Id
, States_Seen
);
1072 -- The variable may eventually become a constituent of a
1073 -- single protected/task type. Record the reference now
1074 -- and verify its legality when analyzing the contract of
1075 -- the variable (SPARK RM 9.3).
1077 elsif Ekind
(Item_Id
) = E_Variable
then
1078 Record_Possible_Part_Of_Reference
1083 if Ekind_In
(Item_Id
, E_Abstract_State
,
1086 and then Present
(Encapsulating_State
(Item_Id
))
1088 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1091 -- All other input/output items are illegal
1092 -- (SPARK RM 6.1.5(1)).
1096 ("item must denote parameter, variable, state or "
1097 & "current instance of concurrent type", Item
);
1100 -- All other input/output items are illegal
1101 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1105 ("item must denote parameter, variable, state or current "
1106 & "instance of concurrent type", Item
);
1109 end Analyze_Input_Output
;
1117 Non_Null_Output_Seen
: Boolean := False;
1118 -- Flag used to check the legality of an output list
1120 -- Start of processing for Analyze_Dependency_Clause
1123 Inputs
:= Expression
(Clause
);
1126 -- An input list with a self-dependency appears as operator "+" where
1127 -- the actuals inputs are the right operand.
1129 if Nkind
(Inputs
) = N_Op_Plus
then
1130 Inputs
:= Right_Opnd
(Inputs
);
1134 -- Process the output_list of a dependency_clause
1136 Output
:= First
(Choices
(Clause
));
1137 while Present
(Output
) loop
1138 Analyze_Input_Output
1141 Self_Ref
=> Self_Ref
,
1143 Seen
=> All_Outputs_Seen
,
1144 Null_Seen
=> Null_Output_Seen
,
1145 Non_Null_Seen
=> Non_Null_Output_Seen
);
1150 -- Process the input_list of a dependency_clause
1152 Analyze_Input_List
(Inputs
);
1153 end Analyze_Dependency_Clause
;
1155 ---------------------------
1156 -- Check_Function_Return --
1157 ---------------------------
1159 procedure Check_Function_Return
is
1161 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1162 and then not Result_Seen
1165 ("result of & must appear in exactly one output list",
1168 end Check_Function_Return
;
1174 procedure Check_Role
1176 Item_Id
: Entity_Id
;
1181 (Item_Is_Input
: out Boolean;
1182 Item_Is_Output
: out Boolean);
1183 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1184 -- Item_Is_Output are set depending on the role.
1186 procedure Role_Error
1187 (Item_Is_Input
: Boolean;
1188 Item_Is_Output
: Boolean);
1189 -- Emit an error message concerning the incorrect use of Item in
1190 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1191 -- denote whether the item is an input and/or an output.
1198 (Item_Is_Input
: out Boolean;
1199 Item_Is_Output
: out Boolean)
1202 case Ekind
(Item_Id
) is
1206 when E_Abstract_State
=>
1208 -- When pragma Global is present it determines the mode of
1209 -- the abstract state.
1212 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1213 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1215 -- Otherwise the state has a default IN OUT mode, because it
1216 -- behaves as a variable.
1219 Item_Is_Input
:= True;
1220 Item_Is_Output
:= True;
1223 -- Constants and IN parameters
1226 | E_Generic_In_Parameter
1230 -- When pragma Global is present it determines the mode
1231 -- of constant objects as inputs (and such objects cannot
1232 -- appear as outputs in the Global contract).
1235 Item_Is_Input
:= Appears_In
(Subp_Inputs
, Item_Id
);
1237 Item_Is_Input
:= True;
1240 Item_Is_Output
:= False;
1242 -- Variables and IN OUT parameters
1244 when E_Generic_In_Out_Parameter
1245 | E_In_Out_Parameter
1248 -- When pragma Global is present it determines the mode of
1253 -- A variable has mode IN when its type is unconstrained
1254 -- or tagged because array bounds, discriminants or tags
1258 Appears_In
(Subp_Inputs
, Item_Id
)
1259 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1261 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1263 -- Otherwise the variable has a default IN OUT mode
1266 Item_Is_Input
:= True;
1267 Item_Is_Output
:= True;
1270 when E_Out_Parameter
=>
1272 -- An OUT parameter of the related subprogram; it cannot
1273 -- appear in Global.
1275 if Scope
(Item_Id
) = Spec_Id
then
1277 -- The parameter has mode IN if its type is unconstrained
1278 -- or tagged because array bounds, discriminants or tags
1282 Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1284 Item_Is_Output
:= True;
1286 -- An OUT parameter of an enclosing subprogram; it can
1287 -- appear in Global and behaves as a read-write variable.
1290 -- When pragma Global is present it determines the mode
1295 -- A variable has mode IN when its type is
1296 -- unconstrained or tagged because array
1297 -- bounds, discriminants or tags can be read.
1300 Appears_In
(Subp_Inputs
, Item_Id
)
1301 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1303 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1305 -- Otherwise the variable has a default IN OUT mode
1308 Item_Is_Input
:= True;
1309 Item_Is_Output
:= True;
1315 when E_Protected_Type
=>
1318 -- A variable has mode IN when its type is unconstrained
1319 -- or tagged because array bounds, discriminants or tags
1323 Appears_In
(Subp_Inputs
, Item_Id
)
1324 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1326 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1329 -- A protected type acts as a formal parameter of mode IN
1330 -- when it applies to a protected function.
1332 if Ekind
(Spec_Id
) = E_Function
then
1333 Item_Is_Input
:= True;
1334 Item_Is_Output
:= False;
1336 -- Otherwise the protected type acts as a formal of mode
1340 Item_Is_Input
:= True;
1341 Item_Is_Output
:= True;
1349 -- When pragma Global is present it determines the mode of
1354 Appears_In
(Subp_Inputs
, Item_Id
)
1355 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
);
1357 Item_Is_Output
:= Appears_In
(Subp_Outputs
, Item_Id
);
1359 -- Otherwise task types act as IN OUT parameters
1362 Item_Is_Input
:= True;
1363 Item_Is_Output
:= True;
1367 raise Program_Error
;
1375 procedure Role_Error
1376 (Item_Is_Input
: Boolean;
1377 Item_Is_Output
: Boolean)
1379 Error_Msg
: Name_Id
;
1384 -- When the item is not part of the input and the output set of
1385 -- the related subprogram, then it appears as extra in pragma
1386 -- [Refined_]Depends.
1388 if not Item_Is_Input
and then not Item_Is_Output
then
1389 Add_Item_To_Name_Buffer
(Item_Id
);
1390 Add_Str_To_Name_Buffer
1391 (" & cannot appear in dependence relation");
1393 Error_Msg
:= Name_Find
;
1394 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1396 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1398 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1399 & "set of subprogram %"), Item
, Item_Id
);
1401 -- The mode of the item and its role in pragma [Refined_]Depends
1402 -- are in conflict. Construct a detailed message explaining the
1403 -- illegality (SPARK RM 6.1.5(5-6)).
1406 if Item_Is_Input
then
1407 Add_Str_To_Name_Buffer
("read-only");
1409 Add_Str_To_Name_Buffer
("write-only");
1412 Add_Char_To_Name_Buffer
(' ');
1413 Add_Item_To_Name_Buffer
(Item_Id
);
1414 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1416 if Item_Is_Input
then
1417 Add_Str_To_Name_Buffer
("output");
1419 Add_Str_To_Name_Buffer
("input");
1422 Add_Str_To_Name_Buffer
(" in dependence relation");
1423 Error_Msg
:= Name_Find
;
1424 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1430 Item_Is_Input
: Boolean;
1431 Item_Is_Output
: Boolean;
1433 -- Start of processing for Check_Role
1436 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1441 if not Item_Is_Input
then
1442 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1445 -- Self-referential item
1448 if not Item_Is_Input
or else not Item_Is_Output
then
1449 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1454 elsif not Item_Is_Output
then
1455 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1463 procedure Check_Usage
1464 (Subp_Items
: Elist_Id
;
1465 Used_Items
: Elist_Id
;
1468 procedure Usage_Error
(Item_Id
: Entity_Id
);
1469 -- Emit an error concerning the illegal usage of an item
1475 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1476 Error_Msg
: Name_Id
;
1483 -- Unconstrained and tagged items are not part of the explicit
1484 -- input set of the related subprogram, they do not have to be
1485 -- present in a dependence relation and should not be flagged
1486 -- (SPARK RM 6.1.5(5)).
1488 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1491 Add_Item_To_Name_Buffer
(Item_Id
);
1492 Add_Str_To_Name_Buffer
1493 (" & is missing from input dependence list");
1495 Error_Msg
:= Name_Find
;
1496 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1498 ("\add `null ='> &` dependency to ignore this input",
1502 -- Output case (SPARK RM 6.1.5(10))
1507 Add_Item_To_Name_Buffer
(Item_Id
);
1508 Add_Str_To_Name_Buffer
1509 (" & is missing from output dependence list");
1511 Error_Msg
:= Name_Find
;
1512 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1520 Item_Id
: Entity_Id
;
1522 -- Start of processing for Check_Usage
1525 if No
(Subp_Items
) then
1529 -- Each input or output of the subprogram must appear in a dependency
1532 Elmt
:= First_Elmt
(Subp_Items
);
1533 while Present
(Elmt
) loop
1534 Item
:= Node
(Elmt
);
1536 if Nkind
(Item
) = N_Defining_Identifier
then
1539 Item_Id
:= Entity_Of
(Item
);
1542 -- The item does not appear in a dependency
1544 if Present
(Item_Id
)
1545 and then not Contains
(Used_Items
, Item_Id
)
1547 if Is_Formal
(Item_Id
) then
1548 Usage_Error
(Item_Id
);
1550 -- The current instance of a protected type behaves as a formal
1551 -- parameter (SPARK RM 6.1.4).
1553 elsif Ekind
(Item_Id
) = E_Protected_Type
1554 or else Is_Single_Protected_Object
(Item_Id
)
1556 Usage_Error
(Item_Id
);
1558 -- The current instance of a task type behaves as a formal
1559 -- parameter (SPARK RM 6.1.4).
1561 elsif Ekind
(Item_Id
) = E_Task_Type
1562 or else Is_Single_Task_Object
(Item_Id
)
1564 -- The dependence of a task unit on itself is implicit and
1565 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1566 -- Emit an error if only one input/output is present.
1568 if Task_Input_Seen
/= Task_Output_Seen
then
1569 Usage_Error
(Item_Id
);
1572 -- States and global objects are not used properly only when
1573 -- the subprogram is subject to pragma Global.
1575 elsif Global_Seen
then
1576 Usage_Error
(Item_Id
);
1584 ----------------------
1585 -- Normalize_Clause --
1586 ----------------------
1588 procedure Normalize_Clause
(Clause
: Node_Id
) is
1589 procedure Create_Or_Modify_Clause
1595 Multiple
: Boolean);
1596 -- Create a brand new clause to represent the self-reference or
1597 -- modify the input and/or output lists of an existing clause. Output
1598 -- denotes a self-referencial output. Outputs is the output list of a
1599 -- clause. Inputs is the input list of a clause. After denotes the
1600 -- clause after which the new clause is to be inserted. Flag In_Place
1601 -- should be set when normalizing the last output of an output list.
1602 -- Flag Multiple should be set when Output comes from a list with
1605 -----------------------------
1606 -- Create_Or_Modify_Clause --
1607 -----------------------------
1609 procedure Create_Or_Modify_Clause
1617 procedure Propagate_Output
1620 -- Handle the various cases of output propagation to the input
1621 -- list. Output denotes a self-referencial output item. Inputs
1622 -- is the input list of a clause.
1624 ----------------------
1625 -- Propagate_Output --
1626 ----------------------
1628 procedure Propagate_Output
1632 function In_Input_List
1634 Inputs
: List_Id
) return Boolean;
1635 -- Determine whether a particulat item appears in the input
1636 -- list of a clause.
1642 function In_Input_List
1644 Inputs
: List_Id
) return Boolean
1649 Elmt
:= First
(Inputs
);
1650 while Present
(Elmt
) loop
1651 if Entity_Of
(Elmt
) = Item
then
1663 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1666 -- Start of processing for Propagate_Output
1669 -- The clause is of the form:
1671 -- (Output =>+ null)
1673 -- Remove null input and replace it with a copy of the output:
1675 -- (Output => Output)
1677 if Nkind
(Inputs
) = N_Null
then
1678 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1680 -- The clause is of the form:
1682 -- (Output =>+ (Input1, ..., InputN))
1684 -- Determine whether the output is not already mentioned in the
1685 -- input list and if not, add it to the list of inputs:
1687 -- (Output => (Output, Input1, ..., InputN))
1689 elsif Nkind
(Inputs
) = N_Aggregate
then
1690 Grouped
:= Expressions
(Inputs
);
1692 if not In_Input_List
1696 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1699 -- The clause is of the form:
1701 -- (Output =>+ Input)
1703 -- If the input does not mention the output, group the two
1706 -- (Output => (Output, Input))
1708 elsif Entity_Of
(Inputs
) /= Output_Id
then
1710 Make_Aggregate
(Loc
,
1711 Expressions
=> New_List
(
1712 New_Copy_Tree
(Output
),
1713 New_Copy_Tree
(Inputs
))));
1715 end Propagate_Output
;
1719 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1720 New_Clause
: Node_Id
;
1722 -- Start of processing for Create_Or_Modify_Clause
1725 -- A null output depending on itself does not require any
1728 if Nkind
(Output
) = N_Null
then
1731 -- A function result cannot depend on itself because it cannot
1732 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1734 elsif Is_Attribute_Result
(Output
) then
1735 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1739 -- When performing the transformation in place, simply add the
1740 -- output to the list of inputs (if not already there). This
1741 -- case arises when dealing with the last output of an output
1742 -- list. Perform the normalization in place to avoid generating
1743 -- a malformed tree.
1746 Propagate_Output
(Output
, Inputs
);
1748 -- A list with multiple outputs is slowly trimmed until only
1749 -- one element remains. When this happens, replace aggregate
1750 -- with the element itself.
1754 Rewrite
(Outputs
, Output
);
1760 -- Unchain the output from its output list as it will appear in
1761 -- a new clause. Note that we cannot simply rewrite the output
1762 -- as null because this will violate the semantics of pragma
1767 -- Generate a new clause of the form:
1768 -- (Output => Inputs)
1771 Make_Component_Association
(Loc
,
1772 Choices
=> New_List
(Output
),
1773 Expression
=> New_Copy_Tree
(Inputs
));
1775 -- The new clause contains replicated content that has already
1776 -- been analyzed. There is not need to reanalyze or renormalize
1779 Set_Analyzed
(New_Clause
);
1782 (Output
=> First
(Choices
(New_Clause
)),
1783 Inputs
=> Expression
(New_Clause
));
1785 Insert_After
(After
, New_Clause
);
1787 end Create_Or_Modify_Clause
;
1791 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1793 Last_Output
: Node_Id
;
1794 Next_Output
: Node_Id
;
1797 -- Start of processing for Normalize_Clause
1800 -- A self-dependency appears as operator "+". Remove the "+" from the
1801 -- tree by moving the real inputs to their proper place.
1803 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1804 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1805 Inputs
:= Expression
(Clause
);
1807 -- Multiple outputs appear as an aggregate
1809 if Nkind
(Outputs
) = N_Aggregate
then
1810 Last_Output
:= Last
(Expressions
(Outputs
));
1812 Output
:= First
(Expressions
(Outputs
));
1813 while Present
(Output
) loop
1815 -- Normalization may remove an output from its list,
1816 -- preserve the subsequent output now.
1818 Next_Output
:= Next
(Output
);
1820 Create_Or_Modify_Clause
1825 In_Place
=> Output
= Last_Output
,
1828 Output
:= Next_Output
;
1834 Create_Or_Modify_Clause
1843 end Normalize_Clause
;
1847 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1848 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1852 Last_Clause
: Node_Id
;
1853 Restore_Scope
: Boolean := False;
1855 -- Start of processing for Analyze_Depends_In_Decl_Part
1858 -- Do not analyze the pragma multiple times
1860 if Is_Analyzed_Pragma
(N
) then
1864 -- Empty dependency list
1866 if Nkind
(Deps
) = N_Null
then
1868 -- Gather all states, objects and formal parameters that the
1869 -- subprogram may depend on. These items are obtained from the
1870 -- parameter profile or pragma [Refined_]Global (if available).
1872 Collect_Subprogram_Inputs_Outputs
1873 (Subp_Id
=> Subp_Id
,
1874 Subp_Inputs
=> Subp_Inputs
,
1875 Subp_Outputs
=> Subp_Outputs
,
1876 Global_Seen
=> Global_Seen
);
1878 -- Verify that every input or output of the subprogram appear in a
1881 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1882 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1883 Check_Function_Return
;
1885 -- Dependency clauses appear as component associations of an aggregate
1887 elsif Nkind
(Deps
) = N_Aggregate
then
1889 -- Do not attempt to perform analysis of a syntactically illegal
1890 -- clause as this will lead to misleading errors.
1892 if Has_Extra_Parentheses
(Deps
) then
1896 if Present
(Component_Associations
(Deps
)) then
1897 Last_Clause
:= Last
(Component_Associations
(Deps
));
1899 -- Gather all states, objects and formal parameters that the
1900 -- subprogram may depend on. These items are obtained from the
1901 -- parameter profile or pragma [Refined_]Global (if available).
1903 Collect_Subprogram_Inputs_Outputs
1904 (Subp_Id
=> Subp_Id
,
1905 Subp_Inputs
=> Subp_Inputs
,
1906 Subp_Outputs
=> Subp_Outputs
,
1907 Global_Seen
=> Global_Seen
);
1909 -- When pragma [Refined_]Depends appears on a single concurrent
1910 -- type, it is relocated to the anonymous object.
1912 if Is_Single_Concurrent_Object
(Spec_Id
) then
1915 -- Ensure that the formal parameters are visible when analyzing
1916 -- all clauses. This falls out of the general rule of aspects
1917 -- pertaining to subprogram declarations.
1919 elsif not In_Open_Scopes
(Spec_Id
) then
1920 Restore_Scope
:= True;
1921 Push_Scope
(Spec_Id
);
1923 if Ekind
(Spec_Id
) = E_Task_Type
then
1924 if Has_Discriminants
(Spec_Id
) then
1925 Install_Discriminants
(Spec_Id
);
1928 elsif Is_Generic_Subprogram
(Spec_Id
) then
1929 Install_Generic_Formals
(Spec_Id
);
1932 Install_Formals
(Spec_Id
);
1936 Clause
:= First
(Component_Associations
(Deps
));
1937 while Present
(Clause
) loop
1938 Errors
:= Serious_Errors_Detected
;
1940 -- The normalization mechanism may create extra clauses that
1941 -- contain replicated input and output names. There is no need
1942 -- to reanalyze them.
1944 if not Analyzed
(Clause
) then
1945 Set_Analyzed
(Clause
);
1947 Analyze_Dependency_Clause
1949 Is_Last
=> Clause
= Last_Clause
);
1952 -- Do not normalize a clause if errors were detected (count
1953 -- of Serious_Errors has increased) because the inputs and/or
1954 -- outputs may denote illegal items. Normalization is disabled
1955 -- in ASIS mode as it alters the tree by introducing new nodes
1956 -- similar to expansion.
1958 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1959 Normalize_Clause
(Clause
);
1965 if Restore_Scope
then
1969 -- Verify that every input or output of the subprogram appear in a
1972 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1973 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1974 Check_Function_Return
;
1976 -- The dependency list is malformed. This is a syntax error, always
1980 Error_Msg_N
("malformed dependency relation", Deps
);
1984 -- The top level dependency relation is malformed. This is a syntax
1985 -- error, always report.
1988 Error_Msg_N
("malformed dependency relation", Deps
);
1992 -- Ensure that a state and a corresponding constituent do not appear
1993 -- together in pragma [Refined_]Depends.
1995 Check_State_And_Constituent_Use
1996 (States
=> States_Seen
,
1997 Constits
=> Constits_Seen
,
2001 Set_Is_Analyzed_Pragma
(N
);
2002 end Analyze_Depends_In_Decl_Part
;
2004 --------------------------------------------
2005 -- Analyze_External_Property_In_Decl_Part --
2006 --------------------------------------------
2008 procedure Analyze_External_Property_In_Decl_Part
2010 Expr_Val
: out Boolean)
2012 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
2013 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
2014 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2020 -- Do not analyze the pragma multiple times
2022 if Is_Analyzed_Pragma
(N
) then
2026 Error_Msg_Name_1
:= Pragma_Name
(N
);
2028 -- An external property pragma must apply to an effectively volatile
2029 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2030 -- The check is performed at the end of the declarative region due to a
2031 -- possible out-of-order arrangement of pragmas:
2034 -- pragma Async_Readers (Obj);
2035 -- pragma Volatile (Obj);
2037 if not Is_Effectively_Volatile
(Obj_Id
) then
2039 ("external property % must apply to a volatile object", N
);
2042 -- Ensure that the Boolean expression (if present) is static. A missing
2043 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2047 if Present
(Arg1
) then
2048 Expr
:= Get_Pragma_Arg
(Arg1
);
2050 if Is_OK_Static_Expression
(Expr
) then
2051 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2055 Set_Is_Analyzed_Pragma
(N
);
2056 end Analyze_External_Property_In_Decl_Part
;
2058 ---------------------------------
2059 -- Analyze_Global_In_Decl_Part --
2060 ---------------------------------
2062 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2063 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2064 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2065 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2067 Constits_Seen
: Elist_Id
:= No_Elist
;
2068 -- A list containing the entities of all constituents processed so far.
2069 -- It aids in detecting illegal usage of a state and a corresponding
2070 -- constituent in pragma [Refinde_]Global.
2072 Seen
: Elist_Id
:= No_Elist
;
2073 -- A list containing the entities of all the items processed so far. It
2074 -- plays a role in detecting distinct entities.
2076 States_Seen
: Elist_Id
:= No_Elist
;
2077 -- A list containing the entities of all states processed so far. It
2078 -- helps in detecting illegal usage of a state and a corresponding
2079 -- constituent in pragma [Refined_]Global.
2081 In_Out_Seen
: Boolean := False;
2082 Input_Seen
: Boolean := False;
2083 Output_Seen
: Boolean := False;
2084 Proof_Seen
: Boolean := False;
2085 -- Flags used to verify the consistency of modes
2087 procedure Analyze_Global_List
2089 Global_Mode
: Name_Id
:= Name_Input
);
2090 -- Verify the legality of a single global list declaration. Global_Mode
2091 -- denotes the current mode in effect.
2093 -------------------------
2094 -- Analyze_Global_List --
2095 -------------------------
2097 procedure Analyze_Global_List
2099 Global_Mode
: Name_Id
:= Name_Input
)
2101 procedure Analyze_Global_Item
2103 Global_Mode
: Name_Id
);
2104 -- Verify the legality of a single global item declaration denoted by
2105 -- Item. Global_Mode denotes the current mode in effect.
2107 procedure Check_Duplicate_Mode
2109 Status
: in out Boolean);
2110 -- Flag Status denotes whether a particular mode has been seen while
2111 -- processing a global list. This routine verifies that Mode is not a
2112 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2114 procedure Check_Mode_Restriction_In_Enclosing_Context
2116 Item_Id
: Entity_Id
);
2117 -- Verify that an item of mode In_Out or Output does not appear as an
2118 -- input in the Global aspect of an enclosing subprogram. If this is
2119 -- the case, emit an error. Item and Item_Id are respectively the
2120 -- item and its entity.
2122 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2123 -- Mode denotes either In_Out or Output. Depending on the kind of the
2124 -- related subprogram, emit an error if those two modes apply to a
2125 -- function (SPARK RM 6.1.4(10)).
2127 -------------------------
2128 -- Analyze_Global_Item --
2129 -------------------------
2131 procedure Analyze_Global_Item
2133 Global_Mode
: Name_Id
)
2135 Item_Id
: Entity_Id
;
2138 -- Detect one of the following cases
2140 -- with Global => (null, Name)
2141 -- with Global => (Name_1, null, Name_2)
2142 -- with Global => (Name, null)
2144 if Nkind
(Item
) = N_Null
then
2145 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2150 Resolve_State
(Item
);
2152 -- Find the entity of the item. If this is a renaming, climb the
2153 -- renaming chain to reach the root object. Renamings of non-
2154 -- entire objects do not yield an entity (Empty).
2156 Item_Id
:= Entity_Of
(Item
);
2158 if Present
(Item_Id
) then
2160 -- A global item may denote a formal parameter of an enclosing
2161 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2162 -- provide a better error diagnostic.
2164 if Is_Formal
(Item_Id
) then
2165 if Scope
(Item_Id
) = Spec_Id
then
2167 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2168 & "parameter of subprogram &"), Item
, Spec_Id
);
2172 -- A global item may denote a concurrent type as long as it is
2173 -- the current instance of an enclosing protected or task type
2174 -- (SPARK RM 6.1.4).
2176 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2177 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2179 -- Pragma [Refined_]Global associated with a protected
2180 -- subprogram cannot mention the current instance of a
2181 -- protected type because the instance behaves as a
2182 -- formal parameter.
2184 if Ekind
(Item_Id
) = E_Protected_Type
then
2185 if Scope
(Spec_Id
) = Item_Id
then
2186 Error_Msg_Name_1
:= Chars
(Item_Id
);
2188 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2189 & "cannot reference current instance of "
2190 & "protected type %"), Item
, Spec_Id
);
2194 -- Pragma [Refined_]Global associated with a task type
2195 -- cannot mention the current instance of a task type
2196 -- because the instance behaves as a formal parameter.
2198 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2199 if Spec_Id
= Item_Id
then
2200 Error_Msg_Name_1
:= Chars
(Item_Id
);
2202 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2203 & "cannot reference current instance of task "
2204 & "type %"), Item
, Spec_Id
);
2209 -- Otherwise the global item denotes a subtype mark that is
2210 -- not a current instance.
2214 ("invalid use of subtype mark in global list", Item
);
2218 -- A global item may denote the anonymous object created for a
2219 -- single protected/task type as long as the current instance
2220 -- is the same single type (SPARK RM 6.1.4).
2222 elsif Is_Single_Concurrent_Object
(Item_Id
)
2223 and then Is_CCT_Instance
(Etype
(Item_Id
), Spec_Id
)
2225 -- Pragma [Refined_]Global associated with a protected
2226 -- subprogram cannot mention the current instance of a
2227 -- protected type because the instance behaves as a formal
2230 if Is_Single_Protected_Object
(Item_Id
) then
2231 if Scope
(Spec_Id
) = Etype
(Item_Id
) then
2232 Error_Msg_Name_1
:= Chars
(Item_Id
);
2234 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2235 & "cannot reference current instance of protected "
2236 & "type %"), Item
, Spec_Id
);
2240 -- Pragma [Refined_]Global associated with a task type
2241 -- cannot mention the current instance of a task type
2242 -- because the instance behaves as a formal parameter.
2244 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2245 if Spec_Id
= Item_Id
then
2246 Error_Msg_Name_1
:= Chars
(Item_Id
);
2248 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2249 & "cannot reference current instance of task "
2250 & "type %"), Item
, Spec_Id
);
2255 -- A formal object may act as a global item inside a generic
2257 elsif Is_Formal_Object
(Item_Id
) then
2260 -- The only legal references are those to abstract states,
2261 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2263 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2269 ("global item must denote object, state or current "
2270 & "instance of concurrent type", Item
);
2274 -- State related checks
2276 if Ekind
(Item_Id
) = E_Abstract_State
then
2278 -- Package and subprogram bodies are instantiated
2279 -- individually in a separate compiler pass. Due to this
2280 -- mode of instantiation, the refinement of a state may
2281 -- no longer be visible when a subprogram body contract
2282 -- is instantiated. Since the generic template is legal,
2283 -- do not perform this check in the instance to circumvent
2286 if Is_Generic_Instance
(Spec_Id
) then
2289 -- An abstract state with visible refinement cannot appear
2290 -- in pragma [Refined_]Global as its place must be taken by
2291 -- some of its constituents (SPARK RM 6.1.4(7)).
2293 elsif Has_Visible_Refinement
(Item_Id
) then
2295 ("cannot mention state & in global refinement",
2297 SPARK_Msg_N
("\use its constituents instead", Item
);
2300 -- An external state cannot appear as a global item of a
2301 -- nonvolatile function (SPARK RM 7.1.3(8)).
2303 elsif Is_External_State
(Item_Id
)
2304 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2305 and then not Is_Volatile_Function
(Spec_Id
)
2308 ("external state & cannot act as global item of "
2309 & "nonvolatile function", Item
, Item_Id
);
2312 -- If the reference to the abstract state appears in an
2313 -- enclosing package body that will eventually refine the
2314 -- state, record the reference for future checks.
2317 Record_Possible_Body_Reference
2318 (State_Id
=> Item_Id
,
2322 -- Constant related checks
2324 elsif Ekind
(Item_Id
) = E_Constant
then
2326 -- A constant is a read-only item, therefore it cannot act
2329 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2331 ("constant & cannot act as output", Item
, Item_Id
);
2335 -- Loop parameter related checks
2337 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2339 -- A loop parameter is a read-only item, therefore it cannot
2340 -- act as an output.
2342 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2344 ("loop parameter & cannot act as output",
2349 -- Variable related checks. These are only relevant when
2350 -- SPARK_Mode is on as they are not standard Ada legality
2353 elsif SPARK_Mode
= On
2354 and then Ekind
(Item_Id
) = E_Variable
2355 and then Is_Effectively_Volatile
(Item_Id
)
2357 -- An effectively volatile object cannot appear as a global
2358 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2360 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2361 and then not Is_Volatile_Function
(Spec_Id
)
2364 ("volatile object & cannot act as global item of a "
2365 & "function", Item
, Item_Id
);
2368 -- An effectively volatile object with external property
2369 -- Effective_Reads set to True must have mode Output or
2370 -- In_Out (SPARK RM 7.1.3(10)).
2372 elsif Effective_Reads_Enabled
(Item_Id
)
2373 and then Global_Mode
= Name_Input
2376 ("volatile object & with property Effective_Reads must "
2377 & "have mode In_Out or Output", Item
, Item_Id
);
2382 -- When the item renames an entire object, replace the item
2383 -- with a reference to the object.
2385 if Entity
(Item
) /= Item_Id
then
2386 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2390 -- Some form of illegal construct masquerading as a name
2391 -- (SPARK RM 6.1.4(4)).
2395 ("global item must denote object, state or current instance "
2396 & "of concurrent type", Item
);
2400 -- Verify that an output does not appear as an input in an
2401 -- enclosing subprogram.
2403 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2404 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2407 -- The same entity might be referenced through various way.
2408 -- Check the entity of the item rather than the item itself
2409 -- (SPARK RM 6.1.4(10)).
2411 if Contains
(Seen
, Item_Id
) then
2412 SPARK_Msg_N
("duplicate global item", Item
);
2414 -- Add the entity of the current item to the list of processed
2418 Append_New_Elmt
(Item_Id
, Seen
);
2420 if Ekind
(Item_Id
) = E_Abstract_State
then
2421 Append_New_Elmt
(Item_Id
, States_Seen
);
2423 -- The variable may eventually become a constituent of a single
2424 -- protected/task type. Record the reference now and verify its
2425 -- legality when analyzing the contract of the variable
2428 elsif Ekind
(Item_Id
) = E_Variable
then
2429 Record_Possible_Part_Of_Reference
2434 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2435 and then Present
(Encapsulating_State
(Item_Id
))
2437 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2440 end Analyze_Global_Item
;
2442 --------------------------
2443 -- Check_Duplicate_Mode --
2444 --------------------------
2446 procedure Check_Duplicate_Mode
2448 Status
: in out Boolean)
2452 SPARK_Msg_N
("duplicate global mode", Mode
);
2456 end Check_Duplicate_Mode
;
2458 -------------------------------------------------
2459 -- Check_Mode_Restriction_In_Enclosing_Context --
2460 -------------------------------------------------
2462 procedure Check_Mode_Restriction_In_Enclosing_Context
2464 Item_Id
: Entity_Id
)
2466 Context
: Entity_Id
;
2468 Inputs
: Elist_Id
:= No_Elist
;
2469 Outputs
: Elist_Id
:= No_Elist
;
2472 -- Traverse the scope stack looking for enclosing subprograms
2473 -- subject to pragma [Refined_]Global.
2475 Context
:= Scope
(Subp_Id
);
2476 while Present
(Context
) and then Context
/= Standard_Standard
loop
2477 if Is_Subprogram
(Context
)
2479 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2481 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2483 Collect_Subprogram_Inputs_Outputs
2484 (Subp_Id
=> Context
,
2485 Subp_Inputs
=> Inputs
,
2486 Subp_Outputs
=> Outputs
,
2487 Global_Seen
=> Dummy
);
2489 -- The item is classified as In_Out or Output but appears as
2490 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(12)).
2492 if Appears_In
(Inputs
, Item_Id
)
2493 and then not Appears_In
(Outputs
, Item_Id
)
2496 ("global item & cannot have mode In_Out or Output",
2500 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2501 & "subprogram &"), Item
, Context
);
2503 -- Stop the traversal once an error has been detected
2509 Context
:= Scope
(Context
);
2511 end Check_Mode_Restriction_In_Enclosing_Context
;
2513 ----------------------------------------
2514 -- Check_Mode_Restriction_In_Function --
2515 ----------------------------------------
2517 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2519 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2521 ("global mode & is not applicable to functions", Mode
);
2523 end Check_Mode_Restriction_In_Function
;
2531 -- Start of processing for Analyze_Global_List
2534 if Nkind
(List
) = N_Null
then
2535 Set_Analyzed
(List
);
2537 -- Single global item declaration
2539 elsif Nkind_In
(List
, N_Expanded_Name
,
2541 N_Selected_Component
)
2543 Analyze_Global_Item
(List
, Global_Mode
);
2545 -- Simple global list or moded global list declaration
2547 elsif Nkind
(List
) = N_Aggregate
then
2548 Set_Analyzed
(List
);
2550 -- The declaration of a simple global list appear as a collection
2553 if Present
(Expressions
(List
)) then
2554 if Present
(Component_Associations
(List
)) then
2556 ("cannot mix moded and non-moded global lists", List
);
2559 Item
:= First
(Expressions
(List
));
2560 while Present
(Item
) loop
2561 Analyze_Global_Item
(Item
, Global_Mode
);
2565 -- The declaration of a moded global list appears as a collection
2566 -- of component associations where individual choices denote
2569 elsif Present
(Component_Associations
(List
)) then
2570 if Present
(Expressions
(List
)) then
2572 ("cannot mix moded and non-moded global lists", List
);
2575 Assoc
:= First
(Component_Associations
(List
));
2576 while Present
(Assoc
) loop
2577 Mode
:= First
(Choices
(Assoc
));
2579 if Nkind
(Mode
) = N_Identifier
then
2580 if Chars
(Mode
) = Name_In_Out
then
2581 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2582 Check_Mode_Restriction_In_Function
(Mode
);
2584 elsif Chars
(Mode
) = Name_Input
then
2585 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2587 elsif Chars
(Mode
) = Name_Output
then
2588 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2589 Check_Mode_Restriction_In_Function
(Mode
);
2591 elsif Chars
(Mode
) = Name_Proof_In
then
2592 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2595 SPARK_Msg_N
("invalid mode selector", Mode
);
2599 SPARK_Msg_N
("invalid mode selector", Mode
);
2602 -- Items in a moded list appear as a collection of
2603 -- expressions. Reuse the existing machinery to analyze
2607 (List
=> Expression
(Assoc
),
2608 Global_Mode
=> Chars
(Mode
));
2616 raise Program_Error
;
2619 -- Any other attempt to declare a global item is illegal. This is a
2620 -- syntax error, always report.
2623 Error_Msg_N
("malformed global list", List
);
2625 end Analyze_Global_List
;
2629 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2631 Restore_Scope
: Boolean := False;
2633 -- Start of processing for Analyze_Global_In_Decl_Part
2636 -- Do not analyze the pragma multiple times
2638 if Is_Analyzed_Pragma
(N
) then
2642 -- There is nothing to be done for a null global list
2644 if Nkind
(Items
) = N_Null
then
2645 Set_Analyzed
(Items
);
2647 -- Analyze the various forms of global lists and items. Note that some
2648 -- of these may be malformed in which case the analysis emits error
2652 -- When pragma [Refined_]Global appears on a single concurrent type,
2653 -- it is relocated to the anonymous object.
2655 if Is_Single_Concurrent_Object
(Spec_Id
) then
2658 -- Ensure that the formal parameters are visible when processing an
2659 -- item. This falls out of the general rule of aspects pertaining to
2660 -- subprogram declarations.
2662 elsif not In_Open_Scopes
(Spec_Id
) then
2663 Restore_Scope
:= True;
2664 Push_Scope
(Spec_Id
);
2666 if Ekind
(Spec_Id
) = E_Task_Type
then
2667 if Has_Discriminants
(Spec_Id
) then
2668 Install_Discriminants
(Spec_Id
);
2671 elsif Is_Generic_Subprogram
(Spec_Id
) then
2672 Install_Generic_Formals
(Spec_Id
);
2675 Install_Formals
(Spec_Id
);
2679 Analyze_Global_List
(Items
);
2681 if Restore_Scope
then
2686 -- Ensure that a state and a corresponding constituent do not appear
2687 -- together in pragma [Refined_]Global.
2689 Check_State_And_Constituent_Use
2690 (States
=> States_Seen
,
2691 Constits
=> Constits_Seen
,
2694 Set_Is_Analyzed_Pragma
(N
);
2695 end Analyze_Global_In_Decl_Part
;
2697 --------------------------------------------
2698 -- Analyze_Initial_Condition_In_Decl_Part --
2699 --------------------------------------------
2701 -- WARNING: This routine manages Ghost regions. Return statements must be
2702 -- replaced by gotos which jump to the end of the routine and restore the
2705 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2706 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2707 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2708 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2710 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2711 -- Save the Ghost mode to restore on exit
2714 -- Do not analyze the pragma multiple times
2716 if Is_Analyzed_Pragma
(N
) then
2720 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2721 -- analysis of the pragma, the Ghost mode at point of declaration and
2722 -- point of analysis may not necessarily be the same. Use the mode in
2723 -- effect at the point of declaration.
2727 -- The expression is preanalyzed because it has not been moved to its
2728 -- final place yet. A direct analysis may generate side effects and this
2729 -- is not desired at this point.
2731 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2732 Set_Is_Analyzed_Pragma
(N
);
2734 Restore_Ghost_Mode
(Saved_GM
);
2735 end Analyze_Initial_Condition_In_Decl_Part
;
2737 --------------------------------------
2738 -- Analyze_Initializes_In_Decl_Part --
2739 --------------------------------------
2741 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2742 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2743 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2745 Constits_Seen
: Elist_Id
:= No_Elist
;
2746 -- A list containing the entities of all constituents processed so far.
2747 -- It aids in detecting illegal usage of a state and a corresponding
2748 -- constituent in pragma Initializes.
2750 Items_Seen
: Elist_Id
:= No_Elist
;
2751 -- A list of all initialization items processed so far. This list is
2752 -- used to detect duplicate items.
2754 Non_Null_Seen
: Boolean := False;
2755 Null_Seen
: Boolean := False;
2756 -- Flags used to check the legality of a null initialization list
2758 States_And_Objs
: Elist_Id
:= No_Elist
;
2759 -- A list of all abstract states and objects declared in the visible
2760 -- declarations of the related package. This list is used to detect the
2761 -- legality of initialization items.
2763 States_Seen
: Elist_Id
:= No_Elist
;
2764 -- A list containing the entities of all states processed so far. It
2765 -- helps in detecting illegal usage of a state and a corresponding
2766 -- constituent in pragma Initializes.
2768 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2769 -- Verify the legality of a single initialization item
2771 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2772 -- Verify the legality of a single initialization item followed by a
2773 -- list of input items.
2775 procedure Collect_States_And_Objects
;
2776 -- Inspect the visible declarations of the related package and gather
2777 -- the entities of all abstract states and objects in States_And_Objs.
2779 ---------------------------------
2780 -- Analyze_Initialization_Item --
2781 ---------------------------------
2783 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2784 Item_Id
: Entity_Id
;
2787 -- Null initialization list
2789 if Nkind
(Item
) = N_Null
then
2791 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2793 elsif Non_Null_Seen
then
2795 ("cannot mix null and non-null initialization items", Item
);
2800 -- Initialization item
2803 Non_Null_Seen
:= True;
2807 ("cannot mix null and non-null initialization items", Item
);
2811 Resolve_State
(Item
);
2813 if Is_Entity_Name
(Item
) then
2814 Item_Id
:= Entity_Of
(Item
);
2816 if Present
(Item_Id
)
2817 and then Ekind_In
(Item_Id
, E_Abstract_State
,
2821 -- The state or variable must be declared in the visible
2822 -- declarations of the package (SPARK RM 7.1.5(7)).
2824 if not Contains
(States_And_Objs
, Item_Id
) then
2825 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2827 ("initialization item & must appear in the visible "
2828 & "declarations of package %", Item
, Item_Id
);
2830 -- Detect a duplicate use of the same initialization item
2831 -- (SPARK RM 7.1.5(5)).
2833 elsif Contains
(Items_Seen
, Item_Id
) then
2834 SPARK_Msg_N
("duplicate initialization item", Item
);
2836 -- The item is legal, add it to the list of processed states
2840 Append_New_Elmt
(Item_Id
, Items_Seen
);
2842 if Ekind
(Item_Id
) = E_Abstract_State
then
2843 Append_New_Elmt
(Item_Id
, States_Seen
);
2846 if Present
(Encapsulating_State
(Item_Id
)) then
2847 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2851 -- The item references something that is not a state or object
2852 -- (SPARK RM 7.1.5(3)).
2856 ("initialization item must denote object or state", Item
);
2859 -- Some form of illegal construct masquerading as a name
2860 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2864 ("initialization item must denote object or state", Item
);
2867 end Analyze_Initialization_Item
;
2869 ---------------------------------------------
2870 -- Analyze_Initialization_Item_With_Inputs --
2871 ---------------------------------------------
2873 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2874 Inputs_Seen
: Elist_Id
:= No_Elist
;
2875 -- A list of all inputs processed so far. This list is used to detect
2876 -- duplicate uses of an input.
2878 Non_Null_Seen
: Boolean := False;
2879 Null_Seen
: Boolean := False;
2880 -- Flags used to check the legality of an input list
2882 procedure Analyze_Input_Item
(Input
: Node_Id
);
2883 -- Verify the legality of a single input item
2885 ------------------------
2886 -- Analyze_Input_Item --
2887 ------------------------
2889 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2890 Input_Id
: Entity_Id
;
2891 Input_OK
: Boolean := True;
2896 if Nkind
(Input
) = N_Null
then
2899 ("multiple null initializations not allowed", Item
);
2901 elsif Non_Null_Seen
then
2903 ("cannot mix null and non-null initialization item", Item
);
2911 Non_Null_Seen
:= True;
2915 ("cannot mix null and non-null initialization item", Item
);
2919 Resolve_State
(Input
);
2921 if Is_Entity_Name
(Input
) then
2922 Input_Id
:= Entity_Of
(Input
);
2924 if Present
(Input_Id
)
2925 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2927 E_Generic_In_Out_Parameter
,
2928 E_Generic_In_Parameter
,
2934 -- The input cannot denote states or objects declared
2935 -- within the related package (SPARK RM 7.1.5(4)).
2937 if Within_Scope
(Input_Id
, Current_Scope
) then
2939 -- Do not consider generic formal parameters or their
2940 -- respective mappings to generic formals. Even though
2941 -- the formals appear within the scope of the package,
2942 -- it is allowed for an initialization item to depend
2943 -- on an input item.
2945 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2946 E_Generic_In_Parameter
)
2950 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2951 and then Present
(Corresponding_Generic_Association
2952 (Declaration_Node
(Input_Id
)))
2958 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2960 ("input item & cannot denote a visible object or "
2961 & "state of package %", Input
, Input_Id
);
2965 -- Detect a duplicate use of the same input item
2966 -- (SPARK RM 7.1.5(5)).
2968 if Contains
(Inputs_Seen
, Input_Id
) then
2970 SPARK_Msg_N
("duplicate input item", Input
);
2973 -- Input is legal, add it to the list of processed inputs
2976 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2978 if Ekind
(Input_Id
) = E_Abstract_State
then
2979 Append_New_Elmt
(Input_Id
, States_Seen
);
2982 if Ekind_In
(Input_Id
, E_Abstract_State
,
2985 and then Present
(Encapsulating_State
(Input_Id
))
2987 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2991 -- The input references something that is not a state or an
2992 -- object (SPARK RM 7.1.5(3)).
2996 ("input item must denote object or state", Input
);
2999 -- Some form of illegal construct masquerading as a name
3000 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3004 ("input item must denote object or state", Input
);
3007 end Analyze_Input_Item
;
3011 Inputs
: constant Node_Id
:= Expression
(Item
);
3015 Name_Seen
: Boolean := False;
3016 -- A flag used to detect multiple item names
3018 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3021 -- Inspect the name of an item with inputs
3023 Elmt
:= First
(Choices
(Item
));
3024 while Present
(Elmt
) loop
3026 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3029 Analyze_Initialization_Item
(Elmt
);
3035 -- Multiple input items appear as an aggregate
3037 if Nkind
(Inputs
) = N_Aggregate
then
3038 if Present
(Expressions
(Inputs
)) then
3039 Input
:= First
(Expressions
(Inputs
));
3040 while Present
(Input
) loop
3041 Analyze_Input_Item
(Input
);
3046 if Present
(Component_Associations
(Inputs
)) then
3048 ("inputs must appear in named association form", Inputs
);
3051 -- Single input item
3054 Analyze_Input_Item
(Inputs
);
3056 end Analyze_Initialization_Item_With_Inputs
;
3058 --------------------------------
3059 -- Collect_States_And_Objects --
3060 --------------------------------
3062 procedure Collect_States_And_Objects
is
3063 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3067 -- Collect the abstract states defined in the package (if any)
3069 if Present
(Abstract_States
(Pack_Id
)) then
3070 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3073 -- Collect all objects that appear in the visible declarations of the
3076 if Present
(Visible_Declarations
(Pack_Spec
)) then
3077 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3078 while Present
(Decl
) loop
3079 if Comes_From_Source
(Decl
)
3080 and then Nkind_In
(Decl
, N_Object_Declaration
,
3081 N_Object_Renaming_Declaration
)
3083 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3085 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3087 (Anonymous_Object
(Defining_Entity
(Decl
)),
3094 end Collect_States_And_Objects
;
3098 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3101 -- Start of processing for Analyze_Initializes_In_Decl_Part
3104 -- Do not analyze the pragma multiple times
3106 if Is_Analyzed_Pragma
(N
) then
3110 -- Nothing to do when the initialization list is empty
3112 if Nkind
(Inits
) = N_Null
then
3116 -- Single and multiple initialization clauses appear as an aggregate. If
3117 -- this is not the case, then either the parser or the analysis of the
3118 -- pragma failed to produce an aggregate.
3120 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3122 -- Initialize the various lists used during analysis
3124 Collect_States_And_Objects
;
3126 if Present
(Expressions
(Inits
)) then
3127 Init
:= First
(Expressions
(Inits
));
3128 while Present
(Init
) loop
3129 Analyze_Initialization_Item
(Init
);
3134 if Present
(Component_Associations
(Inits
)) then
3135 Init
:= First
(Component_Associations
(Inits
));
3136 while Present
(Init
) loop
3137 Analyze_Initialization_Item_With_Inputs
(Init
);
3142 -- Ensure that a state and a corresponding constituent do not appear
3143 -- together in pragma Initializes.
3145 Check_State_And_Constituent_Use
3146 (States
=> States_Seen
,
3147 Constits
=> Constits_Seen
,
3150 Set_Is_Analyzed_Pragma
(N
);
3151 end Analyze_Initializes_In_Decl_Part
;
3153 ---------------------
3154 -- Analyze_Part_Of --
3155 ---------------------
3157 procedure Analyze_Part_Of
3159 Item_Id
: Entity_Id
;
3161 Encap_Id
: out Entity_Id
;
3162 Legal
: out Boolean)
3164 Encap_Typ
: Entity_Id
;
3165 Item_Decl
: Node_Id
;
3166 Pack_Id
: Entity_Id
;
3167 Placement
: State_Space_Kind
;
3168 Parent_Unit
: Entity_Id
;
3171 -- Assume that the indicator is illegal
3176 if Nkind_In
(Encap
, N_Expanded_Name
,
3178 N_Selected_Component
)
3181 Resolve_State
(Encap
);
3183 Encap_Id
:= Entity
(Encap
);
3185 -- The encapsulator is an abstract state
3187 if Ekind
(Encap_Id
) = E_Abstract_State
then
3190 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3192 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3195 -- Otherwise the encapsulator is not a legal choice
3199 ("indicator Part_Of must denote abstract state, single "
3200 & "protected type or single task type", Encap
);
3204 -- This is a syntax error, always report
3208 ("indicator Part_Of must denote abstract state, single protected "
3209 & "type or single task type", Encap
);
3213 -- Catch a case where indicator Part_Of denotes the abstract view of a
3214 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3216 if From_Limited_With
(Encap_Id
)
3217 and then Present
(Non_Limited_View
(Encap_Id
))
3218 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3220 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3221 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3225 -- The encapsulator is an abstract state
3227 if Ekind
(Encap_Id
) = E_Abstract_State
then
3229 -- Determine where the object, package instantiation or state lives
3230 -- with respect to the enclosing packages or package bodies.
3232 Find_Placement_In_State_Space
3233 (Item_Id
=> Item_Id
,
3234 Placement
=> Placement
,
3235 Pack_Id
=> Pack_Id
);
3237 -- The item appears in a non-package construct with a declarative
3238 -- part (subprogram, block, etc). As such, the item is not allowed
3239 -- to be a part of an encapsulating state because the item is not
3242 if Placement
= Not_In_Package
then
3244 ("indicator Part_Of cannot appear in this context "
3245 & "(SPARK RM 7.2.6(5))", Indic
);
3246 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3248 ("\& is not part of the hidden state of package %",
3252 -- The item appears in the visible state space of some package. In
3253 -- general this scenario does not warrant Part_Of except when the
3254 -- package is a private child unit and the encapsulating state is
3255 -- declared in a parent unit or a public descendant of that parent
3258 elsif Placement
= Visible_State_Space
then
3259 if Is_Child_Unit
(Pack_Id
)
3260 and then Is_Private_Descendant
(Pack_Id
)
3262 -- A variable or state abstraction which is part of the visible
3263 -- state of a private child unit (or one of its public
3264 -- descendants) must have its Part_Of indicator specified. The
3265 -- Part_Of indicator must denote a state abstraction declared
3266 -- by either the parent unit of the private unit or by a public
3267 -- descendant of that parent unit.
3269 -- Find nearest private ancestor (which can be the current unit
3272 Parent_Unit
:= Pack_Id
;
3273 while Present
(Parent_Unit
) loop
3276 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3277 Parent_Unit
:= Scope
(Parent_Unit
);
3280 Parent_Unit
:= Scope
(Parent_Unit
);
3282 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3284 ("indicator Part_Of must denote abstract state or public "
3285 & "descendant of & (SPARK RM 7.2.6(3))",
3286 Indic
, Parent_Unit
);
3289 elsif Scope
(Encap_Id
) = Parent_Unit
3291 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3292 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3298 ("indicator Part_Of must denote abstract state or public "
3299 & "descendant of & (SPARK RM 7.2.6(3))",
3300 Indic
, Parent_Unit
);
3304 -- Indicator Part_Of is not needed when the related package is not
3305 -- a private child unit or a public descendant thereof.
3309 ("indicator Part_Of cannot appear in this context "
3310 & "(SPARK RM 7.2.6(5))", Indic
);
3311 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3313 ("\& is declared in the visible part of package %",
3318 -- When the item appears in the private state space of a package, the
3319 -- encapsulating state must be declared in the same package.
3321 elsif Placement
= Private_State_Space
then
3322 if Scope
(Encap_Id
) /= Pack_Id
then
3324 ("indicator Part_Of must designate an abstract state of "
3325 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3326 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3328 ("\& is declared in the private part of package %",
3333 -- Items declared in the body state space of a package do not need
3334 -- Part_Of indicators as the refinement has already been seen.
3338 ("indicator Part_Of cannot appear in this context "
3339 & "(SPARK RM 7.2.6(5))", Indic
);
3341 if Scope
(Encap_Id
) = Pack_Id
then
3342 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3344 ("\& is declared in the body of package %", Indic
, Item_Id
);
3350 -- The encapsulator is a single concurrent type
3353 Encap_Typ
:= Etype
(Encap_Id
);
3355 -- Only abstract states and variables can act as constituents of an
3356 -- encapsulating single concurrent type.
3358 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3361 -- The constituent is a constant
3363 elsif Ekind
(Item_Id
) = E_Constant
then
3364 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3366 (Fix_Msg
(Encap_Typ
, "constant & cannot act as constituent of "
3367 & "single protected type %"), Indic
, Item_Id
);
3370 -- The constituent is a package instantiation
3373 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3375 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3376 & "constituent of single protected type %"), Indic
, Item_Id
);
3380 -- When the item denotes an abstract state of a nested package, use
3381 -- the declaration of the package to detect proper placement.
3386 -- with Abstract_State => (State with Part_Of => T)
3388 if Ekind
(Item_Id
) = E_Abstract_State
then
3389 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3391 Item_Decl
:= Declaration_Node
(Item_Id
);
3394 -- Both the item and its encapsulating single concurrent type must
3395 -- appear in the same declarative region (SPARK RM 9.3). Note that
3396 -- privacy is ignored.
3398 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3399 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3401 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3402 & "immediately within the same region as single protected "
3403 & "type %"), Indic
, Item_Id
);
3407 -- The declaration of the item should follow the declaration of its
3408 -- encapsulating single concurrent type and must appear in the same
3409 -- declarative region (SPARK RM 9.3).
3415 N
:= Next
(Declaration_Node
(Encap_Id
));
3416 while Present
(N
) loop
3417 exit when N
= Item_Decl
;
3421 -- The single concurrent type might be in the visible part of a
3422 -- package, and the declaration of the item in the private part
3423 -- of the same package.
3427 Pack
: constant Node_Id
:=
3428 Parent
(Declaration_Node
(Encap_Id
));
3430 if Nkind
(Pack
) = N_Package_Specification
3431 and then not In_Private_Part
(Encap_Id
)
3433 N
:= First
(Private_Declarations
(Pack
));
3434 while Present
(N
) loop
3435 exit when N
= Item_Decl
;
3444 ("indicator Part_Of must denote a previously declared "
3445 & "single protected type or single task type", Encap
);
3452 end Analyze_Part_Of
;
3454 ----------------------------------
3455 -- Analyze_Part_Of_In_Decl_Part --
3456 ----------------------------------
3458 procedure Analyze_Part_Of_In_Decl_Part
3460 Freeze_Id
: Entity_Id
:= Empty
)
3462 Encap
: constant Node_Id
:=
3463 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3464 Errors
: constant Nat
:= Serious_Errors_Detected
;
3465 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3466 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3467 Constits
: Elist_Id
;
3468 Encap_Id
: Entity_Id
;
3472 -- Detect any discrepancies between the placement of the variable with
3473 -- respect to general state space and the encapsulating state or single
3480 Encap_Id
=> Encap_Id
,
3483 -- The Part_Of indicator turns the variable into a constituent of the
3484 -- encapsulating state or single concurrent type.
3487 pragma Assert
(Present
(Encap_Id
));
3488 Constits
:= Part_Of_Constituents
(Encap_Id
);
3490 if No
(Constits
) then
3491 Constits
:= New_Elmt_List
;
3492 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3495 Append_Elmt
(Var_Id
, Constits
);
3496 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3498 -- A Part_Of constituent partially refines an abstract state. This
3499 -- property does not apply to protected or task units.
3501 if Ekind
(Encap_Id
) = E_Abstract_State
then
3502 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3506 -- Emit a clarification message when the encapsulator is undefined,
3507 -- possibly due to contract "freezing".
3509 if Errors
/= Serious_Errors_Detected
3510 and then Present
(Freeze_Id
)
3511 and then Has_Undefined_Reference
(Encap
)
3513 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3515 end Analyze_Part_Of_In_Decl_Part
;
3517 --------------------
3518 -- Analyze_Pragma --
3519 --------------------
3521 procedure Analyze_Pragma
(N
: Node_Id
) is
3522 Loc
: constant Source_Ptr
:= Sloc
(N
);
3524 Pname
: Name_Id
:= Pragma_Name
(N
);
3525 -- Name of the source pragma, or name of the corresponding aspect for
3526 -- pragmas which originate in a source aspect. In the latter case, the
3527 -- name may be different from the pragma name.
3529 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3531 Pragma_Exit
: exception;
3532 -- This exception is used to exit pragma processing completely. It
3533 -- is used when an error is detected, and no further processing is
3534 -- required. It is also used if an earlier error has left the tree in
3535 -- a state where the pragma should not be processed.
3538 -- Number of pragma argument associations
3544 -- First four pragma arguments (pragma argument association nodes, or
3545 -- Empty if the corresponding argument does not exist).
3547 type Name_List
is array (Natural range <>) of Name_Id
;
3548 type Args_List
is array (Natural range <>) of Node_Id
;
3549 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3551 -----------------------
3552 -- Local Subprograms --
3553 -----------------------
3555 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3556 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3557 -- get the given string argument, and place it in Name_Buffer, adding
3558 -- leading and trailing asterisks if they are not already present. The
3559 -- caller has already checked that Arg is a static string expression.
3561 procedure Ada_2005_Pragma
;
3562 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3563 -- Ada 95 mode, these are implementation defined pragmas, so should be
3564 -- caught by the No_Implementation_Pragmas restriction.
3566 procedure Ada_2012_Pragma
;
3567 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3568 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3569 -- should be caught by the No_Implementation_Pragmas restriction.
3571 procedure Analyze_Depends_Global
3572 (Spec_Id
: out Entity_Id
;
3573 Subp_Decl
: out Node_Id
;
3574 Legal
: out Boolean);
3575 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3576 -- legality of the placement and related context of the pragma. Spec_Id
3577 -- is the entity of the related subprogram. Subp_Decl is the declaration
3578 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3580 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3581 -- Inspect the remainder of the list containing pragma N and look for
3582 -- a pragma that matches Id. If found, analyze the pragma.
3584 procedure Analyze_Pre_Post_Condition
;
3585 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3587 procedure Analyze_Refined_Depends_Global_Post
3588 (Spec_Id
: out Entity_Id
;
3589 Body_Id
: out Entity_Id
;
3590 Legal
: out Boolean);
3591 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3592 -- Refined_Global and Refined_Post. Verify the legality of the placement
3593 -- and related context of the pragma. Spec_Id is the entity of the
3594 -- related subprogram. Body_Id is the entity of the subprogram body.
3595 -- Flag Legal is set when the pragma is legal.
3597 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3598 -- Perform full analysis of pragma Unmodified and the write aspect of
3599 -- pragma Unused. Flag Is_Unused should be set when verifying the
3600 -- semantics of pragma Unused.
3602 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3603 -- Perform full analysis of pragma Unreferenced and the read aspect of
3604 -- pragma Unused. Flag Is_Unused should be set when verifying the
3605 -- semantics of pragma Unused.
3607 procedure Check_Ada_83_Warning
;
3608 -- Issues a warning message for the current pragma if operating in Ada
3609 -- 83 mode (used for language pragmas that are not a standard part of
3610 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3613 procedure Check_Arg_Count
(Required
: Nat
);
3614 -- Check argument count for pragma is equal to given parameter. If not,
3615 -- then issue an error message and raise Pragma_Exit.
3617 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3618 -- Arg which can either be a pragma argument association, in which case
3619 -- the check is applied to the expression of the association or an
3620 -- expression directly.
3622 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3623 -- Check that an argument has the right form for an EXTERNAL_NAME
3624 -- parameter of an extended import/export pragma. The rule is that the
3625 -- name must be an identifier or string literal (in Ada 83 mode) or a
3626 -- static string expression (in Ada 95 mode).
3628 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3629 -- Check the specified argument Arg to make sure that it is an
3630 -- identifier. If not give error and raise Pragma_Exit.
3632 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3633 -- Check the specified argument Arg to make sure that it is an integer
3634 -- literal. If not give error and raise Pragma_Exit.
3636 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3637 -- Check the specified argument Arg to make sure that it has the proper
3638 -- syntactic form for a local name and meets the semantic requirements
3639 -- for a local name. The local name is analyzed as part of the
3640 -- processing for this call. In addition, the local name is required
3641 -- to represent an entity at the library level.
3643 procedure Check_Arg_Is_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.
3649 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3650 -- Check the specified argument Arg to make sure that it is a valid
3651 -- locking policy name. If not give error and raise Pragma_Exit.
3653 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3654 -- Check the specified argument Arg to make sure that it is a valid
3655 -- elaboration policy name. If not give error and raise Pragma_Exit.
3657 procedure Check_Arg_Is_One_Of
3660 procedure Check_Arg_Is_One_Of
3662 N1
, N2
, N3
: Name_Id
);
3663 procedure Check_Arg_Is_One_Of
3665 N1
, N2
, N3
, N4
: Name_Id
);
3666 procedure Check_Arg_Is_One_Of
3668 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3669 -- Check the specified argument Arg to make sure that it is an
3670 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3671 -- present). If not then give error and raise Pragma_Exit.
3673 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3674 -- Check the specified argument Arg to make sure that it is a valid
3675 -- queuing policy name. If not give error and raise Pragma_Exit.
3677 procedure Check_Arg_Is_OK_Static_Expression
3679 Typ
: Entity_Id
:= Empty
);
3680 -- Check the specified argument Arg to make sure that it is a static
3681 -- expression of the given type (i.e. it will be analyzed and resolved
3682 -- using this type, which can be any valid argument to Resolve, e.g.
3683 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3684 -- Typ is left Empty, then any static expression is allowed. Includes
3685 -- checking that the argument does not raise Constraint_Error.
3687 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3688 -- Check the specified argument Arg to make sure that it is a valid task
3689 -- dispatching policy name. If not give error and raise Pragma_Exit.
3691 procedure Check_Arg_Order
(Names
: Name_List
);
3692 -- Checks for an instance of two arguments with identifiers for the
3693 -- current pragma which are not in the sequence indicated by Names,
3694 -- and if so, generates a fatal message about bad order of arguments.
3696 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3697 -- Check there are at least N arguments present
3699 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3700 -- Check there are no more than N arguments present
3702 procedure Check_Component
3705 In_Variant_Part
: Boolean := False);
3706 -- Examine an Unchecked_Union component for correct use of per-object
3707 -- constrained subtypes, and for restrictions on finalizable components.
3708 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3709 -- should be set when Comp comes from a record variant.
3711 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3712 -- Check if a rep item of the same name as the current pragma is already
3713 -- chained as a rep pragma to the given entity. If so give a message
3714 -- about the duplicate, and then raise Pragma_Exit so does not return.
3715 -- Note that if E is a type, then this routine avoids flagging a pragma
3716 -- which applies to a parent type from which E is derived.
3718 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3719 -- Nam is an N_String_Literal node containing the external name set by
3720 -- an Import or Export pragma (or extended Import or Export pragma).
3721 -- This procedure checks for possible duplications if this is the export
3722 -- case, and if found, issues an appropriate error message.
3724 procedure Check_Expr_Is_OK_Static_Expression
3726 Typ
: Entity_Id
:= Empty
);
3727 -- Check the specified expression Expr to make sure that it is a static
3728 -- expression of the given type (i.e. it will be analyzed and resolved
3729 -- using this type, which can be any valid argument to Resolve, e.g.
3730 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3731 -- Typ is left Empty, then any static expression is allowed. Includes
3732 -- checking that the expression does not raise Constraint_Error.
3734 procedure Check_First_Subtype
(Arg
: Node_Id
);
3735 -- Checks that Arg, whose expression is an entity name, references a
3738 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3739 -- Checks that the given argument has an identifier, and if so, requires
3740 -- it to match the given identifier name. If there is no identifier, or
3741 -- a non-matching identifier, then an error message is given and
3742 -- Pragma_Exit is raised.
3744 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3745 -- Checks that the given argument has an identifier, and if so, requires
3746 -- it to match one of the given identifier names. If there is no
3747 -- identifier, or a non-matching identifier, then an error message is
3748 -- given and Pragma_Exit is raised.
3750 procedure Check_In_Main_Program
;
3751 -- Common checks for pragmas that appear within a main program
3752 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3754 procedure Check_Interrupt_Or_Attach_Handler
;
3755 -- Common processing for first argument of pragma Interrupt_Handler or
3756 -- pragma Attach_Handler.
3758 procedure Check_Loop_Pragma_Placement
;
3759 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3760 -- appear immediately within a construct restricted to loops, and that
3761 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3763 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3764 -- Check that pragma appears in a declarative part, or in a package
3765 -- specification, i.e. that it does not occur in a statement sequence
3768 procedure Check_No_Identifier
(Arg
: Node_Id
);
3769 -- Checks that the given argument does not have an identifier. If
3770 -- an identifier is present, then an error message is issued, and
3771 -- Pragma_Exit is raised.
3773 procedure Check_No_Identifiers
;
3774 -- Checks that none of the arguments to the pragma has an identifier.
3775 -- If any argument has an identifier, then an error message is issued,
3776 -- and Pragma_Exit is raised.
3778 procedure Check_No_Link_Name
;
3779 -- Checks that no link name is specified
3781 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3782 -- Checks if the given argument has an identifier, and if so, requires
3783 -- it to match the given identifier name. If there is a non-matching
3784 -- identifier, then an error message is given and Pragma_Exit is raised.
3786 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3787 -- Checks if the given argument has an identifier, and if so, requires
3788 -- it to match the given identifier name. If there is a non-matching
3789 -- identifier, then an error message is given and Pragma_Exit is raised.
3790 -- In this version of the procedure, the identifier name is given as
3791 -- a string with lower case letters.
3793 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3794 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3795 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3796 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3797 -- is an OK static boolean expression. Emit an error if this is not the
3800 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3801 -- Constr is a constraint from an N_Subtype_Indication node from a
3802 -- component constraint in an Unchecked_Union type. This routine checks
3803 -- that the constraint is static as required by the restrictions for
3806 procedure Check_Valid_Configuration_Pragma
;
3807 -- Legality checks for placement of a configuration pragma
3809 procedure Check_Valid_Library_Unit_Pragma
;
3810 -- Legality checks for library unit pragmas. A special case arises for
3811 -- pragmas in generic instances that come from copies of the original
3812 -- library unit pragmas in the generic templates. In the case of other
3813 -- than library level instantiations these can appear in contexts which
3814 -- would normally be invalid (they only apply to the original template
3815 -- and to library level instantiations), and they are simply ignored,
3816 -- which is implemented by rewriting them as null statements.
3818 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3819 -- Check an Unchecked_Union variant for lack of nested variants and
3820 -- presence of at least one component. UU_Typ is the related Unchecked_
3823 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3824 -- Subsidiary routine to the processing of pragmas Abstract_State,
3825 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3826 -- Refined_Global and Refined_State. Transform argument Arg into
3827 -- an aggregate if not one already. N_Null is never transformed.
3828 -- Arg may denote an aspect specification or a pragma argument
3831 procedure Error_Pragma
(Msg
: String);
3832 pragma No_Return
(Error_Pragma
);
3833 -- Outputs error message for current pragma. The message contains a %
3834 -- that will be replaced with the pragma name, and the flag is placed
3835 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3836 -- calls Fix_Error (see spec of that procedure for details).
3838 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3839 pragma No_Return
(Error_Pragma_Arg
);
3840 -- Outputs error message for current pragma. The message may contain
3841 -- a % that will be replaced with the pragma name. The parameter Arg
3842 -- may either be a pragma argument association, in which case the flag
3843 -- is placed on the expression of this association, or an expression,
3844 -- in which case the flag is placed directly on the expression. The
3845 -- message is placed using Error_Msg_N, so the message may also contain
3846 -- an & insertion character which will reference the given Arg value.
3847 -- After placing the message, Pragma_Exit is raised. Note: this routine
3848 -- calls Fix_Error (see spec of that procedure for details).
3850 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3851 pragma No_Return
(Error_Pragma_Arg
);
3852 -- Similar to above form of Error_Pragma_Arg except that two messages
3853 -- are provided, the second is a continuation comment starting with \.
3855 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3856 pragma No_Return
(Error_Pragma_Arg_Ident
);
3857 -- Outputs error message for current pragma. The message may contain a %
3858 -- that will be replaced with the pragma name. The parameter Arg must be
3859 -- a pragma argument association with a non-empty identifier (i.e. its
3860 -- Chars field must be set), and the error message is placed on the
3861 -- identifier. The message is placed using Error_Msg_N so the message
3862 -- may also contain an & insertion character which will reference
3863 -- the identifier. After placing the message, Pragma_Exit is raised.
3864 -- Note: this routine calls Fix_Error (see spec of that procedure for
3867 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3868 pragma No_Return
(Error_Pragma_Ref
);
3869 -- Outputs error message for current pragma. The message may contain
3870 -- a % that will be replaced with the pragma name. The parameter Ref
3871 -- must be an entity whose name can be referenced by & and sloc by #.
3872 -- After placing the message, Pragma_Exit is raised. Note: this routine
3873 -- calls Fix_Error (see spec of that procedure for details).
3875 function Find_Lib_Unit_Name
return Entity_Id
;
3876 -- Used for a library unit pragma to find the entity to which the
3877 -- library unit pragma applies, returns the entity found.
3879 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3880 -- If the pragma is a compilation unit pragma, the id must denote the
3881 -- compilation unit in the same compilation, and the pragma must appear
3882 -- in the list of preceding or trailing pragmas. If it is a program
3883 -- unit pragma that is not a compilation unit pragma, then the
3884 -- identifier must be visible.
3886 function Find_Unique_Parameterless_Procedure
3888 Arg
: Node_Id
) return Entity_Id
;
3889 -- Used for a procedure pragma to find the unique parameterless
3890 -- procedure identified by Name, returns it if it exists, otherwise
3891 -- errors out and uses Arg as the pragma argument for the message.
3893 function Fix_Error
(Msg
: String) return String;
3894 -- This is called prior to issuing an error message. Msg is the normal
3895 -- error message issued in the pragma case. This routine checks for the
3896 -- case of a pragma coming from an aspect in the source, and returns a
3897 -- message suitable for the aspect case as follows:
3899 -- Each substring "pragma" is replaced by "aspect"
3901 -- If "argument of" is at the start of the error message text, it is
3902 -- replaced by "entity for".
3904 -- If "argument" is at the start of the error message text, it is
3905 -- replaced by "entity".
3907 -- So for example, "argument of pragma X must be discrete type"
3908 -- returns "entity for aspect X must be a discrete type".
3910 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3911 -- be different from the pragma name). If the current pragma results
3912 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3913 -- original pragma name.
3915 procedure Gather_Associations
3917 Args
: out Args_List
);
3918 -- This procedure is used to gather the arguments for a pragma that
3919 -- permits arbitrary ordering of parameters using the normal rules
3920 -- for named and positional parameters. The Names argument is a list
3921 -- of Name_Id values that corresponds to the allowed pragma argument
3922 -- association identifiers in order. The result returned in Args is
3923 -- a list of corresponding expressions that are the pragma arguments.
3924 -- Note that this is a list of expressions, not of pragma argument
3925 -- associations (Gather_Associations has completely checked all the
3926 -- optional identifiers when it returns). An entry in Args is Empty
3927 -- on return if the corresponding argument is not present.
3929 procedure GNAT_Pragma
;
3930 -- Called for all GNAT defined pragmas to check the relevant restriction
3931 -- (No_Implementation_Pragmas).
3933 function Is_Before_First_Decl
3934 (Pragma_Node
: Node_Id
;
3935 Decls
: List_Id
) return Boolean;
3936 -- Return True if Pragma_Node is before the first declarative item in
3937 -- Decls where Decls is the list of declarative items.
3939 function Is_Configuration_Pragma
return Boolean;
3940 -- Determines if the placement of the current pragma is appropriate
3941 -- for a configuration pragma.
3943 function Is_In_Context_Clause
return Boolean;
3944 -- Returns True if pragma appears within the context clause of a unit,
3945 -- and False for any other placement (does not generate any messages).
3947 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3948 -- Analyzes the argument, and determines if it is a static string
3949 -- expression, returns True if so, False if non-static or not String.
3950 -- A special case is that a string literal returns True in Ada 83 mode
3951 -- (which has no such thing as static string expressions). Note that
3952 -- the call analyzes its argument, so this cannot be used for the case
3953 -- where an identifier might not be declared.
3955 procedure Pragma_Misplaced
;
3956 pragma No_Return
(Pragma_Misplaced
);
3957 -- Issue fatal error message for misplaced pragma
3959 procedure Process_Atomic_Independent_Shared_Volatile
;
3960 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3961 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3962 -- and treated as being identical in effect to pragma Atomic.
3964 procedure Process_Compile_Time_Warning_Or_Error
;
3965 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3967 procedure Process_Convention
3968 (C
: out Convention_Id
;
3969 Ent
: out Entity_Id
);
3970 -- Common processing for Convention, Interface, Import and Export.
3971 -- Checks first two arguments of pragma, and sets the appropriate
3972 -- convention value in the specified entity or entities. On return
3973 -- C is the convention, Ent is the referenced entity.
3975 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3976 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3977 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3979 procedure Process_Extended_Import_Export_Object_Pragma
3980 (Arg_Internal
: Node_Id
;
3981 Arg_External
: Node_Id
;
3982 Arg_Size
: Node_Id
);
3983 -- Common processing for the pragmas Import/Export_Object. The three
3984 -- arguments correspond to the three named parameters of the pragmas. An
3985 -- argument is empty if the corresponding parameter is not present in
3988 procedure Process_Extended_Import_Export_Internal_Arg
3989 (Arg_Internal
: Node_Id
:= Empty
);
3990 -- Common processing for all extended Import and Export pragmas. The
3991 -- argument is the pragma parameter for the Internal argument. If
3992 -- Arg_Internal is empty or inappropriate, an error message is posted.
3993 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3994 -- set to identify the referenced entity.
3996 procedure Process_Extended_Import_Export_Subprogram_Pragma
3997 (Arg_Internal
: Node_Id
;
3998 Arg_External
: Node_Id
;
3999 Arg_Parameter_Types
: Node_Id
;
4000 Arg_Result_Type
: Node_Id
:= Empty
;
4001 Arg_Mechanism
: Node_Id
;
4002 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4003 -- Common processing for all extended Import and Export pragmas applying
4004 -- to subprograms. The caller omits any arguments that do not apply to
4005 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4006 -- only in the Import_Function and Export_Function cases). The argument
4007 -- names correspond to the allowed pragma association identifiers.
4009 procedure Process_Generic_List
;
4010 -- Common processing for Share_Generic and Inline_Generic
4012 procedure Process_Import_Or_Interface
;
4013 -- Common processing for Import or Interface
4015 procedure Process_Import_Predefined_Type
;
4016 -- Processing for completing a type with pragma Import. This is used
4017 -- to declare types that match predefined C types, especially for cases
4018 -- without corresponding Ada predefined type.
4020 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4021 -- Inline status of a subprogram, indicated as follows:
4022 -- Suppressed: inlining is suppressed for the subprogram
4023 -- Disabled: no inlining is requested for the subprogram
4024 -- Enabled: inlining is requested/required for the subprogram
4026 procedure Process_Inline
(Status
: Inline_Status
);
4027 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4028 -- indicates the inline status specified by the pragma.
4030 procedure Process_Interface_Name
4031 (Subprogram_Def
: Entity_Id
;
4035 -- Given the last two arguments of pragma Import, pragma Export, or
4036 -- pragma Interface_Name, performs validity checks and sets the
4037 -- Interface_Name field of the given subprogram entity to the
4038 -- appropriate external or link name, depending on the arguments given.
4039 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4040 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4041 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4042 -- nor Link_Arg is present, the interface name is set to the default
4043 -- from the subprogram name. In addition, the pragma itself is passed
4044 -- to analyze any expressions in the case the pragma came from an aspect
4047 procedure Process_Interrupt_Or_Attach_Handler
;
4048 -- Common processing for Interrupt and Attach_Handler pragmas
4050 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4051 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4052 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4053 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4054 -- is not set in the Restrictions case.
4056 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4057 -- Common processing for Suppress and Unsuppress. The boolean parameter
4058 -- Suppress_Case is True for the Suppress case, and False for the
4061 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4062 -- Subsidiary to the analysis of pragmas Independent[_Components].
4063 -- Record such a pragma N applied to entity E for future checks.
4065 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4066 -- This procedure sets the Is_Exported flag for the given entity,
4067 -- checking that the entity was not previously imported. Arg is
4068 -- the argument that specified the entity. A check is also made
4069 -- for exporting inappropriate entities.
4071 procedure Set_Extended_Import_Export_External_Name
4072 (Internal_Ent
: Entity_Id
;
4073 Arg_External
: Node_Id
);
4074 -- Common processing for all extended import export pragmas. The first
4075 -- argument, Internal_Ent, is the internal entity, which has already
4076 -- been checked for validity by the caller. Arg_External is from the
4077 -- Import or Export pragma, and may be null if no External parameter
4078 -- was present. If Arg_External is present and is a non-null string
4079 -- (a null string is treated as the default), then the Interface_Name
4080 -- field of Internal_Ent is set appropriately.
4082 procedure Set_Imported
(E
: Entity_Id
);
4083 -- This procedure sets the Is_Imported flag for the given entity,
4084 -- checking that it is not previously exported or imported.
4086 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4087 -- Mech is a parameter passing mechanism (see Import_Function syntax
4088 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4089 -- has the right form, and if not issues an error message. If the
4090 -- argument has the right form then the Mechanism field of Ent is
4091 -- set appropriately.
4093 procedure Set_Rational_Profile
;
4094 -- Activate the set of configuration pragmas and permissions that make
4095 -- up the Rational profile.
4097 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4098 -- Activate the set of configuration pragmas and restrictions that make
4099 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4100 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4101 -- which is used for error messages on any constructs violating the
4104 ----------------------------------
4105 -- Acquire_Warning_Match_String --
4106 ----------------------------------
4108 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4110 String_To_Name_Buffer
4111 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4113 -- Add asterisk at start if not already there
4115 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4116 Name_Buffer
(2 .. Name_Len
+ 1) :=
4117 Name_Buffer
(1 .. Name_Len
);
4118 Name_Buffer
(1) := '*';
4119 Name_Len
:= Name_Len
+ 1;
4122 -- Add asterisk at end if not already there
4124 if Name_Buffer
(Name_Len
) /= '*' then
4125 Name_Len
:= Name_Len
+ 1;
4126 Name_Buffer
(Name_Len
) := '*';
4128 end Acquire_Warning_Match_String
;
4130 ---------------------
4131 -- Ada_2005_Pragma --
4132 ---------------------
4134 procedure Ada_2005_Pragma
is
4136 if Ada_Version
<= Ada_95
then
4137 Check_Restriction
(No_Implementation_Pragmas
, N
);
4139 end Ada_2005_Pragma
;
4141 ---------------------
4142 -- Ada_2012_Pragma --
4143 ---------------------
4145 procedure Ada_2012_Pragma
is
4147 if Ada_Version
<= Ada_2005
then
4148 Check_Restriction
(No_Implementation_Pragmas
, N
);
4150 end Ada_2012_Pragma
;
4152 ----------------------------
4153 -- Analyze_Depends_Global --
4154 ----------------------------
4156 procedure Analyze_Depends_Global
4157 (Spec_Id
: out Entity_Id
;
4158 Subp_Decl
: out Node_Id
;
4159 Legal
: out Boolean)
4162 -- Assume that the pragma is illegal
4169 Check_Arg_Count
(1);
4171 -- Ensure the proper placement of the pragma. Depends/Global must be
4172 -- associated with a subprogram declaration or a body that acts as a
4175 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4179 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4182 -- Generic subprogram
4184 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4187 -- Object declaration of a single concurrent type
4189 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4190 and then Is_Single_Concurrent_Object
4191 (Unique_Defining_Entity
(Subp_Decl
))
4197 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4200 -- Subprogram body acts as spec
4202 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4203 and then No
(Corresponding_Spec
(Subp_Decl
))
4207 -- Subprogram body stub acts as spec
4209 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4210 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4214 -- Subprogram declaration
4216 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4221 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4229 -- If we get here, then the pragma is legal
4232 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4234 -- When the related context is an entry, the entry must belong to a
4235 -- protected unit (SPARK RM 6.1.4(6)).
4237 if Is_Entry_Declaration
(Spec_Id
)
4238 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4243 -- When the related context is an anonymous object created for a
4244 -- simple concurrent type, the type must be a task
4245 -- (SPARK RM 6.1.4(6)).
4247 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4248 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4254 -- A pragma that applies to a Ghost entity becomes Ghost for the
4255 -- purposes of legality checks and removal of ignored Ghost code.
4257 Mark_Ghost_Pragma
(N
, Spec_Id
);
4258 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4259 end Analyze_Depends_Global
;
4261 ------------------------
4262 -- Analyze_If_Present --
4263 ------------------------
4265 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4269 pragma Assert
(Is_List_Member
(N
));
4271 -- Inspect the declarations or statements following pragma N looking
4272 -- for another pragma whose Id matches the caller's request. If it is
4273 -- available, analyze it.
4276 while Present
(Stmt
) loop
4277 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4278 Analyze_Pragma
(Stmt
);
4281 -- The first source declaration or statement immediately following
4282 -- N ends the region where a pragma may appear.
4284 elsif Comes_From_Source
(Stmt
) then
4290 end Analyze_If_Present
;
4292 --------------------------------
4293 -- Analyze_Pre_Post_Condition --
4294 --------------------------------
4296 procedure Analyze_Pre_Post_Condition
is
4297 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4298 Subp_Decl
: Node_Id
;
4299 Subp_Id
: Entity_Id
;
4301 Duplicates_OK
: Boolean := False;
4302 -- Flag set when a pre/postcondition allows multiple pragmas of the
4305 In_Body_OK
: Boolean := False;
4306 -- Flag set when a pre/postcondition is allowed to appear on a body
4307 -- even though the subprogram may have a spec.
4309 Is_Pre_Post
: Boolean := False;
4310 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4313 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4314 -- Implement rules in AI12-0131: an overriding operation can have
4315 -- a class-wide precondition only if one of its ancestors has an
4316 -- explicit class-wide precondition.
4318 -----------------------------
4319 -- Inherits_Class_Wide_Pre --
4320 -----------------------------
4322 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4323 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4326 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4329 -- Check ancestors on the overriding operation to examine the
4330 -- preconditions that may apply to them.
4332 while Present
(Prev
) loop
4333 Cont
:= Contract
(Prev
);
4334 if Present
(Cont
) then
4335 Prag
:= Pre_Post_Conditions
(Cont
);
4336 while Present
(Prag
) loop
4337 if Class_Present
(Prag
) then
4341 Prag
:= Next_Pragma
(Prag
);
4345 -- For a type derived from a generic formal type, the operation
4346 -- inheriting the condition is a renaming, not an overriding of
4347 -- the operation of the formal. Ditto for an inherited
4348 -- operation which has no explicit contracts.
4350 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4351 or else not Comes_From_Source
(Prev
)
4353 Prev
:= Alias
(Prev
);
4355 Prev
:= Overridden_Operation
(Prev
);
4359 -- If the controlling type of the subprogram has progenitors, an
4360 -- interface operation implemented by the current operation may
4361 -- have a class-wide precondition.
4363 if Has_Interfaces
(Typ
) then
4368 Prim_Elmt
: Elmt_Id
;
4369 Prim_List
: Elist_Id
;
4372 Collect_Interfaces
(Typ
, Ints
);
4373 Elmt
:= First_Elmt
(Ints
);
4375 -- Iterate over the primitive operations of each interface
4377 while Present
(Elmt
) loop
4378 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4379 Prim_Elmt
:= First_Elmt
(Prim_List
);
4380 while Present
(Prim_Elmt
) loop
4381 Prim
:= Node
(Prim_Elmt
);
4382 if Chars
(Prim
) = Chars
(E
)
4383 and then Present
(Contract
(Prim
))
4384 and then Class_Present
4385 (Pre_Post_Conditions
(Contract
(Prim
)))
4390 Next_Elmt
(Prim_Elmt
);
4399 end Inherits_Class_Wide_Pre
;
4401 -- Start of processing for Analyze_Pre_Post_Condition
4404 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4405 -- offer uniformity among the various kinds of pre/postconditions by
4406 -- rewriting the pragma identifier. This allows the retrieval of the
4407 -- original pragma name by routine Original_Aspect_Pragma_Name.
4409 if Comes_From_Source
(N
) then
4410 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4411 Is_Pre_Post
:= True;
4412 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4413 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4415 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4416 Is_Pre_Post
:= True;
4417 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4418 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4422 -- Determine the semantics with respect to duplicates and placement
4423 -- in a body. Pragmas Precondition and Postcondition were introduced
4424 -- before aspects and are not subject to the same aspect-like rules.
4426 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4427 Duplicates_OK
:= True;
4433 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4434 -- argument without an identifier.
4437 Check_Arg_Count
(1);
4438 Check_No_Identifiers
;
4440 -- Pragmas Precondition and Postcondition have complex argument
4444 Check_At_Least_N_Arguments
(1);
4445 Check_At_Most_N_Arguments
(2);
4446 Check_Optional_Identifier
(Arg1
, Name_Check
);
4448 if Present
(Arg2
) then
4449 Check_Optional_Identifier
(Arg2
, Name_Message
);
4450 Preanalyze_Spec_Expression
4451 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4455 -- For a pragma PPC in the extended main source unit, record enabled
4457 -- ??? nothing checks that the pragma is in the main source unit
4459 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4460 Set_SCO_Pragma_Enabled
(Loc
);
4463 -- Ensure the proper placement of the pragma
4466 Find_Related_Declaration_Or_Body
4467 (N
, Do_Checks
=> not Duplicates_OK
);
4469 -- When a pre/postcondition pragma applies to an abstract subprogram,
4470 -- its original form must be an aspect with 'Class.
4472 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4473 if not From_Aspect_Specification
(N
) then
4475 ("pragma % cannot be applied to abstract subprogram");
4477 elsif not Class_Present
(N
) then
4479 ("aspect % requires ''Class for abstract subprogram");
4482 -- Entry declaration
4484 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4487 -- Generic subprogram declaration
4489 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4494 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4495 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4499 -- Subprogram body stub
4501 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4502 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4506 -- Subprogram declaration
4508 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4510 -- AI05-0230: When a pre/postcondition pragma applies to a null
4511 -- procedure, its original form must be an aspect with 'Class.
4513 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4514 and then Null_Present
(Specification
(Subp_Decl
))
4515 and then From_Aspect_Specification
(N
)
4516 and then not Class_Present
(N
)
4518 Error_Pragma
("aspect % requires ''Class for null procedure");
4521 -- Implement the legality checks mandated by AI12-0131:
4522 -- Pre'Class shall not be specified for an overriding primitive
4523 -- subprogram of a tagged type T unless the Pre'Class aspect is
4524 -- specified for the corresponding primitive subprogram of some
4528 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4531 if Class_Present
(N
)
4532 and then Pragma_Name
(N
) = Name_Precondition
4533 and then Present
(Overridden_Operation
(E
))
4534 and then not Inherits_Class_Wide_Pre
(E
)
4537 ("illegal class-wide precondition on overriding operation",
4538 Corresponding_Aspect
(N
));
4542 -- A renaming declaration may inherit a generated pragma, its
4543 -- placement comes from expansion, not from source.
4545 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4546 and then not Comes_From_Source
(N
)
4550 -- Otherwise the placement is illegal
4557 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4559 -- A pragma that applies to a Ghost entity becomes Ghost for the
4560 -- purposes of legality checks and removal of ignored Ghost code.
4562 Mark_Ghost_Pragma
(N
, Subp_Id
);
4564 -- Chain the pragma on the contract for further processing by
4565 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4567 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4569 -- Fully analyze the pragma when it appears inside an entry or
4570 -- subprogram body because it cannot benefit from forward references.
4572 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4574 N_Subprogram_Body_Stub
)
4576 -- The legality checks of pragmas Precondition and Postcondition
4577 -- are affected by the SPARK mode in effect and the volatility of
4578 -- the context. Analyze all pragmas in a specific order.
4580 Analyze_If_Present
(Pragma_SPARK_Mode
);
4581 Analyze_If_Present
(Pragma_Volatile_Function
);
4582 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4584 end Analyze_Pre_Post_Condition
;
4586 -----------------------------------------
4587 -- Analyze_Refined_Depends_Global_Post --
4588 -----------------------------------------
4590 procedure Analyze_Refined_Depends_Global_Post
4591 (Spec_Id
: out Entity_Id
;
4592 Body_Id
: out Entity_Id
;
4593 Legal
: out Boolean)
4595 Body_Decl
: Node_Id
;
4596 Spec_Decl
: Node_Id
;
4599 -- Assume that the pragma is illegal
4606 Check_Arg_Count
(1);
4607 Check_No_Identifiers
;
4609 -- Verify the placement of the pragma and check for duplicates. The
4610 -- pragma must apply to a subprogram body [stub].
4612 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4616 if Nkind
(Body_Decl
) = N_Entry_Body
then
4621 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4624 -- Subprogram body stub
4626 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4631 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4639 Body_Id
:= Defining_Entity
(Body_Decl
);
4640 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4642 -- The pragma must apply to the second declaration of a subprogram.
4643 -- In other words, the body [stub] cannot acts as a spec.
4645 if No
(Spec_Id
) then
4646 Error_Pragma
("pragma % cannot apply to a stand alone body");
4649 -- Catch the case where the subprogram body is a subunit and acts as
4650 -- the third declaration of the subprogram.
4652 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4653 Error_Pragma
("pragma % cannot apply to a subunit");
4657 -- A refined pragma can only apply to the body [stub] of a subprogram
4658 -- declared in the visible part of a package. Retrieve the context of
4659 -- the subprogram declaration.
4661 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4663 -- When dealing with protected entries or protected subprograms, use
4664 -- the enclosing protected type as the proper context.
4666 if Ekind_In
(Spec_Id
, E_Entry
,
4670 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4672 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4675 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4677 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4678 & "subprogram declared in a package specification"));
4682 -- If we get here, then the pragma is legal
4686 -- A pragma that applies to a Ghost entity becomes Ghost for the
4687 -- purposes of legality checks and removal of ignored Ghost code.
4689 Mark_Ghost_Pragma
(N
, Spec_Id
);
4691 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4692 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4694 end Analyze_Refined_Depends_Global_Post
;
4696 ----------------------------------
4697 -- Analyze_Unmodified_Or_Unused --
4698 ----------------------------------
4700 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4705 Ghost_Error_Posted
: Boolean := False;
4706 -- Flag set when an error concerning the illegal mix of Ghost and
4707 -- non-Ghost variables is emitted.
4709 Ghost_Id
: Entity_Id
:= Empty
;
4710 -- The entity of the first Ghost variable encountered while
4711 -- processing the arguments of the pragma.
4715 Check_At_Least_N_Arguments
(1);
4717 -- Loop through arguments
4720 while Present
(Arg
) loop
4721 Check_No_Identifier
(Arg
);
4723 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4724 -- in fact generate reference, so that the entity will have a
4725 -- reference, which will inhibit any warnings about it not
4726 -- being referenced, and also properly show up in the ali file
4727 -- as a reference. But this reference is recorded before the
4728 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4729 -- generated for this reference.
4731 Check_Arg_Is_Local_Name
(Arg
);
4732 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4734 if Is_Entity_Name
(Arg_Expr
) then
4735 Arg_Id
:= Entity
(Arg_Expr
);
4737 -- Skip processing the argument if already flagged
4739 if Is_Assignable
(Arg_Id
)
4740 and then not Has_Pragma_Unmodified
(Arg_Id
)
4741 and then not Has_Pragma_Unused
(Arg_Id
)
4743 Set_Has_Pragma_Unmodified
(Arg_Id
);
4746 Set_Has_Pragma_Unused
(Arg_Id
);
4749 -- A pragma that applies to a Ghost entity becomes Ghost for
4750 -- the purposes of legality checks and removal of ignored
4753 Mark_Ghost_Pragma
(N
, Arg_Id
);
4755 -- Capture the entity of the first Ghost variable being
4756 -- processed for error detection purposes.
4758 if Is_Ghost_Entity
(Arg_Id
) then
4759 if No
(Ghost_Id
) then
4763 -- Otherwise the variable is non-Ghost. It is illegal to mix
4764 -- references to Ghost and non-Ghost entities
4767 elsif Present
(Ghost_Id
)
4768 and then not Ghost_Error_Posted
4770 Ghost_Error_Posted
:= True;
4772 Error_Msg_Name_1
:= Pname
;
4774 ("pragma % cannot mention ghost and non-ghost "
4777 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4778 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4780 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4781 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4784 -- Warn if already flagged as Unused or Unmodified
4786 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4787 if Has_Pragma_Unused
(Arg_Id
) then
4789 ("??pragma Unused already given for &!", Arg_Expr
,
4793 ("??pragma Unmodified already given for &!", Arg_Expr
,
4797 -- Otherwise the pragma referenced an illegal entity
4801 ("pragma% can only be applied to a variable", Arg_Expr
);
4807 end Analyze_Unmodified_Or_Unused
;
4809 -----------------------------------
4810 -- Analyze_Unreference_Or_Unused --
4811 -----------------------------------
4813 procedure Analyze_Unreferenced_Or_Unused
4814 (Is_Unused
: Boolean := False)
4821 Ghost_Error_Posted
: Boolean := False;
4822 -- Flag set when an error concerning the illegal mix of Ghost and
4823 -- non-Ghost names is emitted.
4825 Ghost_Id
: Entity_Id
:= Empty
;
4826 -- The entity of the first Ghost name encountered while processing
4827 -- the arguments of the pragma.
4831 Check_At_Least_N_Arguments
(1);
4833 -- Check case of appearing within context clause
4835 if not Is_Unused
and then Is_In_Context_Clause
then
4837 -- The arguments must all be units mentioned in a with clause in
4838 -- the same context clause. Note that Par.Prag already checked
4839 -- that the arguments are either identifiers or selected
4843 while Present
(Arg
) loop
4844 Citem
:= First
(List_Containing
(N
));
4845 while Citem
/= N
loop
4846 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4848 if Nkind
(Citem
) = N_With_Clause
4849 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4851 Set_Has_Pragma_Unreferenced
4854 (Library_Unit
(Citem
))));
4855 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4864 ("argument of pragma% is not withed unit", Arg
);
4870 -- Case of not in list of context items
4874 while Present
(Arg
) loop
4875 Check_No_Identifier
(Arg
);
4877 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4878 -- in fact generate reference, so that the entity will have a
4879 -- reference, which will inhibit any warnings about it not
4880 -- being referenced, and also properly show up in the ali file
4881 -- as a reference. But this reference is recorded before the
4882 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4883 -- generated for this reference.
4885 Check_Arg_Is_Local_Name
(Arg
);
4886 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4888 if Is_Entity_Name
(Arg_Expr
) then
4889 Arg_Id
:= Entity
(Arg_Expr
);
4891 -- Warn if already flagged as Unused or Unreferenced and
4892 -- skip processing the argument.
4894 if Has_Pragma_Unreferenced
(Arg_Id
) then
4895 if Has_Pragma_Unused
(Arg_Id
) then
4897 ("??pragma Unused already given for &!", Arg_Expr
,
4901 ("??pragma Unreferenced already given for &!",
4905 -- Apply Unreferenced to the entity
4908 -- If the entity is overloaded, the pragma applies to the
4909 -- most recent overloading, as documented. In this case,
4910 -- name resolution does not generate a reference, so it
4911 -- must be done here explicitly.
4913 if Is_Overloaded
(Arg_Expr
) then
4914 Generate_Reference
(Arg_Id
, N
);
4917 Set_Has_Pragma_Unreferenced
(Arg_Id
);
4920 Set_Has_Pragma_Unused
(Arg_Id
);
4923 -- A pragma that applies to a Ghost entity becomes Ghost
4924 -- for the purposes of legality checks and removal of
4925 -- ignored Ghost code.
4927 Mark_Ghost_Pragma
(N
, Arg_Id
);
4929 -- Capture the entity of the first Ghost name being
4930 -- processed for error detection purposes.
4932 if Is_Ghost_Entity
(Arg_Id
) then
4933 if No
(Ghost_Id
) then
4937 -- Otherwise the name is non-Ghost. It is illegal to mix
4938 -- references to Ghost and non-Ghost entities
4941 elsif Present
(Ghost_Id
)
4942 and then not Ghost_Error_Posted
4944 Ghost_Error_Posted
:= True;
4946 Error_Msg_Name_1
:= Pname
;
4948 ("pragma % cannot mention ghost and non-ghost "
4951 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4953 ("\& # declared as ghost", N
, Ghost_Id
);
4955 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4957 ("\& # declared as non-ghost", N
, Arg_Id
);
4965 end Analyze_Unreferenced_Or_Unused
;
4967 --------------------------
4968 -- Check_Ada_83_Warning --
4969 --------------------------
4971 procedure Check_Ada_83_Warning
is
4973 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4974 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4976 end Check_Ada_83_Warning
;
4978 ---------------------
4979 -- Check_Arg_Count --
4980 ---------------------
4982 procedure Check_Arg_Count
(Required
: Nat
) is
4984 if Arg_Count
/= Required
then
4985 Error_Pragma
("wrong number of arguments for pragma%");
4987 end Check_Arg_Count
;
4989 --------------------------------
4990 -- Check_Arg_Is_External_Name --
4991 --------------------------------
4993 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4994 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4997 if Nkind
(Argx
) = N_Identifier
then
5001 Analyze_And_Resolve
(Argx
, Standard_String
);
5003 if Is_OK_Static_Expression
(Argx
) then
5006 elsif Etype
(Argx
) = Any_Type
then
5009 -- An interesting special case, if we have a string literal and
5010 -- we are in Ada 83 mode, then we allow it even though it will
5011 -- not be flagged as static. This allows expected Ada 83 mode
5012 -- use of external names which are string literals, even though
5013 -- technically these are not static in Ada 83.
5015 elsif Ada_Version
= Ada_83
5016 and then Nkind
(Argx
) = N_String_Literal
5020 -- Here we have a real error (non-static expression)
5023 Error_Msg_Name_1
:= Pname
;
5024 Flag_Non_Static_Expr
5025 (Fix_Error
("argument for pragma% must be a identifier or "
5026 & "static string expression!"), Argx
);
5031 end Check_Arg_Is_External_Name
;
5033 -----------------------------
5034 -- Check_Arg_Is_Identifier --
5035 -----------------------------
5037 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5038 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5040 if Nkind
(Argx
) /= N_Identifier
then
5041 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5043 end Check_Arg_Is_Identifier
;
5045 ----------------------------------
5046 -- Check_Arg_Is_Integer_Literal --
5047 ----------------------------------
5049 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5050 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5052 if Nkind
(Argx
) /= N_Integer_Literal
then
5054 ("argument for pragma% must be integer literal", Argx
);
5056 end Check_Arg_Is_Integer_Literal
;
5058 -------------------------------------------
5059 -- Check_Arg_Is_Library_Level_Local_Name --
5060 -------------------------------------------
5064 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5065 -- | library_unit_NAME
5067 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5069 Check_Arg_Is_Local_Name
(Arg
);
5071 -- If it came from an aspect, we want to give the error just as if it
5072 -- came from source.
5074 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5075 and then (Comes_From_Source
(N
)
5076 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5079 ("argument for pragma% must be library level entity", Arg
);
5081 end Check_Arg_Is_Library_Level_Local_Name
;
5083 -----------------------------
5084 -- Check_Arg_Is_Local_Name --
5085 -----------------------------
5089 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5090 -- | library_unit_NAME
5092 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5093 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5096 -- If this pragma came from an aspect specification, we don't want to
5097 -- check for this error, because that would cause spurious errors, in
5098 -- case a type is frozen in a scope more nested than the type. The
5099 -- aspect itself of course can't be anywhere but on the declaration
5102 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5103 if From_Aspect_Specification
(Parent
(Arg
)) then
5107 -- Arg is the Expression of an N_Pragma_Argument_Association
5110 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5117 if Nkind
(Argx
) not in N_Direct_Name
5118 and then (Nkind
(Argx
) /= N_Attribute_Reference
5119 or else Present
(Expressions
(Argx
))
5120 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5121 and then (not Is_Entity_Name
(Argx
)
5122 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5124 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5127 -- No further check required if not an entity name
5129 if not Is_Entity_Name
(Argx
) then
5135 Ent
: constant Entity_Id
:= Entity
(Argx
);
5136 Scop
: constant Entity_Id
:= Scope
(Ent
);
5139 -- Case of a pragma applied to a compilation unit: pragma must
5140 -- occur immediately after the program unit in the compilation.
5142 if Is_Compilation_Unit
(Ent
) then
5144 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5147 -- Case of pragma placed immediately after spec
5149 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5152 -- Case of pragma placed immediately after body
5154 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5155 and then Present
(Corresponding_Body
(Decl
))
5159 (Parent
(Unit_Declaration_Node
5160 (Corresponding_Body
(Decl
))));
5162 -- All other cases are illegal
5169 -- Special restricted placement rule from 10.2.1(11.8/2)
5171 elsif Is_Generic_Formal
(Ent
)
5172 and then Prag_Id
= Pragma_Preelaborable_Initialization
5174 OK
:= List_Containing
(N
) =
5175 Generic_Formal_Declarations
5176 (Unit_Declaration_Node
(Scop
));
5178 -- If this is an aspect applied to a subprogram body, the
5179 -- pragma is inserted in its declarative part.
5181 elsif From_Aspect_Specification
(N
)
5182 and then Ent
= Current_Scope
5184 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5188 -- If the aspect is a predicate (possibly others ???) and the
5189 -- context is a record type, this is a discriminant expression
5190 -- within a type declaration, that freezes the predicated
5193 elsif From_Aspect_Specification
(N
)
5194 and then Prag_Id
= Pragma_Predicate
5195 and then Ekind
(Current_Scope
) = E_Record_Type
5196 and then Scop
= Scope
(Current_Scope
)
5200 -- Default case, just check that the pragma occurs in the scope
5201 -- of the entity denoted by the name.
5204 OK
:= Current_Scope
= Scop
;
5209 ("pragma% argument must be in same declarative part", Arg
);
5213 end Check_Arg_Is_Local_Name
;
5215 ---------------------------------
5216 -- Check_Arg_Is_Locking_Policy --
5217 ---------------------------------
5219 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5220 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5223 Check_Arg_Is_Identifier
(Argx
);
5225 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5226 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5228 end Check_Arg_Is_Locking_Policy
;
5230 -----------------------------------------------
5231 -- Check_Arg_Is_Partition_Elaboration_Policy --
5232 -----------------------------------------------
5234 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5235 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5238 Check_Arg_Is_Identifier
(Argx
);
5240 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5242 ("& is not a valid partition elaboration policy name", Argx
);
5244 end Check_Arg_Is_Partition_Elaboration_Policy
;
5246 -------------------------
5247 -- Check_Arg_Is_One_Of --
5248 -------------------------
5250 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5251 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5254 Check_Arg_Is_Identifier
(Argx
);
5256 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5257 Error_Msg_Name_2
:= N1
;
5258 Error_Msg_Name_3
:= N2
;
5259 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5261 end Check_Arg_Is_One_Of
;
5263 procedure Check_Arg_Is_One_Of
5265 N1
, N2
, N3
: Name_Id
)
5267 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5270 Check_Arg_Is_Identifier
(Argx
);
5272 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5273 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5275 end Check_Arg_Is_One_Of
;
5277 procedure Check_Arg_Is_One_Of
5279 N1
, N2
, N3
, N4
: Name_Id
)
5281 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5284 Check_Arg_Is_Identifier
(Argx
);
5286 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5287 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5289 end Check_Arg_Is_One_Of
;
5291 procedure Check_Arg_Is_One_Of
5293 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5295 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5298 Check_Arg_Is_Identifier
(Argx
);
5300 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5301 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5303 end Check_Arg_Is_One_Of
;
5305 ---------------------------------
5306 -- Check_Arg_Is_Queuing_Policy --
5307 ---------------------------------
5309 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5310 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5313 Check_Arg_Is_Identifier
(Argx
);
5315 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5316 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5318 end Check_Arg_Is_Queuing_Policy
;
5320 ---------------------------------------
5321 -- Check_Arg_Is_OK_Static_Expression --
5322 ---------------------------------------
5324 procedure Check_Arg_Is_OK_Static_Expression
5326 Typ
: Entity_Id
:= Empty
)
5329 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5330 end Check_Arg_Is_OK_Static_Expression
;
5332 ------------------------------------------
5333 -- Check_Arg_Is_Task_Dispatching_Policy --
5334 ------------------------------------------
5336 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5337 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5340 Check_Arg_Is_Identifier
(Argx
);
5342 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5344 ("& is not an allowed task dispatching policy name", Argx
);
5346 end Check_Arg_Is_Task_Dispatching_Policy
;
5348 ---------------------
5349 -- Check_Arg_Order --
5350 ---------------------
5352 procedure Check_Arg_Order
(Names
: Name_List
) is
5355 Highest_So_Far
: Natural := 0;
5356 -- Highest index in Names seen do far
5360 for J
in 1 .. Arg_Count
loop
5361 if Chars
(Arg
) /= No_Name
then
5362 for K
in Names
'Range loop
5363 if Chars
(Arg
) = Names
(K
) then
5364 if K
< Highest_So_Far
then
5365 Error_Msg_Name_1
:= Pname
;
5367 ("parameters out of order for pragma%", Arg
);
5368 Error_Msg_Name_1
:= Names
(K
);
5369 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5370 Error_Msg_N
("\% must appear before %", Arg
);
5374 Highest_So_Far
:= K
;
5382 end Check_Arg_Order
;
5384 --------------------------------
5385 -- Check_At_Least_N_Arguments --
5386 --------------------------------
5388 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5390 if Arg_Count
< N
then
5391 Error_Pragma
("too few arguments for pragma%");
5393 end Check_At_Least_N_Arguments
;
5395 -------------------------------
5396 -- Check_At_Most_N_Arguments --
5397 -------------------------------
5399 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5402 if Arg_Count
> N
then
5404 for J
in 1 .. N
loop
5406 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5409 end Check_At_Most_N_Arguments
;
5411 ---------------------
5412 -- Check_Component --
5413 ---------------------
5415 procedure Check_Component
5418 In_Variant_Part
: Boolean := False)
5420 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5421 Sindic
: constant Node_Id
:=
5422 Subtype_Indication
(Component_Definition
(Comp
));
5423 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5426 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5427 -- object constraint, then the component type shall be an Unchecked_
5430 if Nkind
(Sindic
) = N_Subtype_Indication
5431 and then Has_Per_Object_Constraint
(Comp_Id
)
5432 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5435 ("component subtype subject to per-object constraint "
5436 & "must be an Unchecked_Union", Comp
);
5438 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5439 -- the body of a generic unit, or within the body of any of its
5440 -- descendant library units, no part of the type of a component
5441 -- declared in a variant_part of the unchecked union type shall be of
5442 -- a formal private type or formal private extension declared within
5443 -- the formal part of the generic unit.
5445 elsif Ada_Version
>= Ada_2012
5446 and then In_Generic_Body
(UU_Typ
)
5447 and then In_Variant_Part
5448 and then Is_Private_Type
(Typ
)
5449 and then Is_Generic_Type
(Typ
)
5452 ("component of unchecked union cannot be of generic type", Comp
);
5454 elsif Needs_Finalization
(Typ
) then
5456 ("component of unchecked union cannot be controlled", Comp
);
5458 elsif Has_Task
(Typ
) then
5460 ("component of unchecked union cannot have tasks", Comp
);
5462 end Check_Component
;
5464 ----------------------------
5465 -- Check_Duplicate_Pragma --
5466 ----------------------------
5468 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5469 Id
: Entity_Id
:= E
;
5473 -- Nothing to do if this pragma comes from an aspect specification,
5474 -- since we could not be duplicating a pragma, and we dealt with the
5475 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5477 if From_Aspect_Specification
(N
) then
5481 -- Otherwise current pragma may duplicate previous pragma or a
5482 -- previously given aspect specification or attribute definition
5483 -- clause for the same pragma.
5485 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5489 -- If the entity is a type, then we have to make sure that the
5490 -- ostensible duplicate is not for a parent type from which this
5494 if Nkind
(P
) = N_Pragma
then
5496 Args
: constant List_Id
:=
5497 Pragma_Argument_Associations
(P
);
5500 and then Is_Entity_Name
(Expression
(First
(Args
)))
5501 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5502 and then Entity
(Expression
(First
(Args
))) /= E
5508 elsif Nkind
(P
) = N_Aspect_Specification
5509 and then Is_Type
(Entity
(P
))
5510 and then Entity
(P
) /= E
5516 -- Here we have a definite duplicate
5518 Error_Msg_Name_1
:= Pragma_Name
(N
);
5519 Error_Msg_Sloc
:= Sloc
(P
);
5521 -- For a single protected or a single task object, the error is
5522 -- issued on the original entity.
5524 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5525 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5528 if Nkind
(P
) = N_Aspect_Specification
5529 or else From_Aspect_Specification
(P
)
5531 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5533 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5538 end Check_Duplicate_Pragma
;
5540 ----------------------------------
5541 -- Check_Duplicated_Export_Name --
5542 ----------------------------------
5544 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5545 String_Val
: constant String_Id
:= Strval
(Nam
);
5548 -- We are only interested in the export case, and in the case of
5549 -- generics, it is the instance, not the template, that is the
5550 -- problem (the template will generate a warning in any case).
5552 if not Inside_A_Generic
5553 and then (Prag_Id
= Pragma_Export
5555 Prag_Id
= Pragma_Export_Procedure
5557 Prag_Id
= Pragma_Export_Valued_Procedure
5559 Prag_Id
= Pragma_Export_Function
)
5561 for J
in Externals
.First
.. Externals
.Last
loop
5562 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5563 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5564 Error_Msg_N
("external name duplicates name given#", Nam
);
5569 Externals
.Append
(Nam
);
5571 end Check_Duplicated_Export_Name
;
5573 ----------------------------------------
5574 -- Check_Expr_Is_OK_Static_Expression --
5575 ----------------------------------------
5577 procedure Check_Expr_Is_OK_Static_Expression
5579 Typ
: Entity_Id
:= Empty
)
5582 if Present
(Typ
) then
5583 Analyze_And_Resolve
(Expr
, Typ
);
5585 Analyze_And_Resolve
(Expr
);
5588 -- An expression cannot be considered static if its resolution failed
5589 -- or if it's erroneous. Stop the analysis of the related pragma.
5591 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5594 elsif Is_OK_Static_Expression
(Expr
) then
5597 -- An interesting special case, if we have a string literal and we
5598 -- are in Ada 83 mode, then we allow it even though it will not be
5599 -- flagged as static. This allows the use of Ada 95 pragmas like
5600 -- Import in Ada 83 mode. They will of course be flagged with
5601 -- warnings as usual, but will not cause errors.
5603 elsif Ada_Version
= Ada_83
5604 and then Nkind
(Expr
) = N_String_Literal
5608 -- Finally, we have a real error
5611 Error_Msg_Name_1
:= Pname
;
5612 Flag_Non_Static_Expr
5613 (Fix_Error
("argument for pragma% must be a static expression!"),
5617 end Check_Expr_Is_OK_Static_Expression
;
5619 -------------------------
5620 -- Check_First_Subtype --
5621 -------------------------
5623 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5624 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5625 Ent
: constant Entity_Id
:= Entity
(Argx
);
5628 if Is_First_Subtype
(Ent
) then
5631 elsif Is_Type
(Ent
) then
5633 ("pragma% cannot apply to subtype", Argx
);
5635 elsif Is_Object
(Ent
) then
5637 ("pragma% cannot apply to object, requires a type", Argx
);
5641 ("pragma% cannot apply to&, requires a type", Argx
);
5643 end Check_First_Subtype
;
5645 ----------------------
5646 -- Check_Identifier --
5647 ----------------------
5649 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5652 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5654 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5655 Error_Msg_Name_1
:= Pname
;
5656 Error_Msg_Name_2
:= Id
;
5657 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5661 end Check_Identifier
;
5663 --------------------------------
5664 -- Check_Identifier_Is_One_Of --
5665 --------------------------------
5667 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5670 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5672 if Chars
(Arg
) = No_Name
then
5673 Error_Msg_Name_1
:= Pname
;
5674 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5677 elsif Chars
(Arg
) /= N1
5678 and then Chars
(Arg
) /= N2
5680 Error_Msg_Name_1
:= Pname
;
5681 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5685 end Check_Identifier_Is_One_Of
;
5687 ---------------------------
5688 -- Check_In_Main_Program --
5689 ---------------------------
5691 procedure Check_In_Main_Program
is
5692 P
: constant Node_Id
:= Parent
(N
);
5695 -- Must be in subprogram body
5697 if Nkind
(P
) /= N_Subprogram_Body
then
5698 Error_Pragma
("% pragma allowed only in subprogram");
5700 -- Otherwise warn if obviously not main program
5702 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5703 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5705 Error_Msg_Name_1
:= Pname
;
5707 ("??pragma% is only effective in main program", N
);
5709 end Check_In_Main_Program
;
5711 ---------------------------------------
5712 -- Check_Interrupt_Or_Attach_Handler --
5713 ---------------------------------------
5715 procedure Check_Interrupt_Or_Attach_Handler
is
5716 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5717 Handler_Proc
, Proc_Scope
: Entity_Id
;
5722 if Prag_Id
= Pragma_Interrupt_Handler
then
5723 Check_Restriction
(No_Dynamic_Attachment
, N
);
5726 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5727 Proc_Scope
:= Scope
(Handler_Proc
);
5729 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5731 ("argument of pragma% must be protected procedure", Arg1
);
5734 -- For pragma case (as opposed to access case), check placement.
5735 -- We don't need to do that for aspects, because we have the
5736 -- check that they aspect applies an appropriate procedure.
5738 if not From_Aspect_Specification
(N
)
5739 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5741 Error_Pragma
("pragma% must be in protected definition");
5744 if not Is_Library_Level_Entity
(Proc_Scope
) then
5746 ("argument for pragma% must be library level entity", Arg1
);
5749 -- AI05-0033: A pragma cannot appear within a generic body, because
5750 -- instance can be in a nested scope. The check that protected type
5751 -- is itself a library-level declaration is done elsewhere.
5753 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5754 -- handle code prior to AI-0033. Analysis tools typically are not
5755 -- interested in this pragma in any case, so no need to worry too
5756 -- much about its placement.
5758 if Inside_A_Generic
then
5759 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5760 and then In_Package_Body
(Scope
(Current_Scope
))
5761 and then not Relaxed_RM_Semantics
5763 Error_Pragma
("pragma% cannot be used inside a generic");
5766 end Check_Interrupt_Or_Attach_Handler
;
5768 ---------------------------------
5769 -- Check_Loop_Pragma_Placement --
5770 ---------------------------------
5772 procedure Check_Loop_Pragma_Placement
is
5773 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5774 -- Verify whether the current pragma is properly grouped with other
5775 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5776 -- related loop where the pragma appears.
5778 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5779 -- Determine whether an arbitrary statement Stmt denotes pragma
5780 -- Loop_Invariant or Loop_Variant.
5782 procedure Placement_Error
(Constr
: Node_Id
);
5783 pragma No_Return
(Placement_Error
);
5784 -- Node Constr denotes the last loop restricted construct before we
5785 -- encountered an illegal relation between enclosing constructs. Emit
5786 -- an error depending on what Constr was.
5788 --------------------------------
5789 -- Check_Loop_Pragma_Grouping --
5790 --------------------------------
5792 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5793 Stop_Search
: exception;
5794 -- This exception is used to terminate the recursive descent of
5795 -- routine Check_Grouping.
5797 procedure Check_Grouping
(L
: List_Id
);
5798 -- Find the first group of pragmas in list L and if successful,
5799 -- ensure that the current pragma is part of that group. The
5800 -- routine raises Stop_Search once such a check is performed to
5801 -- halt the recursive descent.
5803 procedure Grouping_Error
(Prag
: Node_Id
);
5804 pragma No_Return
(Grouping_Error
);
5805 -- Emit an error concerning the current pragma indicating that it
5806 -- should be placed after pragma Prag.
5808 --------------------
5809 -- Check_Grouping --
5810 --------------------
5812 procedure Check_Grouping
(L
: List_Id
) is
5818 -- Inspect the list of declarations or statements looking for
5819 -- the first grouping of pragmas:
5822 -- pragma Loop_Invariant ...;
5823 -- pragma Loop_Variant ...;
5825 -- pragma Loop_Variant ...; -- current pragma
5827 -- If the current pragma is not in the grouping, then it must
5828 -- either appear in a different declarative or statement list
5829 -- or the construct at (1) is separating the pragma from the
5833 while Present
(Stmt
) loop
5835 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5836 -- inside a loop or a block housed inside a loop. Inspect
5837 -- the declarations and statements of the block as they may
5838 -- contain the first grouping.
5840 if Nkind
(Stmt
) = N_Block_Statement
then
5841 HSS
:= Handled_Statement_Sequence
(Stmt
);
5843 Check_Grouping
(Declarations
(Stmt
));
5845 if Present
(HSS
) then
5846 Check_Grouping
(Statements
(HSS
));
5849 -- First pragma of the first topmost grouping has been found
5851 elsif Is_Loop_Pragma
(Stmt
) then
5853 -- The group and the current pragma are not in the same
5854 -- declarative or statement list.
5856 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5857 Grouping_Error
(Stmt
);
5859 -- Try to reach the current pragma from the first pragma
5860 -- of the grouping while skipping other members:
5862 -- pragma Loop_Invariant ...; -- first pragma
5863 -- pragma Loop_Variant ...; -- member
5865 -- pragma Loop_Variant ...; -- current pragma
5868 while Present
(Stmt
) loop
5870 -- The current pragma is either the first pragma
5871 -- of the group or is a member of the group. Stop
5872 -- the search as the placement is legal.
5877 -- Skip group members, but keep track of the last
5878 -- pragma in the group.
5880 elsif Is_Loop_Pragma
(Stmt
) then
5883 -- Skip declarations and statements generated by
5884 -- the compiler during expansion.
5886 elsif not Comes_From_Source
(Stmt
) then
5889 -- A non-pragma is separating the group from the
5890 -- current pragma, the placement is illegal.
5893 Grouping_Error
(Prag
);
5899 -- If the traversal did not reach the current pragma,
5900 -- then the list must be malformed.
5902 raise Program_Error
;
5910 --------------------
5911 -- Grouping_Error --
5912 --------------------
5914 procedure Grouping_Error
(Prag
: Node_Id
) is
5916 Error_Msg_Sloc
:= Sloc
(Prag
);
5917 Error_Pragma
("pragma% must appear next to pragma#");
5920 -- Start of processing for Check_Loop_Pragma_Grouping
5923 -- Inspect the statements of the loop or nested blocks housed
5924 -- within to determine whether the current pragma is part of the
5925 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5927 Check_Grouping
(Statements
(Loop_Stmt
));
5930 when Stop_Search
=> null;
5931 end Check_Loop_Pragma_Grouping
;
5933 --------------------
5934 -- Is_Loop_Pragma --
5935 --------------------
5937 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5939 -- Inspect the original node as Loop_Invariant and Loop_Variant
5940 -- pragmas are rewritten to null when assertions are disabled.
5942 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5944 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
5945 Name_Loop_Invariant
,
5952 ---------------------
5953 -- Placement_Error --
5954 ---------------------
5956 procedure Placement_Error
(Constr
: Node_Id
) is
5957 LA
: constant String := " with Loop_Entry";
5960 if Prag_Id
= Pragma_Assert
then
5961 Error_Msg_String
(1 .. LA
'Length) := LA
;
5962 Error_Msg_Strlen
:= LA
'Length;
5964 Error_Msg_Strlen
:= 0;
5967 if Nkind
(Constr
) = N_Pragma
then
5969 ("pragma %~ must appear immediately within the statements "
5973 ("block containing pragma %~ must appear immediately within "
5974 & "the statements of a loop", Constr
);
5976 end Placement_Error
;
5978 -- Local declarations
5983 -- Start of processing for Check_Loop_Pragma_Placement
5986 -- Check that pragma appears immediately within a loop statement,
5987 -- ignoring intervening block statements.
5991 while Present
(Stmt
) loop
5993 -- The pragma or previous block must appear immediately within the
5994 -- current block's declarative or statement part.
5996 if Nkind
(Stmt
) = N_Block_Statement
then
5997 if (No
(Declarations
(Stmt
))
5998 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6000 List_Containing
(Prev
) /=
6001 Statements
(Handled_Statement_Sequence
(Stmt
))
6003 Placement_Error
(Prev
);
6006 -- Keep inspecting the parents because we are now within a
6007 -- chain of nested blocks.
6011 Stmt
:= Parent
(Stmt
);
6014 -- The pragma or previous block must appear immediately within the
6015 -- statements of the loop.
6017 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6018 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6019 Placement_Error
(Prev
);
6022 -- Stop the traversal because we reached the innermost loop
6023 -- regardless of whether we encountered an error or not.
6027 -- Ignore a handled statement sequence. Note that this node may
6028 -- be related to a subprogram body in which case we will emit an
6029 -- error on the next iteration of the search.
6031 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6032 Stmt
:= Parent
(Stmt
);
6034 -- Any other statement breaks the chain from the pragma to the
6038 Placement_Error
(Prev
);
6043 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6044 -- grouped together with other such pragmas.
6046 if Is_Loop_Pragma
(N
) then
6048 -- The previous check should have located the related loop
6050 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6051 Check_Loop_Pragma_Grouping
(Stmt
);
6053 end Check_Loop_Pragma_Placement
;
6055 -------------------------------------------
6056 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6057 -------------------------------------------
6059 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6068 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6071 elsif Nkind_In
(P
, N_Package_Specification
,
6076 -- Note: the following tests seem a little peculiar, because
6077 -- they test for bodies, but if we were in the statement part
6078 -- of the body, we would already have hit the handled statement
6079 -- sequence, so the only way we get here is by being in the
6080 -- declarative part of the body.
6082 elsif Nkind_In
(P
, N_Subprogram_Body
,
6093 Error_Pragma
("pragma% is not in declarative part or package spec");
6094 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6096 -------------------------
6097 -- Check_No_Identifier --
6098 -------------------------
6100 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6102 if Nkind
(Arg
) = N_Pragma_Argument_Association
6103 and then Chars
(Arg
) /= No_Name
6105 Error_Pragma_Arg_Ident
6106 ("pragma% does not permit identifier& here", Arg
);
6108 end Check_No_Identifier
;
6110 --------------------------
6111 -- Check_No_Identifiers --
6112 --------------------------
6114 procedure Check_No_Identifiers
is
6118 for J
in 1 .. Arg_Count
loop
6119 Check_No_Identifier
(Arg_Node
);
6122 end Check_No_Identifiers
;
6124 ------------------------
6125 -- Check_No_Link_Name --
6126 ------------------------
6128 procedure Check_No_Link_Name
is
6130 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6134 if Present
(Arg4
) then
6136 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6138 end Check_No_Link_Name
;
6140 -------------------------------
6141 -- Check_Optional_Identifier --
6142 -------------------------------
6144 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6147 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6148 and then Chars
(Arg
) /= No_Name
6150 if Chars
(Arg
) /= Id
then
6151 Error_Msg_Name_1
:= Pname
;
6152 Error_Msg_Name_2
:= Id
;
6153 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6157 end Check_Optional_Identifier
;
6159 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6161 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6162 end Check_Optional_Identifier
;
6164 -------------------------------------
6165 -- Check_Static_Boolean_Expression --
6166 -------------------------------------
6168 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6170 if Present
(Expr
) then
6171 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6173 if not Is_OK_Static_Expression
(Expr
) then
6175 ("expression of pragma % must be static", Expr
);
6178 end Check_Static_Boolean_Expression
;
6180 -----------------------------
6181 -- Check_Static_Constraint --
6182 -----------------------------
6184 -- Note: for convenience in writing this procedure, in addition to
6185 -- the officially (i.e. by spec) allowed argument which is always a
6186 -- constraint, it also allows ranges and discriminant associations.
6187 -- Above is not clear ???
6189 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6191 procedure Require_Static
(E
: Node_Id
);
6192 -- Require given expression to be static expression
6194 --------------------
6195 -- Require_Static --
6196 --------------------
6198 procedure Require_Static
(E
: Node_Id
) is
6200 if not Is_OK_Static_Expression
(E
) then
6201 Flag_Non_Static_Expr
6202 ("non-static constraint not allowed in Unchecked_Union!", E
);
6207 -- Start of processing for Check_Static_Constraint
6210 case Nkind
(Constr
) is
6211 when N_Discriminant_Association
=>
6212 Require_Static
(Expression
(Constr
));
6215 Require_Static
(Low_Bound
(Constr
));
6216 Require_Static
(High_Bound
(Constr
));
6218 when N_Attribute_Reference
=>
6219 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6220 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6222 when N_Range_Constraint
=>
6223 Check_Static_Constraint
(Range_Expression
(Constr
));
6225 when N_Index_Or_Discriminant_Constraint
=>
6229 IDC
:= First
(Constraints
(Constr
));
6230 while Present
(IDC
) loop
6231 Check_Static_Constraint
(IDC
);
6239 end Check_Static_Constraint
;
6241 --------------------------------------
6242 -- Check_Valid_Configuration_Pragma --
6243 --------------------------------------
6245 -- A configuration pragma must appear in the context clause of a
6246 -- compilation unit, and only other pragmas may precede it. Note that
6247 -- the test also allows use in a configuration pragma file.
6249 procedure Check_Valid_Configuration_Pragma
is
6251 if not Is_Configuration_Pragma
then
6252 Error_Pragma
("incorrect placement for configuration pragma%");
6254 end Check_Valid_Configuration_Pragma
;
6256 -------------------------------------
6257 -- Check_Valid_Library_Unit_Pragma --
6258 -------------------------------------
6260 procedure Check_Valid_Library_Unit_Pragma
is
6262 Parent_Node
: Node_Id
;
6263 Unit_Name
: Entity_Id
;
6264 Unit_Kind
: Node_Kind
;
6265 Unit_Node
: Node_Id
;
6266 Sindex
: Source_File_Index
;
6269 if not Is_List_Member
(N
) then
6273 Plist
:= List_Containing
(N
);
6274 Parent_Node
:= Parent
(Plist
);
6276 if Parent_Node
= Empty
then
6279 -- Case of pragma appearing after a compilation unit. In this case
6280 -- it must have an argument with the corresponding name and must
6281 -- be part of the following pragmas of its parent.
6283 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6284 if Plist
/= Pragmas_After
(Parent_Node
) then
6287 elsif Arg_Count
= 0 then
6289 ("argument required if outside compilation unit");
6292 Check_No_Identifiers
;
6293 Check_Arg_Count
(1);
6294 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6295 Unit_Kind
:= Nkind
(Unit_Node
);
6297 Analyze
(Get_Pragma_Arg
(Arg1
));
6299 if Unit_Kind
= N_Generic_Subprogram_Declaration
6300 or else Unit_Kind
= N_Subprogram_Declaration
6302 Unit_Name
:= Defining_Entity
(Unit_Node
);
6304 elsif Unit_Kind
in N_Generic_Instantiation
then
6305 Unit_Name
:= Defining_Entity
(Unit_Node
);
6308 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6311 if Chars
(Unit_Name
) /=
6312 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6315 ("pragma% argument is not current unit name", Arg1
);
6318 if Ekind
(Unit_Name
) = E_Package
6319 and then Present
(Renamed_Entity
(Unit_Name
))
6321 Error_Pragma
("pragma% not allowed for renamed package");
6325 -- Pragma appears other than after a compilation unit
6328 -- Here we check for the generic instantiation case and also
6329 -- for the case of processing a generic formal package. We
6330 -- detect these cases by noting that the Sloc on the node
6331 -- does not belong to the current compilation unit.
6333 Sindex
:= Source_Index
(Current_Sem_Unit
);
6335 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6336 Rewrite
(N
, Make_Null_Statement
(Loc
));
6339 -- If before first declaration, the pragma applies to the
6340 -- enclosing unit, and the name if present must be this name.
6342 elsif Is_Before_First_Decl
(N
, Plist
) then
6343 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6344 Unit_Kind
:= Nkind
(Unit_Node
);
6346 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6349 elsif Unit_Kind
= N_Subprogram_Body
6350 and then not Acts_As_Spec
(Unit_Node
)
6354 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6357 elsif Nkind
(Parent_Node
) = N_Package_Specification
6358 and then Plist
= Private_Declarations
(Parent_Node
)
6362 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6363 or else Nkind
(Parent_Node
) =
6364 N_Generic_Subprogram_Declaration
)
6365 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6369 elsif Arg_Count
> 0 then
6370 Analyze
(Get_Pragma_Arg
(Arg1
));
6372 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6374 ("name in pragma% must be enclosing unit", Arg1
);
6377 -- It is legal to have no argument in this context
6383 -- Error if not before first declaration. This is because a
6384 -- library unit pragma argument must be the name of a library
6385 -- unit (RM 10.1.5(7)), but the only names permitted in this
6386 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6387 -- generic subprogram declarations or generic instantiations.
6391 ("pragma% misplaced, must be before first declaration");
6395 end Check_Valid_Library_Unit_Pragma
;
6401 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6402 Clist
: constant Node_Id
:= Component_List
(Variant
);
6406 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6407 while Present
(Comp
) loop
6408 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6409 Next_Non_Pragma
(Comp
);
6413 ---------------------------
6414 -- Ensure_Aggregate_Form --
6415 ---------------------------
6417 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6418 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6419 Expr
: constant Node_Id
:= Expression
(Arg
);
6420 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6421 Comps
: List_Id
:= No_List
;
6422 Exprs
: List_Id
:= No_List
;
6423 Nam
: Name_Id
:= No_Name
;
6424 Nam_Loc
: Source_Ptr
;
6427 -- The pragma argument is in positional form:
6429 -- pragma Depends (Nam => ...)
6433 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6434 -- argument association.
6436 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6438 Nam_Loc
:= Sloc
(Arg
);
6440 -- Remove the pragma argument name as this will be captured in the
6443 Set_Chars
(Arg
, No_Name
);
6446 -- The argument is already in aggregate form, but the presence of a
6447 -- name causes this to be interpreted as named association which in
6448 -- turn must be converted into an aggregate.
6450 -- pragma Global (In_Out => (A, B, C))
6454 -- pragma Global ((In_Out => (A, B, C)))
6456 -- aggregate aggregate
6458 if Nkind
(Expr
) = N_Aggregate
then
6459 if Nam
= No_Name
then
6463 -- Do not transform a null argument into an aggregate as N_Null has
6464 -- special meaning in formal verification pragmas.
6466 elsif Nkind
(Expr
) = N_Null
then
6470 -- Everything comes from source if the original comes from source
6472 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6474 -- Positional argument is transformed into an aggregate with an
6475 -- Expressions list.
6477 if Nam
= No_Name
then
6478 Exprs
:= New_List
(Relocate_Node
(Expr
));
6480 -- An associative argument is transformed into an aggregate with
6481 -- Component_Associations.
6485 Make_Component_Association
(Loc
,
6486 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6487 Expression
=> Relocate_Node
(Expr
)));
6490 Set_Expression
(Arg
,
6491 Make_Aggregate
(Loc
,
6492 Component_Associations
=> Comps
,
6493 Expressions
=> Exprs
));
6495 -- Restore Comes_From_Source default
6497 Set_Comes_From_Source_Default
(CFSD
);
6498 end Ensure_Aggregate_Form
;
6504 procedure Error_Pragma
(Msg
: String) is
6506 Error_Msg_Name_1
:= Pname
;
6507 Error_Msg_N
(Fix_Error
(Msg
), N
);
6511 ----------------------
6512 -- Error_Pragma_Arg --
6513 ----------------------
6515 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6517 Error_Msg_Name_1
:= Pname
;
6518 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6520 end Error_Pragma_Arg
;
6522 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6524 Error_Msg_Name_1
:= Pname
;
6525 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6526 Error_Pragma_Arg
(Msg2
, Arg
);
6527 end Error_Pragma_Arg
;
6529 ----------------------------
6530 -- Error_Pragma_Arg_Ident --
6531 ----------------------------
6533 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6535 Error_Msg_Name_1
:= Pname
;
6536 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6538 end Error_Pragma_Arg_Ident
;
6540 ----------------------
6541 -- Error_Pragma_Ref --
6542 ----------------------
6544 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6546 Error_Msg_Name_1
:= Pname
;
6547 Error_Msg_Sloc
:= Sloc
(Ref
);
6548 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6550 end Error_Pragma_Ref
;
6552 ------------------------
6553 -- Find_Lib_Unit_Name --
6554 ------------------------
6556 function Find_Lib_Unit_Name
return Entity_Id
is
6558 -- Return inner compilation unit entity, for case of nested
6559 -- categorization pragmas. This happens in generic unit.
6561 if Nkind
(Parent
(N
)) = N_Package_Specification
6562 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6564 return Defining_Entity
(Parent
(N
));
6566 return Current_Scope
;
6568 end Find_Lib_Unit_Name
;
6570 ----------------------------
6571 -- Find_Program_Unit_Name --
6572 ----------------------------
6574 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6575 Unit_Name
: Entity_Id
;
6576 Unit_Kind
: Node_Kind
;
6577 P
: constant Node_Id
:= Parent
(N
);
6580 if Nkind
(P
) = N_Compilation_Unit
then
6581 Unit_Kind
:= Nkind
(Unit
(P
));
6583 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6584 N_Package_Declaration
)
6585 or else Unit_Kind
in N_Generic_Declaration
6587 Unit_Name
:= Defining_Entity
(Unit
(P
));
6589 if Chars
(Id
) = Chars
(Unit_Name
) then
6590 Set_Entity
(Id
, Unit_Name
);
6591 Set_Etype
(Id
, Etype
(Unit_Name
));
6593 Set_Etype
(Id
, Any_Type
);
6595 ("cannot find program unit referenced by pragma%");
6599 Set_Etype
(Id
, Any_Type
);
6600 Error_Pragma
("pragma% inapplicable to this unit");
6606 end Find_Program_Unit_Name
;
6608 -----------------------------------------
6609 -- Find_Unique_Parameterless_Procedure --
6610 -----------------------------------------
6612 function Find_Unique_Parameterless_Procedure
6614 Arg
: Node_Id
) return Entity_Id
6616 Proc
: Entity_Id
:= Empty
;
6619 -- The body of this procedure needs some comments ???
6621 if not Is_Entity_Name
(Name
) then
6623 ("argument of pragma% must be entity name", Arg
);
6625 elsif not Is_Overloaded
(Name
) then
6626 Proc
:= Entity
(Name
);
6628 if Ekind
(Proc
) /= E_Procedure
6629 or else Present
(First_Formal
(Proc
))
6632 ("argument of pragma% must be parameterless procedure", Arg
);
6637 Found
: Boolean := False;
6639 Index
: Interp_Index
;
6642 Get_First_Interp
(Name
, Index
, It
);
6643 while Present
(It
.Nam
) loop
6646 if Ekind
(Proc
) = E_Procedure
6647 and then No
(First_Formal
(Proc
))
6651 Set_Entity
(Name
, Proc
);
6652 Set_Is_Overloaded
(Name
, False);
6655 ("ambiguous handler name for pragma% ", Arg
);
6659 Get_Next_Interp
(Index
, It
);
6664 ("argument of pragma% must be parameterless procedure",
6667 Proc
:= Entity
(Name
);
6673 end Find_Unique_Parameterless_Procedure
;
6679 function Fix_Error
(Msg
: String) return String is
6680 Res
: String (Msg
'Range) := Msg
;
6681 Res_Last
: Natural := Msg
'Last;
6685 -- If we have a rewriting of another pragma, go to that pragma
6687 if Is_Rewrite_Substitution
(N
)
6688 and then Nkind
(Original_Node
(N
)) = N_Pragma
6690 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6693 -- Case where pragma comes from an aspect specification
6695 if From_Aspect_Specification
(N
) then
6697 -- Change appearence of "pragma" in message to "aspect"
6700 while J
<= Res_Last
- 5 loop
6701 if Res
(J
.. J
+ 5) = "pragma" then
6702 Res
(J
.. J
+ 5) := "aspect";
6710 -- Change "argument of" at start of message to "entity for"
6713 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6715 Res
(Res
'First .. Res
'First + 9) := "entity for";
6716 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6717 Res
(Res
'First + 11 .. Res_Last
);
6718 Res_Last
:= Res_Last
- 1;
6721 -- Change "argument" at start of message to "entity"
6724 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6726 Res
(Res
'First .. Res
'First + 5) := "entity";
6727 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6728 Res
(Res
'First + 8 .. Res_Last
);
6729 Res_Last
:= Res_Last
- 2;
6732 -- Get name from corresponding aspect
6734 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6737 -- Return possibly modified message
6739 return Res
(Res
'First .. Res_Last
);
6742 -------------------------
6743 -- Gather_Associations --
6744 -------------------------
6746 procedure Gather_Associations
6748 Args
: out Args_List
)
6753 -- Initialize all parameters to Empty
6755 for J
in Args
'Range loop
6759 -- That's all we have to do if there are no argument associations
6761 if No
(Pragma_Argument_Associations
(N
)) then
6765 -- Otherwise first deal with any positional parameters present
6767 Arg
:= First
(Pragma_Argument_Associations
(N
));
6768 for Index
in Args
'Range loop
6769 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6770 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6774 -- Positional parameters all processed, if any left, then we
6775 -- have too many positional parameters.
6777 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6779 ("too many positional associations for pragma%", Arg
);
6782 -- Process named parameters if any are present
6784 while Present
(Arg
) loop
6785 if Chars
(Arg
) = No_Name
then
6787 ("positional association cannot follow named association",
6791 for Index
in Names
'Range loop
6792 if Names
(Index
) = Chars
(Arg
) then
6793 if Present
(Args
(Index
)) then
6795 ("duplicate argument association for pragma%", Arg
);
6797 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6802 if Index
= Names
'Last then
6803 Error_Msg_Name_1
:= Pname
;
6804 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6806 -- Check for possible misspelling
6808 for Index1
in Names
'Range loop
6809 if Is_Bad_Spelling_Of
6810 (Chars
(Arg
), Names
(Index1
))
6812 Error_Msg_Name_1
:= Names
(Index1
);
6813 Error_Msg_N
-- CODEFIX
6814 ("\possible misspelling of%", Arg
);
6826 end Gather_Associations
;
6832 procedure GNAT_Pragma
is
6834 -- We need to check the No_Implementation_Pragmas restriction for
6835 -- the case of a pragma from source. Note that the case of aspects
6836 -- generating corresponding pragmas marks these pragmas as not being
6837 -- from source, so this test also catches that case.
6839 if Comes_From_Source
(N
) then
6840 Check_Restriction
(No_Implementation_Pragmas
, N
);
6844 --------------------------
6845 -- Is_Before_First_Decl --
6846 --------------------------
6848 function Is_Before_First_Decl
6849 (Pragma_Node
: Node_Id
;
6850 Decls
: List_Id
) return Boolean
6852 Item
: Node_Id
:= First
(Decls
);
6855 -- Only other pragmas can come before this pragma
6858 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6861 elsif Item
= Pragma_Node
then
6867 end Is_Before_First_Decl
;
6869 -----------------------------
6870 -- Is_Configuration_Pragma --
6871 -----------------------------
6873 -- A configuration pragma must appear in the context clause of a
6874 -- compilation unit, and only other pragmas may precede it. Note that
6875 -- the test below also permits use in a configuration pragma file.
6877 function Is_Configuration_Pragma
return Boolean is
6878 Lis
: constant List_Id
:= List_Containing
(N
);
6879 Par
: constant Node_Id
:= Parent
(N
);
6883 -- If no parent, then we are in the configuration pragma file,
6884 -- so the placement is definitely appropriate.
6889 -- Otherwise we must be in the context clause of a compilation unit
6890 -- and the only thing allowed before us in the context list is more
6891 -- configuration pragmas.
6893 elsif Nkind
(Par
) = N_Compilation_Unit
6894 and then Context_Items
(Par
) = Lis
6901 elsif Nkind
(Prg
) /= N_Pragma
then
6911 end Is_Configuration_Pragma
;
6913 --------------------------
6914 -- Is_In_Context_Clause --
6915 --------------------------
6917 function Is_In_Context_Clause
return Boolean is
6919 Parent_Node
: Node_Id
;
6922 if not Is_List_Member
(N
) then
6926 Plist
:= List_Containing
(N
);
6927 Parent_Node
:= Parent
(Plist
);
6929 if Parent_Node
= Empty
6930 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6931 or else Context_Items
(Parent_Node
) /= Plist
6938 end Is_In_Context_Clause
;
6940 ---------------------------------
6941 -- Is_Static_String_Expression --
6942 ---------------------------------
6944 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6945 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6946 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6949 Analyze_And_Resolve
(Argx
);
6951 -- Special case Ada 83, where the expression will never be static,
6952 -- but we will return true if we had a string literal to start with.
6954 if Ada_Version
= Ada_83
then
6957 -- Normal case, true only if we end up with a string literal that
6958 -- is marked as being the result of evaluating a static expression.
6961 return Is_OK_Static_Expression
(Argx
)
6962 and then Nkind
(Argx
) = N_String_Literal
;
6965 end Is_Static_String_Expression
;
6967 ----------------------
6968 -- Pragma_Misplaced --
6969 ----------------------
6971 procedure Pragma_Misplaced
is
6973 Error_Pragma
("incorrect placement of pragma%");
6974 end Pragma_Misplaced
;
6976 ------------------------------------------------
6977 -- Process_Atomic_Independent_Shared_Volatile --
6978 ------------------------------------------------
6980 procedure Process_Atomic_Independent_Shared_Volatile
is
6981 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
6982 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
6984 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
6985 -- Appropriately set flags on the given entity (either an array or
6986 -- record component, or an object declaration) according to the
6989 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
6990 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6991 -- no explicit alignment was given, set alignment to unknown, since
6992 -- back end knows what the alignment requirements are for atomic and
6993 -- full access arrays. Note: this is necessary for derived types.
6995 -------------------------
6996 -- Check_VFA_Conflicts --
6997 -------------------------
6999 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7003 VFA_And_Atomic
: Boolean := False;
7004 -- Set True if atomic component present
7006 VFA_And_Aliased
: Boolean := False;
7007 -- Set True if aliased component present
7010 -- Fetch the type in case we are dealing with an object or
7013 if Is_Type
(Ent
) then
7016 pragma Assert
(Is_Object
(Ent
)
7018 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7023 -- Check Atomic and VFA used together
7025 if Prag_Id
= Pragma_Volatile_Full_Access
7026 or else Is_Volatile_Full_Access
(Ent
)
7028 if Prag_Id
= Pragma_Atomic
7029 or else Prag_Id
= Pragma_Shared
7030 or else Is_Atomic
(Ent
)
7032 VFA_And_Atomic
:= True;
7034 elsif Is_Array_Type
(Typ
) then
7035 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7037 -- Note: Has_Atomic_Components is not used below, as this flag
7038 -- represents the pragma of the same name, Atomic_Components,
7039 -- which only applies to arrays.
7041 elsif Is_Record_Type
(Typ
) then
7042 -- Attributes cannot be applied to discriminants, only
7043 -- regular record components.
7045 Comp
:= First_Component
(Typ
);
7046 while Present
(Comp
) loop
7048 or else Is_Atomic
(Typ
)
7050 VFA_And_Atomic
:= True;
7055 Next_Component
(Comp
);
7059 if VFA_And_Atomic
then
7061 ("cannot have Volatile_Full_Access and Atomic for same "
7066 -- Check for the application of VFA to an entity that has aliased
7069 if Prag_Id
= Pragma_Volatile_Full_Access
then
7070 if Is_Array_Type
(Typ
)
7071 and then Has_Aliased_Components
(Typ
)
7073 VFA_And_Aliased
:= True;
7075 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7076 -- and Has_Independent_Components, applies only to arrays.
7077 -- However, this flag does not have a corresponding pragma, so
7078 -- perhaps it should be possible to apply it to record types as
7079 -- well. Should this be done ???
7081 elsif Is_Record_Type
(Typ
) then
7082 -- It is possible to have an aliased discriminant, so they
7083 -- must be checked along with normal components.
7085 Comp
:= First_Component_Or_Discriminant
(Typ
);
7086 while Present
(Comp
) loop
7087 if Is_Aliased
(Comp
)
7088 or else Is_Aliased
(Etype
(Comp
))
7090 VFA_And_Aliased
:= True;
7091 Check_SPARK_05_Restriction
7092 ("aliased is not allowed", Comp
);
7097 Next_Component_Or_Discriminant
(Comp
);
7101 if VFA_And_Aliased
then
7103 ("cannot apply Volatile_Full_Access (aliased component "
7107 end Check_VFA_Conflicts
;
7109 ------------------------------
7110 -- Mark_Component_Or_Object --
7111 ------------------------------
7113 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7115 if Prag_Id
= Pragma_Atomic
7116 or else Prag_Id
= Pragma_Shared
7117 or else Prag_Id
= Pragma_Volatile_Full_Access
7119 if Prag_Id
= Pragma_Volatile_Full_Access
then
7120 Set_Is_Volatile_Full_Access
(Ent
);
7122 Set_Is_Atomic
(Ent
);
7125 -- If the object declaration has an explicit initialization, a
7126 -- temporary may have to be created to hold the expression, to
7127 -- ensure that access to the object remains atomic.
7129 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7130 and then Present
(Expression
(Parent
(Ent
)))
7132 Set_Has_Delayed_Freeze
(Ent
);
7136 -- Atomic/Shared/Volatile_Full_Access imply Independent
7138 if Prag_Id
/= Pragma_Volatile
then
7139 Set_Is_Independent
(Ent
);
7141 if Prag_Id
= Pragma_Independent
then
7142 Record_Independence_Check
(N
, Ent
);
7146 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7148 if Prag_Id
/= Pragma_Independent
then
7149 Set_Is_Volatile
(Ent
);
7150 Set_Treat_As_Volatile
(Ent
);
7152 end Mark_Component_Or_Object
;
7154 --------------------
7155 -- Set_Atomic_VFA --
7156 --------------------
7158 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7160 if Prag_Id
= Pragma_Volatile_Full_Access
then
7161 Set_Is_Volatile_Full_Access
(Ent
);
7163 Set_Is_Atomic
(Ent
);
7166 if not Has_Alignment_Clause
(Ent
) then
7167 Set_Alignment
(Ent
, Uint_0
);
7177 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7180 Check_Ada_83_Warning
;
7181 Check_No_Identifiers
;
7182 Check_Arg_Count
(1);
7183 Check_Arg_Is_Local_Name
(Arg1
);
7184 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7186 if Etype
(E_Arg
) = Any_Type
then
7190 E
:= Entity
(E_Arg
);
7192 -- A pragma that applies to a Ghost entity becomes Ghost for the
7193 -- purposes of legality checks and removal of ignored Ghost code.
7195 Mark_Ghost_Pragma
(N
, E
);
7197 -- Check duplicate before we chain ourselves
7199 Check_Duplicate_Pragma
(E
);
7201 -- Check appropriateness of the entity
7203 Decl
:= Declaration_Node
(E
);
7205 -- Deal with the case where the pragma/attribute is applied to a type
7208 if Rep_Item_Too_Early
(E
, N
)
7209 or else Rep_Item_Too_Late
(E
, N
)
7213 Check_First_Subtype
(Arg1
);
7216 -- Attribute belongs on the base type. If the view of the type is
7217 -- currently private, it also belongs on the underlying type.
7219 if Prag_Id
= Pragma_Atomic
7220 or else Prag_Id
= Pragma_Shared
7221 or else Prag_Id
= Pragma_Volatile_Full_Access
7224 Set_Atomic_VFA
(Base_Type
(E
));
7225 Set_Atomic_VFA
(Underlying_Type
(E
));
7228 -- Atomic/Shared/Volatile_Full_Access imply Independent
7230 if Prag_Id
/= Pragma_Volatile
then
7231 Set_Is_Independent
(E
);
7232 Set_Is_Independent
(Base_Type
(E
));
7233 Set_Is_Independent
(Underlying_Type
(E
));
7235 if Prag_Id
= Pragma_Independent
then
7236 Record_Independence_Check
(N
, Base_Type
(E
));
7240 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7242 if Prag_Id
/= Pragma_Independent
then
7243 Set_Is_Volatile
(E
);
7244 Set_Is_Volatile
(Base_Type
(E
));
7245 Set_Is_Volatile
(Underlying_Type
(E
));
7247 Set_Treat_As_Volatile
(E
);
7248 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7251 -- Apply Volatile to the composite type's individual components,
7254 if Prag_Id
= Pragma_Volatile
7255 and then Is_Record_Type
(Etype
(E
))
7260 Comp
:= First_Component
(E
);
7261 while Present
(Comp
) loop
7262 Mark_Component_Or_Object
(Comp
);
7264 Next_Component
(Comp
);
7269 -- Deal with the case where the pragma/attribute applies to a
7270 -- component or object declaration.
7272 elsif Nkind
(Decl
) = N_Object_Declaration
7273 or else (Nkind
(Decl
) = N_Component_Declaration
7274 and then Original_Record_Component
(E
) = E
)
7276 if Rep_Item_Too_Late
(E
, N
) then
7280 Mark_Component_Or_Object
(E
);
7282 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7285 -- Perform the checks needed to assure the proper use of the GNAT
7286 -- pragma Volatile_Full_Access.
7288 Check_VFA_Conflicts
(E
);
7290 -- The following check is only relevant when SPARK_Mode is on as
7291 -- this is not a standard Ada legality rule. Pragma Volatile can
7292 -- only apply to a full type declaration or an object declaration
7293 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7294 -- untagged derived types that are rewritten as subtypes of their
7295 -- respective root types.
7298 and then Prag_Id
= Pragma_Volatile
7300 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
7301 N_Object_Declaration
)
7304 ("argument of pragma % must denote a full type or object "
7305 & "declaration", Arg1
);
7307 end Process_Atomic_Independent_Shared_Volatile
;
7309 -------------------------------------------
7310 -- Process_Compile_Time_Warning_Or_Error --
7311 -------------------------------------------
7313 procedure Process_Compile_Time_Warning_Or_Error
is
7314 Validation_Needed
: Boolean := False;
7316 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7317 -- Tree visitor that checks if N is an attribute reference that can
7318 -- be statically computed by the back end. Validation_Needed is set
7319 -- to True if found.
7325 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7327 if Nkind
(N
) = N_Attribute_Reference
7328 and then Is_Entity_Name
(Prefix
(N
))
7331 Attr_Id
: constant Attribute_Id
:=
7332 Get_Attribute_Id
(Attribute_Name
(N
));
7334 if Attr_Id
= Attribute_Alignment
7335 or else Attr_Id
= Attribute_Size
7337 Validation_Needed
:= True;
7345 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7349 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7351 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7354 Check_Arg_Count
(2);
7355 Check_No_Identifiers
;
7356 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7357 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7359 if Compile_Time_Known_Value
(Arg1x
) then
7360 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7362 -- Register the expression for its validation after the back end has
7363 -- been called if it has occurrences of attributes Size or Alignment
7364 -- (because they may be statically computed by the back end and hence
7365 -- the whole expression needs to be reevaluated).
7368 Check_Expression
(Arg1x
);
7370 if Validation_Needed
then
7371 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7374 end Process_Compile_Time_Warning_Or_Error
;
7376 ------------------------
7377 -- Process_Convention --
7378 ------------------------
7380 procedure Process_Convention
7381 (C
: out Convention_Id
;
7382 Ent
: out Entity_Id
)
7386 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7387 -- Called if we have more than one Export/Import/Convention pragma.
7388 -- This is generally illegal, but we have a special case of allowing
7389 -- Import and Interface to coexist if they specify the convention in
7390 -- a consistent manner. We are allowed to do this, since Interface is
7391 -- an implementation defined pragma, and we choose to do it since we
7392 -- know Rational allows this combination. S is the entity id of the
7393 -- subprogram in question. This procedure also sets the special flag
7394 -- Import_Interface_Present in both pragmas in the case where we do
7395 -- have matching Import and Interface pragmas.
7397 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7398 -- Set convention in entity E, and also flag that the entity has a
7399 -- convention pragma. If entity is for a private or incomplete type,
7400 -- also set convention and flag on underlying type. This procedure
7401 -- also deals with the special case of C_Pass_By_Copy convention,
7402 -- and error checks for inappropriate convention specification.
7404 -------------------------------
7405 -- Diagnose_Multiple_Pragmas --
7406 -------------------------------
7408 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7409 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7413 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7414 -- Decl is a pragma node. This function returns True if this
7415 -- pragma has a first argument that is an identifier with a
7416 -- Chars field corresponding to the Convention_Id C.
7418 function Same_Name
(Decl
: Node_Id
) return Boolean;
7419 -- Decl is a pragma node. This function returns True if this
7420 -- pragma has a second argument that is an identifier with a
7421 -- Chars field that matches the Chars of the current subprogram.
7423 ---------------------
7424 -- Same_Convention --
7425 ---------------------
7427 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7428 Arg1
: constant Node_Id
:=
7429 First
(Pragma_Argument_Associations
(Decl
));
7432 if Present
(Arg1
) then
7434 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7436 if Nkind
(Arg
) = N_Identifier
7437 and then Is_Convention_Name
(Chars
(Arg
))
7438 and then Get_Convention_Id
(Chars
(Arg
)) = C
7446 end Same_Convention
;
7452 function Same_Name
(Decl
: Node_Id
) return Boolean is
7453 Arg1
: constant Node_Id
:=
7454 First
(Pragma_Argument_Associations
(Decl
));
7462 Arg2
:= Next
(Arg1
);
7469 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7471 if Nkind
(Arg
) = N_Identifier
7472 and then Chars
(Arg
) = Chars
(S
)
7481 -- Start of processing for Diagnose_Multiple_Pragmas
7486 -- Definitely give message if we have Convention/Export here
7488 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7491 -- If we have an Import or Export, scan back from pragma to
7492 -- find any previous pragma applying to the same procedure.
7493 -- The scan will be terminated by the start of the list, or
7494 -- hitting the subprogram declaration. This won't allow one
7495 -- pragma to appear in the public part and one in the private
7496 -- part, but that seems very unlikely in practice.
7500 while Present
(Decl
) and then Decl
/= Pdec
loop
7502 -- Look for pragma with same name as us
7504 if Nkind
(Decl
) = N_Pragma
7505 and then Same_Name
(Decl
)
7507 -- Give error if same as our pragma or Export/Convention
7509 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7512 Pragma_Name_Unmapped
(N
))
7516 -- Case of Import/Interface or the other way round
7518 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7519 Name_Interface
, Name_Import
)
7521 -- Here we know that we have Import and Interface. It
7522 -- doesn't matter which way round they are. See if
7523 -- they specify the same convention. If so, all OK,
7524 -- and set special flags to stop other messages
7526 if Same_Convention
(Decl
) then
7527 Set_Import_Interface_Present
(N
);
7528 Set_Import_Interface_Present
(Decl
);
7531 -- If different conventions, special message
7534 Error_Msg_Sloc
:= Sloc
(Decl
);
7536 ("convention differs from that given#", Arg1
);
7546 -- Give message if needed if we fall through those tests
7547 -- except on Relaxed_RM_Semantics where we let go: either this
7548 -- is a case accepted/ignored by other Ada compilers (e.g.
7549 -- a mix of Convention and Import), or another error will be
7550 -- generated later (e.g. using both Import and Export).
7552 if Err
and not Relaxed_RM_Semantics
then
7554 ("at most one Convention/Export/Import pragma is allowed",
7557 end Diagnose_Multiple_Pragmas
;
7559 --------------------------------
7560 -- Set_Convention_From_Pragma --
7561 --------------------------------
7563 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7565 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7566 -- for an overridden dispatching operation. Technically this is
7567 -- an amendment and should only be done in Ada 2005 mode. However,
7568 -- this is clearly a mistake, since the problem that is addressed
7569 -- by this AI is that there is a clear gap in the RM.
7571 if Is_Dispatching_Operation
(E
)
7572 and then Present
(Overridden_Operation
(E
))
7573 and then C
/= Convention
(Overridden_Operation
(E
))
7576 ("cannot change convention for overridden dispatching "
7577 & "operation", Arg1
);
7580 -- Special checks for Convention_Stdcall
7582 if C
= Convention_Stdcall
then
7584 -- A dispatching call is not allowed. A dispatching subprogram
7585 -- cannot be used to interface to the Win32 API, so in fact
7586 -- this check does not impose any effective restriction.
7588 if Is_Dispatching_Operation
(E
) then
7589 Error_Msg_Sloc
:= Sloc
(E
);
7591 -- Note: make this unconditional so that if there is more
7592 -- than one call to which the pragma applies, we get a
7593 -- message for each call. Also don't use Error_Pragma,
7594 -- so that we get multiple messages.
7597 ("dispatching subprogram# cannot use Stdcall convention!",
7600 -- Several allowed cases
7602 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7606 or else Ekind
(E
) = E_Variable
7608 -- A component as well. The entity does not have its Ekind
7609 -- set until the enclosing record declaration is fully
7612 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7614 -- An access to subprogram is also allowed
7618 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7620 -- Allow internal call to set convention of subprogram type
7622 or else Ekind
(E
) = E_Subprogram_Type
7628 ("second argument of pragma% must be subprogram (type)",
7633 -- Set the convention
7635 Set_Convention
(E
, C
);
7636 Set_Has_Convention_Pragma
(E
);
7638 -- For the case of a record base type, also set the convention of
7639 -- any anonymous access types declared in the record which do not
7640 -- currently have a specified convention.
7642 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7647 Comp
:= First_Component
(E
);
7648 while Present
(Comp
) loop
7649 if Present
(Etype
(Comp
))
7650 and then Ekind_In
(Etype
(Comp
),
7651 E_Anonymous_Access_Type
,
7652 E_Anonymous_Access_Subprogram_Type
)
7653 and then not Has_Convention_Pragma
(Comp
)
7655 Set_Convention
(Comp
, C
);
7658 Next_Component
(Comp
);
7663 -- Deal with incomplete/private type case, where underlying type
7664 -- is available, so set convention of that underlying type.
7666 if Is_Incomplete_Or_Private_Type
(E
)
7667 and then Present
(Underlying_Type
(E
))
7669 Set_Convention
(Underlying_Type
(E
), C
);
7670 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7673 -- A class-wide type should inherit the convention of the specific
7674 -- root type (although this isn't specified clearly by the RM).
7676 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7677 Set_Convention
(Class_Wide_Type
(E
), C
);
7680 -- If the entity is a record type, then check for special case of
7681 -- C_Pass_By_Copy, which is treated the same as C except that the
7682 -- special record flag is set. This convention is only permitted
7683 -- on record types (see AI95-00131).
7685 if Cname
= Name_C_Pass_By_Copy
then
7686 if Is_Record_Type
(E
) then
7687 Set_C_Pass_By_Copy
(Base_Type
(E
));
7688 elsif Is_Incomplete_Or_Private_Type
(E
)
7689 and then Is_Record_Type
(Underlying_Type
(E
))
7691 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7694 ("C_Pass_By_Copy convention allowed only for record type",
7699 -- If the entity is a derived boolean type, check for the special
7700 -- case of convention C, C++, or Fortran, where we consider any
7701 -- nonzero value to represent true.
7703 if Is_Discrete_Type
(E
)
7704 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7710 C
= Convention_Fortran
)
7712 Set_Nonzero_Is_True
(Base_Type
(E
));
7714 end Set_Convention_From_Pragma
;
7718 Comp_Unit
: Unit_Number_Type
;
7723 -- Start of processing for Process_Convention
7726 Check_At_Least_N_Arguments
(2);
7727 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7728 Check_Arg_Is_Identifier
(Arg1
);
7729 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7731 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7732 -- tested again below to set the critical flag).
7734 if Cname
= Name_C_Pass_By_Copy
then
7737 -- Otherwise we must have something in the standard convention list
7739 elsif Is_Convention_Name
(Cname
) then
7740 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7742 -- Otherwise warn on unrecognized convention
7745 if Warn_On_Export_Import
then
7747 ("??unrecognized convention name, C assumed",
7748 Get_Pragma_Arg
(Arg1
));
7754 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7755 Check_Arg_Is_Local_Name
(Arg2
);
7757 Id
:= Get_Pragma_Arg
(Arg2
);
7760 if not Is_Entity_Name
(Id
) then
7761 Error_Pragma_Arg
("entity name required", Arg2
);
7766 -- Set entity to return
7770 -- Ada_Pass_By_Copy special checking
7772 if C
= Convention_Ada_Pass_By_Copy
then
7773 if not Is_First_Subtype
(E
) then
7775 ("convention `Ada_Pass_By_Copy` only allowed for types",
7779 if Is_By_Reference_Type
(E
) then
7781 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7785 -- Ada_Pass_By_Reference special checking
7787 elsif C
= Convention_Ada_Pass_By_Reference
then
7788 if not Is_First_Subtype
(E
) then
7790 ("convention `Ada_Pass_By_Reference` only allowed for types",
7794 if Is_By_Copy_Type
(E
) then
7796 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7801 -- Go to renamed subprogram if present, since convention applies to
7802 -- the actual renamed entity, not to the renaming entity. If the
7803 -- subprogram is inherited, go to parent subprogram.
7805 if Is_Subprogram
(E
)
7806 and then Present
(Alias
(E
))
7808 if Nkind
(Parent
(Declaration_Node
(E
))) =
7809 N_Subprogram_Renaming_Declaration
7811 if Scope
(E
) /= Scope
(Alias
(E
)) then
7813 ("cannot apply pragma% to non-local entity&#", E
);
7818 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7819 N_Private_Extension_Declaration
)
7820 and then Scope
(E
) = Scope
(Alias
(E
))
7824 -- Return the parent subprogram the entity was inherited from
7830 -- Check that we are not applying this to a specless body. Relax this
7831 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7833 if Is_Subprogram
(E
)
7834 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7835 and then not Relaxed_RM_Semantics
7838 ("pragma% requires separate spec and must come before body");
7841 -- Check that we are not applying this to a named constant
7843 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7844 Error_Msg_Name_1
:= Pname
;
7846 ("cannot apply pragma% to named constant!",
7847 Get_Pragma_Arg
(Arg2
));
7849 ("\supply appropriate type for&!", Arg2
);
7852 if Ekind
(E
) = E_Enumeration_Literal
then
7853 Error_Pragma
("enumeration literal not allowed for pragma%");
7856 -- Check for rep item appearing too early or too late
7858 if Etype
(E
) = Any_Type
7859 or else Rep_Item_Too_Early
(E
, N
)
7863 elsif Present
(Underlying_Type
(E
)) then
7864 E
:= Underlying_Type
(E
);
7867 if Rep_Item_Too_Late
(E
, N
) then
7871 if Has_Convention_Pragma
(E
) then
7872 Diagnose_Multiple_Pragmas
(E
);
7874 elsif Convention
(E
) = Convention_Protected
7875 or else Ekind
(Scope
(E
)) = E_Protected_Type
7878 ("a protected operation cannot be given a different convention",
7882 -- For Intrinsic, a subprogram is required
7884 if C
= Convention_Intrinsic
7885 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7887 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7889 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7891 ("second argument of pragma% must be a subprogram", Arg2
);
7895 -- Deal with non-subprogram cases
7897 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7898 Set_Convention_From_Pragma
(E
);
7902 -- The pragma must apply to a first subtype, but it can also
7903 -- apply to a generic type in a generic formal part, in which
7904 -- case it will also appear in the corresponding instance.
7906 if Is_Generic_Type
(E
) or else In_Instance
then
7909 Check_First_Subtype
(Arg2
);
7912 Set_Convention_From_Pragma
(Base_Type
(E
));
7914 -- For access subprograms, we must set the convention on the
7915 -- internally generated directly designated type as well.
7917 if Ekind
(E
) = E_Access_Subprogram_Type
then
7918 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7922 -- For the subprogram case, set proper convention for all homonyms
7923 -- in same scope and the same declarative part, i.e. the same
7924 -- compilation unit.
7927 Comp_Unit
:= Get_Source_Unit
(E
);
7928 Set_Convention_From_Pragma
(E
);
7930 -- Treat a pragma Import as an implicit body, and pragma import
7931 -- as implicit reference (for navigation in GPS).
7933 if Prag_Id
= Pragma_Import
then
7934 Generate_Reference
(E
, Id
, 'b');
7936 -- For exported entities we restrict the generation of references
7937 -- to entities exported to foreign languages since entities
7938 -- exported to Ada do not provide further information to GPS and
7939 -- add undesired references to the output of the gnatxref tool.
7941 elsif Prag_Id
= Pragma_Export
7942 and then Convention
(E
) /= Convention_Ada
7944 Generate_Reference
(E
, Id
, 'i');
7947 -- If the pragma comes from an aspect, it only applies to the
7948 -- given entity, not its homonyms.
7950 if From_Aspect_Specification
(N
) then
7951 if C
= Convention_Intrinsic
7952 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
7954 if Is_Fixed_Point_Type
(Etype
(Ent
))
7955 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
7956 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
7959 ("no intrinsic operator available for this fixed-point "
7962 ("\use expression functions with the desired "
7963 & "conversions made explicit", N
);
7970 -- Otherwise Loop through the homonyms of the pragma argument's
7971 -- entity, an apply convention to those in the current scope.
7977 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7979 -- Ignore entry for which convention is already set
7981 if Has_Convention_Pragma
(E1
) then
7985 if Is_Subprogram
(E1
)
7986 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
7988 and then not Relaxed_RM_Semantics
7990 Set_Has_Completion
(E
); -- to prevent cascaded error
7992 ("pragma% requires separate spec and must come before "
7996 -- Do not set the pragma on inherited operations or on formal
7999 if Comes_From_Source
(E1
)
8000 and then Comp_Unit
= Get_Source_Unit
(E1
)
8001 and then not Is_Formal_Subprogram
(E1
)
8002 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8003 N_Full_Type_Declaration
8005 if Present
(Alias
(E1
))
8006 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8009 ("cannot apply pragma% to non-local entity& declared#",
8013 Set_Convention_From_Pragma
(E1
);
8015 if Prag_Id
= Pragma_Import
then
8016 Generate_Reference
(E1
, Id
, 'b');
8024 end Process_Convention
;
8026 ----------------------------------------
8027 -- Process_Disable_Enable_Atomic_Sync --
8028 ----------------------------------------
8030 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8032 Check_No_Identifiers
;
8033 Check_At_Most_N_Arguments
(1);
8035 -- Modeled internally as
8036 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8041 Pragma_Argument_Associations
=> New_List
(
8042 Make_Pragma_Argument_Association
(Loc
,
8044 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8046 if Present
(Arg1
) then
8047 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8051 end Process_Disable_Enable_Atomic_Sync
;
8053 -------------------------------------------------
8054 -- Process_Extended_Import_Export_Internal_Arg --
8055 -------------------------------------------------
8057 procedure Process_Extended_Import_Export_Internal_Arg
8058 (Arg_Internal
: Node_Id
:= Empty
)
8061 if No
(Arg_Internal
) then
8062 Error_Pragma
("Internal parameter required for pragma%");
8065 if Nkind
(Arg_Internal
) = N_Identifier
then
8068 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8069 and then (Prag_Id
= Pragma_Import_Function
8071 Prag_Id
= Pragma_Export_Function
)
8077 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8080 Check_Arg_Is_Local_Name
(Arg_Internal
);
8081 end Process_Extended_Import_Export_Internal_Arg
;
8083 --------------------------------------------------
8084 -- Process_Extended_Import_Export_Object_Pragma --
8085 --------------------------------------------------
8087 procedure Process_Extended_Import_Export_Object_Pragma
8088 (Arg_Internal
: Node_Id
;
8089 Arg_External
: Node_Id
;
8095 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8096 Def_Id
:= Entity
(Arg_Internal
);
8098 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8100 ("pragma% must designate an object", Arg_Internal
);
8103 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8105 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8108 ("previous Common/Psect_Object applies, pragma % not permitted",
8112 if Rep_Item_Too_Late
(Def_Id
, N
) then
8116 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8118 if Present
(Arg_Size
) then
8119 Check_Arg_Is_External_Name
(Arg_Size
);
8122 -- Export_Object case
8124 if Prag_Id
= Pragma_Export_Object
then
8125 if not Is_Library_Level_Entity
(Def_Id
) then
8127 ("argument for pragma% must be library level entity",
8131 if Ekind
(Current_Scope
) = E_Generic_Package
then
8132 Error_Pragma
("pragma& cannot appear in a generic unit");
8135 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8137 ("exported object must have compile time known size",
8141 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8142 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8144 Set_Exported
(Def_Id
, Arg_Internal
);
8147 -- Import_Object case
8150 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8152 ("cannot use pragma% for task/protected object",
8156 if Ekind
(Def_Id
) = E_Constant
then
8158 ("cannot import a constant", Arg_Internal
);
8161 if Warn_On_Export_Import
8162 and then Has_Discriminants
(Etype
(Def_Id
))
8165 ("imported value must be initialized??", Arg_Internal
);
8168 if Warn_On_Export_Import
8169 and then Is_Access_Type
(Etype
(Def_Id
))
8172 ("cannot import object of an access type??", Arg_Internal
);
8175 if Warn_On_Export_Import
8176 and then Is_Imported
(Def_Id
)
8178 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8180 -- Check for explicit initialization present. Note that an
8181 -- initialization generated by the code generator, e.g. for an
8182 -- access type, does not count here.
8184 elsif Present
(Expression
(Parent
(Def_Id
)))
8187 (Original_Node
(Expression
(Parent
(Def_Id
))))
8189 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8191 ("imported entities cannot be initialized (RM B.1(24))",
8192 "\no initialization allowed for & declared#", Arg1
);
8194 Set_Imported
(Def_Id
);
8195 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8198 end Process_Extended_Import_Export_Object_Pragma
;
8200 ------------------------------------------------------
8201 -- Process_Extended_Import_Export_Subprogram_Pragma --
8202 ------------------------------------------------------
8204 procedure Process_Extended_Import_Export_Subprogram_Pragma
8205 (Arg_Internal
: Node_Id
;
8206 Arg_External
: Node_Id
;
8207 Arg_Parameter_Types
: Node_Id
;
8208 Arg_Result_Type
: Node_Id
:= Empty
;
8209 Arg_Mechanism
: Node_Id
;
8210 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8216 Ambiguous
: Boolean;
8219 function Same_Base_Type
8221 Formal
: Entity_Id
) return Boolean;
8222 -- Determines if Ptype references the type of Formal. Note that only
8223 -- the base types need to match according to the spec. Ptype here is
8224 -- the argument from the pragma, which is either a type name, or an
8225 -- access attribute.
8227 --------------------
8228 -- Same_Base_Type --
8229 --------------------
8231 function Same_Base_Type
8233 Formal
: Entity_Id
) return Boolean
8235 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8239 -- Case where pragma argument is typ'Access
8241 if Nkind
(Ptype
) = N_Attribute_Reference
8242 and then Attribute_Name
(Ptype
) = Name_Access
8244 Pref
:= Prefix
(Ptype
);
8247 if not Is_Entity_Name
(Pref
)
8248 or else Entity
(Pref
) = Any_Type
8253 -- We have a match if the corresponding argument is of an
8254 -- anonymous access type, and its designated type matches the
8255 -- type of the prefix of the access attribute
8257 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8258 and then Base_Type
(Entity
(Pref
)) =
8259 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8261 -- Case where pragma argument is a type name
8266 if not Is_Entity_Name
(Ptype
)
8267 or else Entity
(Ptype
) = Any_Type
8272 -- We have a match if the corresponding argument is of the type
8273 -- given in the pragma (comparing base types)
8275 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8279 -- Start of processing for
8280 -- Process_Extended_Import_Export_Subprogram_Pragma
8283 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8287 -- Loop through homonyms (overloadings) of the entity
8289 Hom_Id
:= Entity
(Arg_Internal
);
8290 while Present
(Hom_Id
) loop
8291 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8293 -- We need a subprogram in the current scope
8295 if not Is_Subprogram
(Def_Id
)
8296 or else Scope
(Def_Id
) /= Current_Scope
8303 -- Pragma cannot apply to subprogram body
8305 if Is_Subprogram
(Def_Id
)
8306 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8310 ("pragma% requires separate spec and must come before "
8314 -- Test result type if given, note that the result type
8315 -- parameter can only be present for the function cases.
8317 if Present
(Arg_Result_Type
)
8318 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8322 elsif Etype
(Def_Id
) /= Standard_Void_Type
8323 and then Nam_In
(Pname
, Name_Export_Procedure
,
8324 Name_Import_Procedure
)
8328 -- Test parameter types if given. Note that this parameter has
8329 -- not been analyzed (and must not be, since it is semantic
8330 -- nonsense), so we get it as the parser left it.
8332 elsif Present
(Arg_Parameter_Types
) then
8333 Check_Matching_Types
: declare
8338 Formal
:= First_Formal
(Def_Id
);
8340 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8341 if Present
(Formal
) then
8345 -- A list of one type, e.g. (List) is parsed as a
8346 -- parenthesized expression.
8348 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8349 and then Paren_Count
(Arg_Parameter_Types
) = 1
8352 or else Present
(Next_Formal
(Formal
))
8357 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8360 -- A list of more than one type is parsed as a aggregate
8362 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8363 and then Paren_Count
(Arg_Parameter_Types
) = 0
8365 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8366 while Present
(Ptype
) or else Present
(Formal
) loop
8369 or else not Same_Base_Type
(Ptype
, Formal
)
8374 Next_Formal
(Formal
);
8379 -- Anything else is of the wrong form
8383 ("wrong form for Parameter_Types parameter",
8384 Arg_Parameter_Types
);
8386 end Check_Matching_Types
;
8389 -- Match is now False if the entry we found did not match
8390 -- either a supplied Parameter_Types or Result_Types argument
8396 -- Ambiguous case, the flag Ambiguous shows if we already
8397 -- detected this and output the initial messages.
8400 if not Ambiguous
then
8402 Error_Msg_Name_1
:= Pname
;
8404 ("pragma% does not uniquely identify subprogram!",
8406 Error_Msg_Sloc
:= Sloc
(Ent
);
8407 Error_Msg_N
("matching subprogram #!", N
);
8411 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8412 Error_Msg_N
("matching subprogram #!", N
);
8417 Hom_Id
:= Homonym
(Hom_Id
);
8420 -- See if we found an entry
8423 if not Ambiguous
then
8424 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8426 ("pragma% cannot be given for generic subprogram");
8429 ("pragma% does not identify local subprogram");
8436 -- Import pragmas must be for imported entities
8438 if Prag_Id
= Pragma_Import_Function
8440 Prag_Id
= Pragma_Import_Procedure
8442 Prag_Id
= Pragma_Import_Valued_Procedure
8444 if not Is_Imported
(Ent
) then
8446 ("pragma Import or Interface must precede pragma%");
8449 -- Here we have the Export case which can set the entity as exported
8451 -- But does not do so if the specified external name is null, since
8452 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8453 -- compatible) to request no external name.
8455 elsif Nkind
(Arg_External
) = N_String_Literal
8456 and then String_Length
(Strval
(Arg_External
)) = 0
8460 -- In all other cases, set entity as exported
8463 Set_Exported
(Ent
, Arg_Internal
);
8466 -- Special processing for Valued_Procedure cases
8468 if Prag_Id
= Pragma_Import_Valued_Procedure
8470 Prag_Id
= Pragma_Export_Valued_Procedure
8472 Formal
:= First_Formal
(Ent
);
8475 Error_Pragma
("at least one parameter required for pragma%");
8477 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8478 Error_Pragma
("first parameter must have mode out for pragma%");
8481 Set_Is_Valued_Procedure
(Ent
);
8485 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8487 -- Process Result_Mechanism argument if present. We have already
8488 -- checked that this is only allowed for the function case.
8490 if Present
(Arg_Result_Mechanism
) then
8491 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8494 -- Process Mechanism parameter if present. Note that this parameter
8495 -- is not analyzed, and must not be analyzed since it is semantic
8496 -- nonsense, so we get it in exactly as the parser left it.
8498 if Present
(Arg_Mechanism
) then
8506 -- A single mechanism association without a formal parameter
8507 -- name is parsed as a parenthesized expression. All other
8508 -- cases are parsed as aggregates, so we rewrite the single
8509 -- parameter case as an aggregate for consistency.
8511 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8512 and then Paren_Count
(Arg_Mechanism
) = 1
8514 Rewrite
(Arg_Mechanism
,
8515 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8516 Expressions
=> New_List
(
8517 Relocate_Node
(Arg_Mechanism
))));
8520 -- Case of only mechanism name given, applies to all formals
8522 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8523 Formal
:= First_Formal
(Ent
);
8524 while Present
(Formal
) loop
8525 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8526 Next_Formal
(Formal
);
8529 -- Case of list of mechanism associations given
8532 if Null_Record_Present
(Arg_Mechanism
) then
8534 ("inappropriate form for Mechanism parameter",
8538 -- Deal with positional ones first
8540 Formal
:= First_Formal
(Ent
);
8542 if Present
(Expressions
(Arg_Mechanism
)) then
8543 Mname
:= First
(Expressions
(Arg_Mechanism
));
8544 while Present
(Mname
) loop
8547 ("too many mechanism associations", Mname
);
8550 Set_Mechanism_Value
(Formal
, Mname
);
8551 Next_Formal
(Formal
);
8556 -- Deal with named entries
8558 if Present
(Component_Associations
(Arg_Mechanism
)) then
8559 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8560 while Present
(Massoc
) loop
8561 Choice
:= First
(Choices
(Massoc
));
8563 if Nkind
(Choice
) /= N_Identifier
8564 or else Present
(Next
(Choice
))
8567 ("incorrect form for mechanism association",
8571 Formal
:= First_Formal
(Ent
);
8575 ("parameter name & not present", Choice
);
8578 if Chars
(Choice
) = Chars
(Formal
) then
8580 (Formal
, Expression
(Massoc
));
8582 -- Set entity on identifier (needed by ASIS)
8584 Set_Entity
(Choice
, Formal
);
8589 Next_Formal
(Formal
);
8598 end Process_Extended_Import_Export_Subprogram_Pragma
;
8600 --------------------------
8601 -- Process_Generic_List --
8602 --------------------------
8604 procedure Process_Generic_List
is
8609 Check_No_Identifiers
;
8610 Check_At_Least_N_Arguments
(1);
8612 -- Check all arguments are names of generic units or instances
8615 while Present
(Arg
) loop
8616 Exp
:= Get_Pragma_Arg
(Arg
);
8619 if not Is_Entity_Name
(Exp
)
8621 (not Is_Generic_Instance
(Entity
(Exp
))
8623 not Is_Generic_Unit
(Entity
(Exp
)))
8626 ("pragma% argument must be name of generic unit/instance",
8632 end Process_Generic_List
;
8634 ------------------------------------
8635 -- Process_Import_Predefined_Type --
8636 ------------------------------------
8638 procedure Process_Import_Predefined_Type
is
8639 Loc
: constant Source_Ptr
:= Sloc
(N
);
8641 Ftyp
: Node_Id
:= Empty
;
8647 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8649 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8650 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8654 Ftyp
:= Node
(Elmt
);
8656 if Present
(Ftyp
) then
8658 -- Don't build a derived type declaration, because predefined C
8659 -- types have no declaration anywhere, so cannot really be named.
8660 -- Instead build a full type declaration, starting with an
8661 -- appropriate type definition is built
8663 if Is_Floating_Point_Type
(Ftyp
) then
8664 Def
:= Make_Floating_Point_Definition
(Loc
,
8665 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8666 Make_Real_Range_Specification
(Loc
,
8667 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8668 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8670 -- Should never have a predefined type we cannot handle
8673 raise Program_Error
;
8676 -- Build and insert a Full_Type_Declaration, which will be
8677 -- analyzed as soon as this list entry has been analyzed.
8679 Decl
:= Make_Full_Type_Declaration
(Loc
,
8680 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8681 Type_Definition
=> Def
);
8683 Insert_After
(N
, Decl
);
8684 Mark_Rewrite_Insertion
(Decl
);
8687 Error_Pragma_Arg
("no matching type found for pragma%",
8690 end Process_Import_Predefined_Type
;
8692 ---------------------------------
8693 -- Process_Import_Or_Interface --
8694 ---------------------------------
8696 procedure Process_Import_Or_Interface
is
8702 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8703 -- pragma Import (Entity, "external name");
8705 if Relaxed_RM_Semantics
8706 and then Arg_Count
= 2
8707 and then Prag_Id
= Pragma_Import
8708 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8711 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8714 if not Is_Entity_Name
(Def_Id
) then
8715 Error_Pragma_Arg
("entity name required", Arg1
);
8718 Def_Id
:= Entity
(Def_Id
);
8719 Kill_Size_Check_Code
(Def_Id
);
8720 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8723 Process_Convention
(C
, Def_Id
);
8725 -- A pragma that applies to a Ghost entity becomes Ghost for the
8726 -- purposes of legality checks and removal of ignored Ghost code.
8728 Mark_Ghost_Pragma
(N
, Def_Id
);
8729 Kill_Size_Check_Code
(Def_Id
);
8730 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8733 -- Various error checks
8735 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8737 -- We do not permit Import to apply to a renaming declaration
8739 if Present
(Renamed_Object
(Def_Id
)) then
8741 ("pragma% not allowed for object renaming", Arg2
);
8743 -- User initialization is not allowed for imported object, but
8744 -- the object declaration may contain a default initialization,
8745 -- that will be discarded. Note that an explicit initialization
8746 -- only counts if it comes from source, otherwise it is simply
8747 -- the code generator making an implicit initialization explicit.
8749 elsif Present
(Expression
(Parent
(Def_Id
)))
8750 and then Comes_From_Source
8751 (Original_Node
(Expression
(Parent
(Def_Id
))))
8753 -- Set imported flag to prevent cascaded errors
8755 Set_Is_Imported
(Def_Id
);
8757 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8759 ("no initialization allowed for declaration of& #",
8760 "\imported entities cannot be initialized (RM B.1(24))",
8764 -- If the pragma comes from an aspect specification the
8765 -- Is_Imported flag has already been set.
8767 if not From_Aspect_Specification
(N
) then
8768 Set_Imported
(Def_Id
);
8771 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8773 -- Note that we do not set Is_Public here. That's because we
8774 -- only want to set it if there is no address clause, and we
8775 -- don't know that yet, so we delay that processing till
8778 -- pragma Import completes deferred constants
8780 if Ekind
(Def_Id
) = E_Constant
then
8781 Set_Has_Completion
(Def_Id
);
8784 -- It is not possible to import a constant of an unconstrained
8785 -- array type (e.g. string) because there is no simple way to
8786 -- write a meaningful subtype for it.
8788 if Is_Array_Type
(Etype
(Def_Id
))
8789 and then not Is_Constrained
(Etype
(Def_Id
))
8792 ("imported constant& must have a constrained subtype",
8797 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8799 -- If the name is overloaded, pragma applies to all of the denoted
8800 -- entities in the same declarative part, unless the pragma comes
8801 -- from an aspect specification or was generated by the compiler
8802 -- (such as for pragma Provide_Shift_Operators).
8805 while Present
(Hom_Id
) loop
8807 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8809 -- Ignore inherited subprograms because the pragma will apply
8810 -- to the parent operation, which is the one called.
8812 if Is_Overloadable
(Def_Id
)
8813 and then Present
(Alias
(Def_Id
))
8817 -- If it is not a subprogram, it must be in an outer scope and
8818 -- pragma does not apply.
8820 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8823 -- The pragma does not apply to primitives of interfaces
8825 elsif Is_Dispatching_Operation
(Def_Id
)
8826 and then Present
(Find_Dispatching_Type
(Def_Id
))
8827 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8831 -- Verify that the homonym is in the same declarative part (not
8832 -- just the same scope). If the pragma comes from an aspect
8833 -- specification we know that it is part of the declaration.
8835 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8836 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8837 and then not From_Aspect_Specification
(N
)
8842 -- If the pragma comes from an aspect specification the
8843 -- Is_Imported flag has already been set.
8845 if not From_Aspect_Specification
(N
) then
8846 Set_Imported
(Def_Id
);
8849 -- Reject an Import applied to an abstract subprogram
8851 if Is_Subprogram
(Def_Id
)
8852 and then Is_Abstract_Subprogram
(Def_Id
)
8854 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8856 ("cannot import abstract subprogram& declared#",
8860 -- Special processing for Convention_Intrinsic
8862 if C
= Convention_Intrinsic
then
8864 -- Link_Name argument not allowed for intrinsic
8868 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8870 -- If no external name is present, then check that this
8871 -- is a valid intrinsic subprogram. If an external name
8872 -- is present, then this is handled by the back end.
8875 Check_Intrinsic_Subprogram
8876 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8880 -- Verify that the subprogram does not have a completion
8881 -- through a renaming declaration. For other completions the
8882 -- pragma appears as a too late representation.
8885 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8889 and then Nkind
(Decl
) = N_Subprogram_Declaration
8890 and then Present
(Corresponding_Body
(Decl
))
8891 and then Nkind
(Unit_Declaration_Node
8892 (Corresponding_Body
(Decl
))) =
8893 N_Subprogram_Renaming_Declaration
8895 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8897 ("cannot import&, renaming already provided for "
8898 & "declaration #", N
, Def_Id
);
8902 -- If the pragma comes from an aspect specification, there
8903 -- must be an Import aspect specified as well. In the rare
8904 -- case where Import is set to False, the suprogram needs to
8905 -- have a local completion.
8908 Imp_Aspect
: constant Node_Id
:=
8909 Find_Aspect
(Def_Id
, Aspect_Import
);
8913 if Present
(Imp_Aspect
)
8914 and then Present
(Expression
(Imp_Aspect
))
8916 Expr
:= Expression
(Imp_Aspect
);
8917 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8919 if Is_Entity_Name
(Expr
)
8920 and then Entity
(Expr
) = Standard_True
8922 Set_Has_Completion
(Def_Id
);
8925 -- If there is no expression, the default is True, as for
8926 -- all boolean aspects. Same for the older pragma.
8929 Set_Has_Completion
(Def_Id
);
8933 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8936 if Is_Compilation_Unit
(Hom_Id
) then
8938 -- Its possible homonyms are not affected by the pragma.
8939 -- Such homonyms might be present in the context of other
8940 -- units being compiled.
8944 elsif From_Aspect_Specification
(N
) then
8947 -- If the pragma was created by the compiler, then we don't
8948 -- want it to apply to other homonyms. This kind of case can
8949 -- occur when using pragma Provide_Shift_Operators, which
8950 -- generates implicit shift and rotate operators with Import
8951 -- pragmas that might apply to earlier explicit or implicit
8952 -- declarations marked with Import (for example, coming from
8953 -- an earlier pragma Provide_Shift_Operators for another type),
8954 -- and we don't generally want other homonyms being treated
8955 -- as imported or the pragma flagged as an illegal duplicate.
8957 elsif not Comes_From_Source
(N
) then
8961 Hom_Id
:= Homonym
(Hom_Id
);
8965 -- Import a CPP class
8967 elsif C
= Convention_CPP
8968 and then (Is_Record_Type
(Def_Id
)
8969 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8971 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8972 if Present
(Full_View
(Def_Id
)) then
8973 Def_Id
:= Full_View
(Def_Id
);
8977 ("cannot import 'C'P'P type before full declaration seen",
8978 Get_Pragma_Arg
(Arg2
));
8980 -- Although we have reported the error we decorate it as
8981 -- CPP_Class to avoid reporting spurious errors
8983 Set_Is_CPP_Class
(Def_Id
);
8988 -- Types treated as CPP classes must be declared limited (note:
8989 -- this used to be a warning but there is no real benefit to it
8990 -- since we did effectively intend to treat the type as limited
8993 if not Is_Limited_Type
(Def_Id
) then
8995 ("imported 'C'P'P type must be limited",
8996 Get_Pragma_Arg
(Arg2
));
8999 if Etype
(Def_Id
) /= Def_Id
9000 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9002 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9005 Set_Is_CPP_Class
(Def_Id
);
9007 -- Imported CPP types must not have discriminants (because C++
9008 -- classes do not have discriminants).
9010 if Has_Discriminants
(Def_Id
) then
9012 ("imported 'C'P'P type cannot have discriminants",
9013 First
(Discriminant_Specifications
9014 (Declaration_Node
(Def_Id
))));
9017 -- Check that components of imported CPP types do not have default
9018 -- expressions. For private types this check is performed when the
9019 -- full view is analyzed (see Process_Full_View).
9021 if not Is_Private_Type
(Def_Id
) then
9022 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9025 -- Import a CPP exception
9027 elsif C
= Convention_CPP
9028 and then Ekind
(Def_Id
) = E_Exception
9032 ("'External_'Name arguments is required for 'Cpp exception",
9035 -- As only a string is allowed, Check_Arg_Is_External_Name
9038 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9041 if Present
(Arg4
) then
9043 ("Link_Name argument not allowed for imported Cpp exception",
9047 -- Do not call Set_Interface_Name as the name of the exception
9048 -- shouldn't be modified (and in particular it shouldn't be
9049 -- the External_Name). For exceptions, the External_Name is the
9050 -- name of the RTTI structure.
9052 -- ??? Emit an error if pragma Import/Export_Exception is present
9054 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9056 Check_Arg_Count
(3);
9057 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9059 Process_Import_Predefined_Type
;
9063 ("second argument of pragma% must be object, subprogram "
9064 & "or incomplete type",
9068 -- If this pragma applies to a compilation unit, then the unit, which
9069 -- is a subprogram, does not require (or allow) a body. We also do
9070 -- not need to elaborate imported procedures.
9072 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9074 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9076 Set_Body_Required
(Cunit
, False);
9079 end Process_Import_Or_Interface
;
9081 --------------------
9082 -- Process_Inline --
9083 --------------------
9085 procedure Process_Inline
(Status
: Inline_Status
) is
9092 Ghost_Error_Posted
: Boolean := False;
9093 -- Flag set when an error concerning the illegal mix of Ghost and
9094 -- non-Ghost subprograms is emitted.
9096 Ghost_Id
: Entity_Id
:= Empty
;
9097 -- The entity of the first Ghost subprogram encountered while
9098 -- processing the arguments of the pragma.
9100 procedure Make_Inline
(Subp
: Entity_Id
);
9101 -- Subp is the defining unit name of the subprogram declaration. If
9102 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9103 -- the corresponding body, if there is one present.
9105 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9106 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9107 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9109 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
9110 -- Returns True if it can be determined at this stage that inlining
9111 -- is not possible, for example if the body is available and contains
9112 -- exception handlers, we prevent inlining, since otherwise we can
9113 -- get undefined symbols at link time. This function also emits a
9114 -- warning if the pragma appears too late.
9116 -- ??? is business with link symbols still valid, or does it relate
9117 -- to front end ZCX which is being phased out ???
9119 ---------------------------
9120 -- Inlining_Not_Possible --
9121 ---------------------------
9123 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9124 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9128 if Nkind
(Decl
) = N_Subprogram_Body
then
9129 Stats
:= Handled_Statement_Sequence
(Decl
);
9130 return Present
(Exception_Handlers
(Stats
))
9131 or else Present
(At_End_Proc
(Stats
));
9133 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9134 and then Present
(Corresponding_Body
(Decl
))
9136 if Analyzed
(Corresponding_Body
(Decl
)) then
9137 Error_Msg_N
("pragma appears too late, ignored??", N
);
9140 -- If the subprogram is a renaming as body, the body is just a
9141 -- call to the renamed subprogram, and inlining is trivially
9145 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9146 N_Subprogram_Renaming_Declaration
9152 Handled_Statement_Sequence
9153 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9156 Present
(Exception_Handlers
(Stats
))
9157 or else Present
(At_End_Proc
(Stats
));
9161 -- If body is not available, assume the best, the check is
9162 -- performed again when compiling enclosing package bodies.
9166 end Inlining_Not_Possible
;
9172 procedure Make_Inline
(Subp
: Entity_Id
) is
9173 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9174 Inner_Subp
: Entity_Id
:= Subp
;
9177 -- Ignore if bad type, avoid cascaded error
9179 if Etype
(Subp
) = Any_Type
then
9183 -- If inlining is not possible, for now do not treat as an error
9185 elsif Status
/= Suppressed
9186 and then Front_End_Inlining
9187 and then Inlining_Not_Possible
(Subp
)
9192 -- Here we have a candidate for inlining, but we must exclude
9193 -- derived operations. Otherwise we would end up trying to inline
9194 -- a phantom declaration, and the result would be to drag in a
9195 -- body which has no direct inlining associated with it. That
9196 -- would not only be inefficient but would also result in the
9197 -- backend doing cross-unit inlining in cases where it was
9198 -- definitely inappropriate to do so.
9200 -- However, a simple Comes_From_Source test is insufficient, since
9201 -- we do want to allow inlining of generic instances which also do
9202 -- not come from source. We also need to recognize specs generated
9203 -- by the front-end for bodies that carry the pragma. Finally,
9204 -- predefined operators do not come from source but are not
9205 -- inlineable either.
9207 elsif Is_Generic_Instance
(Subp
)
9208 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9212 elsif not Comes_From_Source
(Subp
)
9213 and then Scope
(Subp
) /= Standard_Standard
9219 -- The referenced entity must either be the enclosing entity, or
9220 -- an entity declared within the current open scope.
9222 if Present
(Scope
(Subp
))
9223 and then Scope
(Subp
) /= Current_Scope
9224 and then Subp
/= Current_Scope
9227 ("argument of% must be entity in current scope", Assoc
);
9231 -- Processing for procedure, operator or function. If subprogram
9232 -- is aliased (as for an instance) indicate that the renamed
9233 -- entity (if declared in the same unit) is inlined.
9234 -- If this is the anonymous subprogram created for a subprogram
9235 -- instance, the inlining applies to it directly. Otherwise we
9236 -- retrieve it as the alias of the visible subprogram instance.
9238 if Is_Subprogram
(Subp
) then
9239 if Is_Wrapper_Package
(Scope
(Subp
)) then
9242 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9245 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9246 Set_Inline_Flags
(Inner_Subp
);
9248 Decl
:= Parent
(Parent
(Inner_Subp
));
9250 if Nkind
(Decl
) = N_Subprogram_Declaration
9251 and then Present
(Corresponding_Body
(Decl
))
9253 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9255 elsif Is_Generic_Instance
(Subp
)
9256 and then Comes_From_Source
(Subp
)
9258 -- Indicate that the body needs to be created for
9259 -- inlining subsequent calls. The instantiation node
9260 -- follows the declaration of the wrapper package
9261 -- created for it. The subprogram that requires the
9262 -- body is the anonymous one in the wrapper package.
9264 if Scope
(Subp
) /= Standard_Standard
9266 Need_Subprogram_Instance_Body
9267 (Next
(Unit_Declaration_Node
9268 (Scope
(Alias
(Subp
)))), Subp
)
9273 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9274 -- appear in a formal part to apply to a formal subprogram.
9275 -- Do not apply check within an instance or a formal package
9276 -- the test will have been applied to the original generic.
9278 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9279 and then List_Containing
(Decl
) = List_Containing
(N
)
9280 and then not In_Instance
9283 ("Inline cannot apply to a formal subprogram", N
);
9285 -- If Subp is a renaming, it is the renamed entity that
9286 -- will appear in any call, and be inlined. However, for
9287 -- ASIS uses it is convenient to indicate that the renaming
9288 -- itself is an inlined subprogram, so that some gnatcheck
9289 -- rules can be applied in the absence of expansion.
9291 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9292 Set_Inline_Flags
(Subp
);
9298 -- For a generic subprogram set flag as well, for use at the point
9299 -- of instantiation, to determine whether the body should be
9302 elsif Is_Generic_Subprogram
(Subp
) then
9303 Set_Inline_Flags
(Subp
);
9306 -- Literals are by definition inlined
9308 elsif Kind
= E_Enumeration_Literal
then
9311 -- Anything else is an error
9315 ("expect subprogram name for pragma%", Assoc
);
9319 ----------------------
9320 -- Set_Inline_Flags --
9321 ----------------------
9323 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9325 -- First set the Has_Pragma_XXX flags and issue the appropriate
9326 -- errors and warnings for suspicious combinations.
9328 if Prag_Id
= Pragma_No_Inline
then
9329 if Has_Pragma_Inline_Always
(Subp
) then
9331 ("Inline_Always and No_Inline are mutually exclusive", N
);
9332 elsif Has_Pragma_Inline
(Subp
) then
9334 ("Inline and No_Inline both specified for& ??",
9335 N
, Entity
(Subp_Id
));
9338 Set_Has_Pragma_No_Inline
(Subp
);
9340 if Prag_Id
= Pragma_Inline_Always
then
9341 if Has_Pragma_No_Inline
(Subp
) then
9343 ("Inline_Always and No_Inline are mutually exclusive",
9347 Set_Has_Pragma_Inline_Always
(Subp
);
9349 if Has_Pragma_No_Inline
(Subp
) then
9351 ("Inline and No_Inline both specified for& ??",
9352 N
, Entity
(Subp_Id
));
9356 Set_Has_Pragma_Inline
(Subp
);
9359 -- Then adjust the Is_Inlined flag. It can never be set if the
9360 -- subprogram is subject to pragma No_Inline.
9364 Set_Is_Inlined
(Subp
, False);
9370 if not Has_Pragma_No_Inline
(Subp
) then
9371 Set_Is_Inlined
(Subp
, True);
9375 -- A pragma that applies to a Ghost entity becomes Ghost for the
9376 -- purposes of legality checks and removal of ignored Ghost code.
9378 Mark_Ghost_Pragma
(N
, Subp
);
9380 -- Capture the entity of the first Ghost subprogram being
9381 -- processed for error detection purposes.
9383 if Is_Ghost_Entity
(Subp
) then
9384 if No
(Ghost_Id
) then
9388 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9389 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9391 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9392 Ghost_Error_Posted
:= True;
9394 Error_Msg_Name_1
:= Pname
;
9396 ("pragma % cannot mention ghost and non-ghost subprograms",
9399 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9400 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9402 Error_Msg_Sloc
:= Sloc
(Subp
);
9403 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9405 end Set_Inline_Flags
;
9407 -- Start of processing for Process_Inline
9410 Check_No_Identifiers
;
9411 Check_At_Least_N_Arguments
(1);
9413 if Status
= Enabled
then
9414 Inline_Processing_Required
:= True;
9418 while Present
(Assoc
) loop
9419 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9423 if Is_Entity_Name
(Subp_Id
) then
9424 Subp
:= Entity
(Subp_Id
);
9426 if Subp
= Any_Id
then
9428 -- If previous error, avoid cascaded errors
9430 Check_Error_Detected
;
9436 -- For the pragma case, climb homonym chain. This is
9437 -- what implements allowing the pragma in the renaming
9438 -- case, with the result applying to the ancestors, and
9439 -- also allows Inline to apply to all previous homonyms.
9441 if not From_Aspect_Specification
(N
) then
9442 while Present
(Homonym
(Subp
))
9443 and then Scope
(Homonym
(Subp
)) = Current_Scope
9445 Make_Inline
(Homonym
(Subp
));
9446 Subp
:= Homonym
(Subp
);
9453 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9459 -- If the context is a package declaration, the pragma indicates
9460 -- that inlining will require the presence of the corresponding
9461 -- body. (this may be further refined).
9464 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9465 N_Package_Declaration
9467 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9471 ----------------------------
9472 -- Process_Interface_Name --
9473 ----------------------------
9475 procedure Process_Interface_Name
9476 (Subprogram_Def
: Entity_Id
;
9483 String_Val
: String_Id
;
9485 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9486 -- SN is a string literal node for an interface name. This routine
9487 -- performs some minimal checks that the name is reasonable. In
9488 -- particular that no spaces or other obviously incorrect characters
9489 -- appear. This is only a warning, since any characters are allowed.
9491 ----------------------------------
9492 -- Check_Form_Of_Interface_Name --
9493 ----------------------------------
9495 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9496 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9497 SL
: constant Nat
:= String_Length
(S
);
9502 Error_Msg_N
("interface name cannot be null string", SN
);
9505 for J
in 1 .. SL
loop
9506 C
:= Get_String_Char
(S
, J
);
9508 -- Look for dubious character and issue unconditional warning.
9509 -- Definitely dubious if not in character range.
9511 if not In_Character_Range
(C
)
9513 -- Commas, spaces and (back)slashes are dubious
9515 or else Get_Character
(C
) = ','
9516 or else Get_Character
(C
) = '\'
9517 or else Get_Character
(C
) = ' '
9518 or else Get_Character
(C
) = '/'
9521 ("??interface name contains illegal character",
9522 Sloc
(SN
) + Source_Ptr
(J
));
9525 end Check_Form_Of_Interface_Name
;
9527 -- Start of processing for Process_Interface_Name
9530 -- If we are looking at a pragma that comes from an aspect then it
9531 -- needs to have its corresponding aspect argument expressions
9532 -- analyzed in addition to the generated pragma so that aspects
9533 -- within generic units get properly resolved.
9535 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9537 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9545 -- Obtain all interfacing aspects used to construct the pragma
9547 Get_Interfacing_Aspects
9548 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9550 -- Analyze the expression of aspect External_Name
9552 if Present
(EN
) then
9553 Analyze
(Expression
(EN
));
9556 -- Analyze the expressio of aspect Link_Name
9558 if Present
(LN
) then
9559 Analyze
(Expression
(LN
));
9564 if No
(Link_Arg
) then
9565 if No
(Ext_Arg
) then
9568 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9570 Link_Nam
:= Expression
(Ext_Arg
);
9573 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9574 Ext_Nam
:= Expression
(Ext_Arg
);
9579 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9580 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9581 Ext_Nam
:= Expression
(Ext_Arg
);
9582 Link_Nam
:= Expression
(Link_Arg
);
9585 -- Check expressions for external name and link name are static
9587 if Present
(Ext_Nam
) then
9588 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9589 Check_Form_Of_Interface_Name
(Ext_Nam
);
9591 -- Verify that external name is not the name of a local entity,
9592 -- which would hide the imported one and could lead to run-time
9593 -- surprises. The problem can only arise for entities declared in
9594 -- a package body (otherwise the external name is fully qualified
9595 -- and will not conflict).
9603 if Prag_Id
= Pragma_Import
then
9604 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
9605 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9607 if Nam
/= Chars
(Subprogram_Def
)
9608 and then Present
(E
)
9609 and then not Is_Overloadable
(E
)
9610 and then Is_Immediately_Visible
(E
)
9611 and then not Is_Imported
(E
)
9612 and then Ekind
(Scope
(E
)) = E_Package
9615 while Present
(Par
) loop
9616 if Nkind
(Par
) = N_Package_Body
then
9617 Error_Msg_Sloc
:= Sloc
(E
);
9619 ("imported entity is hidden by & declared#",
9624 Par
:= Parent
(Par
);
9631 if Present
(Link_Nam
) then
9632 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9633 Check_Form_Of_Interface_Name
(Link_Nam
);
9636 -- If there is no link name, just set the external name
9638 if No
(Link_Nam
) then
9639 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9641 -- For the Link_Name case, the given literal is preceded by an
9642 -- asterisk, which indicates to GCC that the given name should be
9643 -- taken literally, and in particular that no prepending of
9644 -- underlines should occur, even in systems where this is the
9649 Store_String_Char
(Get_Char_Code
('*'));
9650 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9651 Store_String_Chars
(String_Val
);
9653 Make_String_Literal
(Sloc
(Link_Nam
),
9654 Strval
=> End_String
);
9657 -- Set the interface name. If the entity is a generic instance, use
9658 -- its alias, which is the callable entity.
9660 if Is_Generic_Instance
(Subprogram_Def
) then
9661 Set_Encoded_Interface_Name
9662 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9664 Set_Encoded_Interface_Name
9665 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9668 Check_Duplicated_Export_Name
(Link_Nam
);
9669 end Process_Interface_Name
;
9671 -----------------------------------------
9672 -- Process_Interrupt_Or_Attach_Handler --
9673 -----------------------------------------
9675 procedure Process_Interrupt_Or_Attach_Handler
is
9676 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9677 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9680 -- A pragma that applies to a Ghost entity becomes Ghost for the
9681 -- purposes of legality checks and removal of ignored Ghost code.
9683 Mark_Ghost_Pragma
(N
, Handler
);
9684 Set_Is_Interrupt_Handler
(Handler
);
9686 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
9688 Record_Rep_Item
(Prot_Typ
, N
);
9690 -- Chain the pragma on the contract for completeness
9692 Add_Contract_Item
(N
, Handler
);
9693 end Process_Interrupt_Or_Attach_Handler
;
9695 --------------------------------------------------
9696 -- Process_Restrictions_Or_Restriction_Warnings --
9697 --------------------------------------------------
9699 -- Note: some of the simple identifier cases were handled in par-prag,
9700 -- but it is harmless (and more straightforward) to simply handle all
9701 -- cases here, even if it means we repeat a bit of work in some cases.
9703 procedure Process_Restrictions_Or_Restriction_Warnings
9707 R_Id
: Restriction_Id
;
9713 -- Ignore all Restrictions pragmas in CodePeer mode
9715 if CodePeer_Mode
then
9719 Check_Ada_83_Warning
;
9720 Check_At_Least_N_Arguments
(1);
9721 Check_Valid_Configuration_Pragma
;
9724 while Present
(Arg
) loop
9726 Expr
:= Get_Pragma_Arg
(Arg
);
9728 -- Case of no restriction identifier present
9730 if Id
= No_Name
then
9731 if Nkind
(Expr
) /= N_Identifier
then
9733 ("invalid form for restriction", Arg
);
9738 (Process_Restriction_Synonyms
(Expr
));
9740 if R_Id
not in All_Boolean_Restrictions
then
9741 Error_Msg_Name_1
:= Pname
;
9743 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9745 -- Check for possible misspelling
9747 for J
in Restriction_Id
loop
9749 Rnm
: constant String := Restriction_Id
'Image (J
);
9752 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9753 Name_Len
:= Rnm
'Length;
9754 Set_Casing
(All_Lower_Case
);
9756 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9759 (Source_Index
(Current_Sem_Unit
)));
9760 Error_Msg_String
(1 .. Rnm
'Length) :=
9761 Name_Buffer
(1 .. Name_Len
);
9762 Error_Msg_Strlen
:= Rnm
'Length;
9763 Error_Msg_N
-- CODEFIX
9764 ("\possible misspelling of ""~""",
9765 Get_Pragma_Arg
(Arg
));
9774 if Implementation_Restriction
(R_Id
) then
9775 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
9778 -- Special processing for No_Elaboration_Code restriction
9780 if R_Id
= No_Elaboration_Code
then
9782 -- Restriction is only recognized within a configuration
9783 -- pragma file, or within a unit of the main extended
9784 -- program. Note: the test for Main_Unit is needed to
9785 -- properly include the case of configuration pragma files.
9787 if not (Current_Sem_Unit
= Main_Unit
9788 or else In_Extended_Main_Source_Unit
(N
))
9792 -- Don't allow in a subunit unless already specified in
9795 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
9796 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
9797 and then not Restriction_Active
(No_Elaboration_Code
)
9800 ("invalid specification of ""No_Elaboration_Code""",
9803 ("\restriction cannot be specified in a subunit", N
);
9805 ("\unless also specified in body or spec", N
);
9808 -- If we accept a No_Elaboration_Code restriction, then it
9809 -- needs to be added to the configuration restriction set so
9810 -- that we get proper application to other units in the main
9811 -- extended source as required.
9814 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9818 -- If this is a warning, then set the warning unless we already
9819 -- have a real restriction active (we never want a warning to
9820 -- override a real restriction).
9823 if not Restriction_Active
(R_Id
) then
9824 Set_Restriction
(R_Id
, N
);
9825 Restriction_Warnings
(R_Id
) := True;
9828 -- If real restriction case, then set it and make sure that the
9829 -- restriction warning flag is off, since a real restriction
9830 -- always overrides a warning.
9833 Set_Restriction
(R_Id
, N
);
9834 Restriction_Warnings
(R_Id
) := False;
9837 -- Check for obsolescent restrictions in Ada 2005 mode
9840 and then Ada_Version
>= Ada_2005
9841 and then (R_Id
= No_Asynchronous_Control
9843 R_Id
= No_Unchecked_Deallocation
9845 R_Id
= No_Unchecked_Conversion
)
9847 Check_Restriction
(No_Obsolescent_Features
, N
);
9850 -- A very special case that must be processed here: pragma
9851 -- Restrictions (No_Exceptions) turns off all run-time
9852 -- checking. This is a bit dubious in terms of the formal
9853 -- language definition, but it is what is intended by RM
9854 -- H.4(12). Restriction_Warnings never affects generated code
9855 -- so this is done only in the real restriction case.
9857 -- Atomic_Synchronization is not a real check, so it is not
9858 -- affected by this processing).
9860 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9861 -- run-time checks in CodePeer and GNATprove modes: we want to
9862 -- generate checks for analysis purposes, as set respectively
9863 -- by -gnatC and -gnatd.F
9866 and then not (CodePeer_Mode
or GNATprove_Mode
)
9867 and then R_Id
= No_Exceptions
9869 for J
in Scope_Suppress
.Suppress
'Range loop
9870 if J
/= Atomic_Synchronization
then
9871 Scope_Suppress
.Suppress
(J
) := True;
9876 -- Case of No_Dependence => unit-name. Note that the parser
9877 -- already made the necessary entry in the No_Dependence table.
9879 elsif Id
= Name_No_Dependence
then
9880 if not OK_No_Dependence_Unit_Name
(Expr
) then
9884 -- Case of No_Specification_Of_Aspect => aspect-identifier
9886 elsif Id
= Name_No_Specification_Of_Aspect
then
9891 if Nkind
(Expr
) /= N_Identifier
then
9894 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9897 if A_Id
= No_Aspect
then
9898 Error_Pragma_Arg
("invalid restriction name", Arg
);
9900 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9904 -- Case of No_Use_Of_Attribute => attribute-identifier
9906 elsif Id
= Name_No_Use_Of_Attribute
then
9907 if Nkind
(Expr
) /= N_Identifier
9908 or else not Is_Attribute_Name
(Chars
(Expr
))
9910 Error_Msg_N
("unknown attribute name??", Expr
);
9913 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9916 -- Case of No_Use_Of_Entity => fully-qualified-name
9918 elsif Id
= Name_No_Use_Of_Entity
then
9920 -- Restriction is only recognized within a configuration
9921 -- pragma file, or within a unit of the main extended
9922 -- program. Note: the test for Main_Unit is needed to
9923 -- properly include the case of configuration pragma files.
9925 if Current_Sem_Unit
= Main_Unit
9926 or else In_Extended_Main_Source_Unit
(N
)
9928 if not OK_No_Dependence_Unit_Name
(Expr
) then
9929 Error_Msg_N
("wrong form for entity name", Expr
);
9931 Set_Restriction_No_Use_Of_Entity
9932 (Expr
, Warn
, No_Profile
);
9936 -- Case of No_Use_Of_Pragma => pragma-identifier
9938 elsif Id
= Name_No_Use_Of_Pragma
then
9939 if Nkind
(Expr
) /= N_Identifier
9940 or else not Is_Pragma_Name
(Chars
(Expr
))
9942 Error_Msg_N
("unknown pragma name??", Expr
);
9944 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9947 -- All other cases of restriction identifier present
9950 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9951 Analyze_And_Resolve
(Expr
, Any_Integer
);
9953 if R_Id
not in All_Parameter_Restrictions
then
9955 ("invalid restriction parameter identifier", Arg
);
9957 elsif not Is_OK_Static_Expression
(Expr
) then
9958 Flag_Non_Static_Expr
9959 ("value must be static expression!", Expr
);
9962 elsif not Is_Integer_Type
(Etype
(Expr
))
9963 or else Expr_Value
(Expr
) < 0
9966 ("value must be non-negative integer", Arg
);
9969 -- Restriction pragma is active
9971 Val
:= Expr_Value
(Expr
);
9973 if not UI_Is_In_Int_Range
(Val
) then
9975 ("pragma ignored, value too large??", Arg
);
9978 -- Warning case. If the real restriction is active, then we
9979 -- ignore the request, since warning never overrides a real
9980 -- restriction. Otherwise we set the proper warning. Note that
9981 -- this circuit sets the warning again if it is already set,
9982 -- which is what we want, since the constant may have changed.
9985 if not Restriction_Active
(R_Id
) then
9987 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9988 Restriction_Warnings
(R_Id
) := True;
9991 -- Real restriction case, set restriction and make sure warning
9992 -- flag is off since real restriction always overrides warning.
9995 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9996 Restriction_Warnings
(R_Id
) := False;
10002 end Process_Restrictions_Or_Restriction_Warnings
;
10004 ---------------------------------
10005 -- Process_Suppress_Unsuppress --
10006 ---------------------------------
10008 -- Note: this procedure makes entries in the check suppress data
10009 -- structures managed by Sem. See spec of package Sem for full
10010 -- details on how we handle recording of check suppression.
10012 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10017 In_Package_Spec
: constant Boolean :=
10018 Is_Package_Or_Generic_Package
(Current_Scope
)
10019 and then not In_Package_Body
(Current_Scope
);
10021 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10022 -- Used to suppress a single check on the given entity
10024 --------------------------------
10025 -- Suppress_Unsuppress_Echeck --
10026 --------------------------------
10028 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10030 -- Check for error of trying to set atomic synchronization for
10031 -- a non-atomic variable.
10033 if C
= Atomic_Synchronization
10034 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10037 ("pragma & requires atomic type or variable",
10038 Pragma_Identifier
(Original_Node
(N
)));
10041 Set_Checks_May_Be_Suppressed
(E
);
10043 if In_Package_Spec
then
10044 Push_Global_Suppress_Stack_Entry
10047 Suppress
=> Suppress_Case
);
10049 Push_Local_Suppress_Stack_Entry
10052 Suppress
=> Suppress_Case
);
10055 -- If this is a first subtype, and the base type is distinct,
10056 -- then also set the suppress flags on the base type.
10058 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10059 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10061 end Suppress_Unsuppress_Echeck
;
10063 -- Start of processing for Process_Suppress_Unsuppress
10066 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10067 -- on user code: we want to generate checks for analysis purposes, as
10068 -- set respectively by -gnatC and -gnatd.F
10070 if Comes_From_Source
(N
)
10071 and then (CodePeer_Mode
or GNATprove_Mode
)
10076 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10077 -- declarative part or a package spec (RM 11.5(5)).
10079 if not Is_Configuration_Pragma
then
10080 Check_Is_In_Decl_Part_Or_Package_Spec
;
10083 Check_At_Least_N_Arguments
(1);
10084 Check_At_Most_N_Arguments
(2);
10085 Check_No_Identifier
(Arg1
);
10086 Check_Arg_Is_Identifier
(Arg1
);
10088 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10090 if C
= No_Check_Id
then
10092 ("argument of pragma% is not valid check name", Arg1
);
10095 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10097 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10099 ("Suppress of Elaboration_Check ignored in SPARK??",
10100 "\elaboration checking rules are statically enforced "
10101 & "(SPARK RM 7.7)", Arg1
);
10104 -- One-argument case
10106 if Arg_Count
= 1 then
10108 -- Make an entry in the local scope suppress table. This is the
10109 -- table that directly shows the current value of the scope
10110 -- suppress check for any check id value.
10112 if C
= All_Checks
then
10114 -- For All_Checks, we set all specific predefined checks with
10115 -- the exception of Elaboration_Check, which is handled
10116 -- specially because of not wanting All_Checks to have the
10117 -- effect of deactivating static elaboration order processing.
10118 -- Atomic_Synchronization is also not affected, since this is
10119 -- not a real check.
10121 for J
in Scope_Suppress
.Suppress
'Range loop
10122 if J
/= Elaboration_Check
10124 J
/= Atomic_Synchronization
10126 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10130 -- If not All_Checks, and predefined check, then set appropriate
10131 -- scope entry. Note that we will set Elaboration_Check if this
10132 -- is explicitly specified. Atomic_Synchronization is allowed
10133 -- only if internally generated and entity is atomic.
10135 elsif C
in Predefined_Check_Id
10136 and then (not Comes_From_Source
(N
)
10137 or else C
/= Atomic_Synchronization
)
10139 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10142 -- Also make an entry in the Local_Entity_Suppress table
10144 Push_Local_Suppress_Stack_Entry
10147 Suppress
=> Suppress_Case
);
10149 -- Case of two arguments present, where the check is suppressed for
10150 -- a specified entity (given as the second argument of the pragma)
10153 -- This is obsolescent in Ada 2005 mode
10155 if Ada_Version
>= Ada_2005
then
10156 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10159 Check_Optional_Identifier
(Arg2
, Name_On
);
10160 E_Id
:= Get_Pragma_Arg
(Arg2
);
10163 if not Is_Entity_Name
(E_Id
) then
10165 ("second argument of pragma% must be entity name", Arg2
);
10168 E
:= Entity
(E_Id
);
10174 -- A pragma that applies to a Ghost entity becomes Ghost for the
10175 -- purposes of legality checks and removal of ignored Ghost code.
10177 Mark_Ghost_Pragma
(N
, E
);
10179 -- Enforce RM 11.5(7) which requires that for a pragma that
10180 -- appears within a package spec, the named entity must be
10181 -- within the package spec. We allow the package name itself
10182 -- to be mentioned since that makes sense, although it is not
10183 -- strictly allowed by 11.5(7).
10186 and then E
/= Current_Scope
10187 and then Scope
(E
) /= Current_Scope
10190 ("entity in pragma% is not in package spec (RM 11.5(7))",
10194 -- Loop through homonyms. As noted below, in the case of a package
10195 -- spec, only homonyms within the package spec are considered.
10198 Suppress_Unsuppress_Echeck
(E
, C
);
10200 if Is_Generic_Instance
(E
)
10201 and then Is_Subprogram
(E
)
10202 and then Present
(Alias
(E
))
10204 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10207 -- Move to next homonym if not aspect spec case
10209 exit when From_Aspect_Specification
(N
);
10213 -- If we are within a package specification, the pragma only
10214 -- applies to homonyms in the same scope.
10216 exit when In_Package_Spec
10217 and then Scope
(E
) /= Current_Scope
;
10220 end Process_Suppress_Unsuppress
;
10222 -------------------------------
10223 -- Record_Independence_Check --
10224 -------------------------------
10226 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10227 pragma Unreferenced
(N
, E
);
10229 -- For GCC back ends the validation is done a priori
10230 -- ??? This code is dead, might be useful in the future
10232 -- if not AAMP_On_Target then
10236 -- Independence_Checks.Append ((N, E));
10239 end Record_Independence_Check
;
10245 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10247 if Is_Imported
(E
) then
10249 ("cannot export entity& that was previously imported", Arg
);
10251 elsif Present
(Address_Clause
(E
))
10252 and then not Relaxed_RM_Semantics
10255 ("cannot export entity& that has an address clause", Arg
);
10258 Set_Is_Exported
(E
);
10260 -- Generate a reference for entity explicitly, because the
10261 -- identifier may be overloaded and name resolution will not
10264 Generate_Reference
(E
, Arg
);
10266 -- Deal with exporting non-library level entity
10268 if not Is_Library_Level_Entity
(E
) then
10270 -- Not allowed at all for subprograms
10272 if Is_Subprogram
(E
) then
10273 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10275 -- Otherwise set public and statically allocated
10279 Set_Is_Statically_Allocated
(E
);
10281 -- Warn if the corresponding W flag is set
10283 if Warn_On_Export_Import
10285 -- Only do this for something that was in the source. Not
10286 -- clear if this can be False now (there used for sure to be
10287 -- cases on some systems where it was False), but anyway the
10288 -- test is harmless if not needed, so it is retained.
10290 and then Comes_From_Source
(Arg
)
10293 ("?x?& has been made static as a result of Export",
10296 ("\?x?this usage is non-standard and non-portable",
10302 if Warn_On_Export_Import
and then Is_Type
(E
) then
10303 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10306 if Warn_On_Export_Import
and Inside_A_Generic
then
10308 ("all instances of& will have the same external name?x?",
10313 ----------------------------------------------
10314 -- Set_Extended_Import_Export_External_Name --
10315 ----------------------------------------------
10317 procedure Set_Extended_Import_Export_External_Name
10318 (Internal_Ent
: Entity_Id
;
10319 Arg_External
: Node_Id
)
10321 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10322 New_Name
: Node_Id
;
10325 if No
(Arg_External
) then
10329 Check_Arg_Is_External_Name
(Arg_External
);
10331 if Nkind
(Arg_External
) = N_String_Literal
then
10332 if String_Length
(Strval
(Arg_External
)) = 0 then
10335 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10338 elsif Nkind
(Arg_External
) = N_Identifier
then
10339 New_Name
:= Get_Default_External_Name
(Arg_External
);
10341 -- Check_Arg_Is_External_Name should let through only identifiers and
10342 -- string literals or static string expressions (which are folded to
10343 -- string literals).
10346 raise Program_Error
;
10349 -- If we already have an external name set (by a prior normal Import
10350 -- or Export pragma), then the external names must match
10352 if Present
(Interface_Name
(Internal_Ent
)) then
10354 -- Ignore mismatching names in CodePeer mode, to support some
10355 -- old compilers which would export the same procedure under
10356 -- different names, e.g:
10358 -- pragma Export_Procedure (P, "a");
10359 -- pragma Export_Procedure (P, "b");
10361 if CodePeer_Mode
then
10365 Check_Matching_Internal_Names
: declare
10366 S1
: constant String_Id
:= Strval
(Old_Name
);
10367 S2
: constant String_Id
:= Strval
(New_Name
);
10369 procedure Mismatch
;
10370 pragma No_Return
(Mismatch
);
10371 -- Called if names do not match
10377 procedure Mismatch
is
10379 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10381 ("external name does not match that given #",
10385 -- Start of processing for Check_Matching_Internal_Names
10388 if String_Length
(S1
) /= String_Length
(S2
) then
10392 for J
in 1 .. String_Length
(S1
) loop
10393 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10398 end Check_Matching_Internal_Names
;
10400 -- Otherwise set the given name
10403 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10404 Check_Duplicated_Export_Name
(New_Name
);
10406 end Set_Extended_Import_Export_External_Name
;
10412 procedure Set_Imported
(E
: Entity_Id
) is
10414 -- Error message if already imported or exported
10416 if Is_Exported
(E
) or else Is_Imported
(E
) then
10418 -- Error if being set Exported twice
10420 if Is_Exported
(E
) then
10421 Error_Msg_NE
("entity& was previously exported", N
, E
);
10423 -- Ignore error in CodePeer mode where we treat all imported
10424 -- subprograms as unknown.
10426 elsif CodePeer_Mode
then
10429 -- OK if Import/Interface case
10431 elsif Import_Interface_Present
(N
) then
10434 -- Error if being set Imported twice
10437 Error_Msg_NE
("entity& was previously imported", N
, E
);
10440 Error_Msg_Name_1
:= Pname
;
10442 ("\(pragma% applies to all previous entities)", N
);
10444 Error_Msg_Sloc
:= Sloc
(E
);
10445 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10447 -- Here if not previously imported or exported, OK to import
10450 Set_Is_Imported
(E
);
10452 -- For subprogram, set Import_Pragma field
10454 if Is_Subprogram
(E
) then
10455 Set_Import_Pragma
(E
, N
);
10458 -- If the entity is an object that is not at the library level,
10459 -- then it is statically allocated. We do not worry about objects
10460 -- with address clauses in this context since they are not really
10461 -- imported in the linker sense.
10464 and then not Is_Library_Level_Entity
(E
)
10465 and then No
(Address_Clause
(E
))
10467 Set_Is_Statically_Allocated
(E
);
10474 -------------------------
10475 -- Set_Mechanism_Value --
10476 -------------------------
10478 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10479 -- analyzed, since it is semantic nonsense), so we get it in the exact
10480 -- form created by the parser.
10482 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10483 procedure Bad_Mechanism
;
10484 pragma No_Return
(Bad_Mechanism
);
10485 -- Signal bad mechanism name
10487 -------------------------
10488 -- Bad_Mechanism_Value --
10489 -------------------------
10491 procedure Bad_Mechanism
is
10493 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10496 -- Start of processing for Set_Mechanism_Value
10499 if Mechanism
(Ent
) /= Default_Mechanism
then
10501 ("mechanism for & has already been set", Mech_Name
, Ent
);
10504 -- MECHANISM_NAME ::= value | reference
10506 if Nkind
(Mech_Name
) = N_Identifier
then
10507 if Chars
(Mech_Name
) = Name_Value
then
10508 Set_Mechanism
(Ent
, By_Copy
);
10511 elsif Chars
(Mech_Name
) = Name_Reference
then
10512 Set_Mechanism
(Ent
, By_Reference
);
10515 elsif Chars
(Mech_Name
) = Name_Copy
then
10517 ("bad mechanism name, Value assumed", Mech_Name
);
10526 end Set_Mechanism_Value
;
10528 --------------------------
10529 -- Set_Rational_Profile --
10530 --------------------------
10532 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10533 -- extension to the semantics of renaming declarations.
10535 procedure Set_Rational_Profile
is
10537 Implicit_Packing
:= True;
10538 Overriding_Renamings
:= True;
10539 Use_VADS_Size
:= True;
10540 end Set_Rational_Profile
;
10542 ---------------------------
10543 -- Set_Ravenscar_Profile --
10544 ---------------------------
10546 -- The tasks to be done here are
10548 -- Set required policies
10550 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10551 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10552 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10553 -- (For GNAT_Ravenscar_EDF profile)
10554 -- pragma Locking_Policy (Ceiling_Locking)
10556 -- Set Detect_Blocking mode
10558 -- Set required restrictions (see System.Rident for detailed list)
10560 -- Set the No_Dependence rules
10561 -- No_Dependence => Ada.Asynchronous_Task_Control
10562 -- No_Dependence => Ada.Calendar
10563 -- No_Dependence => Ada.Execution_Time.Group_Budget
10564 -- No_Dependence => Ada.Execution_Time.Timers
10565 -- No_Dependence => Ada.Task_Attributes
10566 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10568 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10569 procedure Set_Error_Msg_To_Profile_Name
;
10570 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10573 -----------------------------------
10574 -- Set_Error_Msg_To_Profile_Name --
10575 -----------------------------------
10577 procedure Set_Error_Msg_To_Profile_Name
is
10578 Prof_Nam
: constant Node_Id
:=
10580 (First
(Pragma_Argument_Associations
(N
)));
10583 Get_Name_String
(Chars
(Prof_Nam
));
10584 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10585 Error_Msg_Strlen
:= Name_Len
;
10586 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10587 end Set_Error_Msg_To_Profile_Name
;
10596 Profile_Dispatching_Policy
: Character;
10598 -- Start of processing for Set_Ravenscar_Profile
10601 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10603 if Profile
= GNAT_Ravenscar_EDF
then
10604 Profile_Dispatching_Policy
:= 'E';
10606 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10609 Profile_Dispatching_Policy
:= 'F';
10612 if Task_Dispatching_Policy
/= ' '
10613 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
10615 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10616 Set_Error_Msg_To_Profile_Name
;
10617 Error_Pragma
("Profile (~) incompatible with policy#");
10619 -- Set the FIFO_Within_Priorities policy, but always preserve
10620 -- System_Location since we like the error message with the run time
10624 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
10626 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10627 Task_Dispatching_Policy_Sloc
:= Loc
;
10631 -- pragma Locking_Policy (Ceiling_Locking)
10633 if Locking_Policy
/= ' '
10634 and then Locking_Policy
/= 'C'
10636 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10637 Set_Error_Msg_To_Profile_Name
;
10638 Error_Pragma
("Profile (~) incompatible with policy#");
10640 -- Set the Ceiling_Locking policy, but preserve System_Location since
10641 -- we like the error message with the run time name.
10644 Locking_Policy
:= 'C';
10646 if Locking_Policy_Sloc
/= System_Location
then
10647 Locking_Policy_Sloc
:= Loc
;
10651 -- pragma Detect_Blocking
10653 Detect_Blocking
:= True;
10655 -- Set the corresponding restrictions
10657 Set_Profile_Restrictions
10658 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10660 -- Set the No_Dependence restrictions
10662 -- The following No_Dependence restrictions:
10663 -- No_Dependence => Ada.Asynchronous_Task_Control
10664 -- No_Dependence => Ada.Calendar
10665 -- No_Dependence => Ada.Task_Attributes
10666 -- are already set by previous call to Set_Profile_Restrictions.
10668 -- Set the following restrictions which were added to Ada 2005:
10669 -- No_Dependence => Ada.Execution_Time.Group_Budget
10670 -- No_Dependence => Ada.Execution_Time.Timers
10672 if Ada_Version
>= Ada_2005
then
10673 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
10674 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
10677 Make_Selected_Component
10680 Selector_Name
=> Sel_Id
);
10682 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
10685 Make_Selected_Component
10688 Selector_Name
=> Sel_Id
);
10690 Set_Restriction_No_Dependence
10692 Warn
=> Treat_Restrictions_As_Warnings
,
10693 Profile
=> Ravenscar
);
10695 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
10698 Make_Selected_Component
10701 Selector_Name
=> Sel_Id
);
10703 Set_Restriction_No_Dependence
10705 Warn
=> Treat_Restrictions_As_Warnings
,
10706 Profile
=> Ravenscar
);
10709 -- Set the following restriction which was added to Ada 2012 (see
10711 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10713 if Ada_Version
>= Ada_2012
then
10714 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
10715 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
10718 Make_Selected_Component
10721 Selector_Name
=> Sel_Id
);
10723 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
10726 Make_Selected_Component
10729 Selector_Name
=> Sel_Id
);
10731 Set_Restriction_No_Dependence
10733 Warn
=> Treat_Restrictions_As_Warnings
,
10734 Profile
=> Ravenscar
);
10736 end Set_Ravenscar_Profile
;
10738 -- Start of processing for Analyze_Pragma
10741 -- The following code is a defense against recursion. Not clear that
10742 -- this can happen legitimately, but perhaps some error situations can
10743 -- cause it, and we did see this recursion during testing.
10745 if Analyzed
(N
) then
10751 Check_Restriction_No_Use_Of_Pragma
(N
);
10753 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10754 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10756 if Should_Ignore_Pragma_Sem
(N
)
10757 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
10758 and then Ignore_Rep_Clauses
)
10763 -- Deal with unrecognized pragma
10765 if not Is_Pragma_Name
(Pname
) then
10766 if Warn_On_Unrecognized_Pragma
then
10767 Error_Msg_Name_1
:= Pname
;
10768 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10770 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10771 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10772 Error_Msg_Name_1
:= PN
;
10773 Error_Msg_N
-- CODEFIX
10774 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
10783 -- Here to start processing for recognized pragma
10785 Pname
:= Original_Aspect_Pragma_Name
(N
);
10787 -- Capture setting of Opt.Uneval_Old
10789 case Opt
.Uneval_Old
is
10791 Set_Uneval_Old_Accept
(N
);
10797 Set_Uneval_Old_Warn
(N
);
10800 raise Program_Error
;
10803 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10804 -- is already set, indicating that we have already checked the policy
10805 -- at the right point. This happens for example in the case of a pragma
10806 -- that is derived from an Aspect.
10808 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10811 -- For a pragma that is a rewriting of another pragma, copy the
10812 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10814 elsif Is_Rewrite_Substitution
(N
)
10815 and then Nkind
(Original_Node
(N
)) = N_Pragma
10816 and then Original_Node
(N
) /= N
10818 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10819 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10821 -- Otherwise query the applicable policy at this point
10824 Check_Applicable_Policy
(N
);
10826 -- If pragma is disabled, rewrite as NULL and skip analysis
10828 if Is_Disabled
(N
) then
10829 Rewrite
(N
, Make_Null_Statement
(Loc
));
10835 -- Preset arguments
10843 if Present
(Pragma_Argument_Associations
(N
)) then
10844 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10845 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10847 if Present
(Arg1
) then
10848 Arg2
:= Next
(Arg1
);
10850 if Present
(Arg2
) then
10851 Arg3
:= Next
(Arg2
);
10853 if Present
(Arg3
) then
10854 Arg4
:= Next
(Arg3
);
10860 -- An enumeration type defines the pragmas that are supported by the
10861 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10862 -- into the corresponding enumeration value for the following case.
10870 -- pragma Abort_Defer;
10872 when Pragma_Abort_Defer
=>
10874 Check_Arg_Count
(0);
10876 -- The only required semantic processing is to check the
10877 -- placement. This pragma must appear at the start of the
10878 -- statement sequence of a handled sequence of statements.
10880 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10881 or else N
/= First
(Statements
(Parent
(N
)))
10886 --------------------
10887 -- Abstract_State --
10888 --------------------
10890 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10892 -- ABSTRACT_STATE_LIST ::=
10894 -- | STATE_NAME_WITH_OPTIONS
10895 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10897 -- STATE_NAME_WITH_OPTIONS ::=
10899 -- | (STATE_NAME with OPTION_LIST)
10901 -- OPTION_LIST ::= OPTION {, OPTION}
10905 -- | NAME_VALUE_OPTION
10907 -- SIMPLE_OPTION ::= Ghost | Synchronous
10909 -- NAME_VALUE_OPTION ::=
10910 -- Part_Of => ABSTRACT_STATE
10911 -- | External [=> EXTERNAL_PROPERTY_LIST]
10913 -- EXTERNAL_PROPERTY_LIST ::=
10914 -- EXTERNAL_PROPERTY
10915 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10917 -- EXTERNAL_PROPERTY ::=
10918 -- Async_Readers [=> boolean_EXPRESSION]
10919 -- | Async_Writers [=> boolean_EXPRESSION]
10920 -- | Effective_Reads [=> boolean_EXPRESSION]
10921 -- | Effective_Writes [=> boolean_EXPRESSION]
10922 -- others => boolean_EXPRESSION
10924 -- STATE_NAME ::= defining_identifier
10926 -- ABSTRACT_STATE ::= name
10928 -- Characteristics:
10930 -- * Analysis - The annotation is fully analyzed immediately upon
10931 -- elaboration as it cannot forward reference entities.
10933 -- * Expansion - None.
10935 -- * Template - The annotation utilizes the generic template of the
10936 -- related package declaration.
10938 -- * Globals - The annotation cannot reference global entities.
10940 -- * Instance - The annotation is instantiated automatically when
10941 -- the related generic package is instantiated.
10943 when Pragma_Abstract_State
=> Abstract_State
: declare
10944 Missing_Parentheses
: Boolean := False;
10945 -- Flag set when a state declaration with options is not properly
10948 -- Flags used to verify the consistency of states
10950 Non_Null_Seen
: Boolean := False;
10951 Null_Seen
: Boolean := False;
10953 procedure Analyze_Abstract_State
10955 Pack_Id
: Entity_Id
);
10956 -- Verify the legality of a single state declaration. Create and
10957 -- decorate a state abstraction entity and introduce it into the
10958 -- visibility chain. Pack_Id denotes the entity or the related
10959 -- package where pragma Abstract_State appears.
10961 procedure Malformed_State_Error
(State
: Node_Id
);
10962 -- Emit an error concerning the illegal declaration of abstract
10963 -- state State. This routine diagnoses syntax errors that lead to
10964 -- a different parse tree. The error is issued regardless of the
10965 -- SPARK mode in effect.
10967 ----------------------------
10968 -- Analyze_Abstract_State --
10969 ----------------------------
10971 procedure Analyze_Abstract_State
10973 Pack_Id
: Entity_Id
)
10975 -- Flags used to verify the consistency of options
10977 AR_Seen
: Boolean := False;
10978 AW_Seen
: Boolean := False;
10979 ER_Seen
: Boolean := False;
10980 EW_Seen
: Boolean := False;
10981 External_Seen
: Boolean := False;
10982 Ghost_Seen
: Boolean := False;
10983 Others_Seen
: Boolean := False;
10984 Part_Of_Seen
: Boolean := False;
10985 Synchronous_Seen
: Boolean := False;
10987 -- Flags used to store the static value of all external states'
10990 AR_Val
: Boolean := False;
10991 AW_Val
: Boolean := False;
10992 ER_Val
: Boolean := False;
10993 EW_Val
: Boolean := False;
10995 State_Id
: Entity_Id
:= Empty
;
10996 -- The entity to be generated for the current state declaration
10998 procedure Analyze_External_Option
(Opt
: Node_Id
);
10999 -- Verify the legality of option External
11001 procedure Analyze_External_Property
11003 Expr
: Node_Id
:= Empty
);
11004 -- Verify the legailty of a single external property. Prop
11005 -- denotes the external property. Expr is the expression used
11006 -- to set the property.
11008 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11009 -- Verify the legality of option Part_Of
11011 procedure Check_Duplicate_Option
11013 Status
: in out Boolean);
11014 -- Flag Status denotes whether a particular option has been
11015 -- seen while processing a state. This routine verifies that
11016 -- Opt is not a duplicate option and sets the flag Status
11017 -- (SPARK RM 7.1.4(1)).
11019 procedure Check_Duplicate_Property
11021 Status
: in out Boolean);
11022 -- Flag Status denotes whether a particular property has been
11023 -- seen while processing option External. This routine verifies
11024 -- that Prop is not a duplicate property and sets flag Status.
11025 -- Opt is not a duplicate property and sets the flag Status.
11026 -- (SPARK RM 7.1.4(2))
11028 procedure Check_Ghost_Synchronous
;
11029 -- Ensure that the abstract state is not subject to both Ghost
11030 -- and Synchronous simple options. Emit an error if this is the
11033 procedure Create_Abstract_State
11037 Is_Null
: Boolean);
11038 -- Generate an abstract state entity with name Nam and enter it
11039 -- into visibility. Decl is the "declaration" of the state as
11040 -- it appears in pragma Abstract_State. Loc is the location of
11041 -- the related state "declaration". Flag Is_Null should be set
11042 -- when the associated Abstract_State pragma defines a null
11045 -----------------------------
11046 -- Analyze_External_Option --
11047 -----------------------------
11049 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11050 Errors
: constant Nat
:= Serious_Errors_Detected
;
11052 Props
: Node_Id
:= Empty
;
11055 if Nkind
(Opt
) = N_Component_Association
then
11056 Props
:= Expression
(Opt
);
11059 -- External state with properties
11061 if Present
(Props
) then
11063 -- Multiple properties appear as an aggregate
11065 if Nkind
(Props
) = N_Aggregate
then
11067 -- Simple property form
11069 Prop
:= First
(Expressions
(Props
));
11070 while Present
(Prop
) loop
11071 Analyze_External_Property
(Prop
);
11075 -- Property with expression form
11077 Prop
:= First
(Component_Associations
(Props
));
11078 while Present
(Prop
) loop
11079 Analyze_External_Property
11080 (Prop
=> First
(Choices
(Prop
)),
11081 Expr
=> Expression
(Prop
));
11089 Analyze_External_Property
(Props
);
11092 -- An external state defined without any properties defaults
11093 -- all properties to True.
11102 -- Once all external properties have been processed, verify
11103 -- their mutual interaction. Do not perform the check when
11104 -- at least one of the properties is illegal as this will
11105 -- produce a bogus error.
11107 if Errors
= Serious_Errors_Detected
then
11108 Check_External_Properties
11109 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11111 end Analyze_External_Option
;
11113 -------------------------------
11114 -- Analyze_External_Property --
11115 -------------------------------
11117 procedure Analyze_External_Property
11119 Expr
: Node_Id
:= Empty
)
11121 Expr_Val
: Boolean;
11124 -- Check the placement of "others" (if available)
11126 if Nkind
(Prop
) = N_Others_Choice
then
11127 if Others_Seen
then
11129 ("only one others choice allowed in option External",
11132 Others_Seen
:= True;
11135 elsif Others_Seen
then
11137 ("others must be the last property in option External",
11140 -- The only remaining legal options are the four predefined
11141 -- external properties.
11143 elsif Nkind
(Prop
) = N_Identifier
11144 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11145 Name_Async_Writers
,
11146 Name_Effective_Reads
,
11147 Name_Effective_Writes
)
11151 -- Otherwise the construct is not a valid property
11154 SPARK_Msg_N
("invalid external state property", Prop
);
11158 -- Ensure that the expression of the external state property
11159 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11161 if Present
(Expr
) then
11162 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11164 if Is_OK_Static_Expression
(Expr
) then
11165 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11168 ("expression of external state property must be "
11172 -- The lack of expression defaults the property to True
11178 -- Named properties
11180 if Nkind
(Prop
) = N_Identifier
then
11181 if Chars
(Prop
) = Name_Async_Readers
then
11182 Check_Duplicate_Property
(Prop
, AR_Seen
);
11183 AR_Val
:= Expr_Val
;
11185 elsif Chars
(Prop
) = Name_Async_Writers
then
11186 Check_Duplicate_Property
(Prop
, AW_Seen
);
11187 AW_Val
:= Expr_Val
;
11189 elsif Chars
(Prop
) = Name_Effective_Reads
then
11190 Check_Duplicate_Property
(Prop
, ER_Seen
);
11191 ER_Val
:= Expr_Val
;
11194 Check_Duplicate_Property
(Prop
, EW_Seen
);
11195 EW_Val
:= Expr_Val
;
11198 -- The handling of property "others" must take into account
11199 -- all other named properties that have been encountered so
11200 -- far. Only those that have not been seen are affected by
11204 if not AR_Seen
then
11205 AR_Val
:= Expr_Val
;
11208 if not AW_Seen
then
11209 AW_Val
:= Expr_Val
;
11212 if not ER_Seen
then
11213 ER_Val
:= Expr_Val
;
11216 if not EW_Seen
then
11217 EW_Val
:= Expr_Val
;
11220 end Analyze_External_Property
;
11222 ----------------------------
11223 -- Analyze_Part_Of_Option --
11224 ----------------------------
11226 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11227 Encap
: constant Node_Id
:= Expression
(Opt
);
11228 Constits
: Elist_Id
;
11229 Encap_Id
: Entity_Id
;
11233 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11236 (Indic
=> First
(Choices
(Opt
)),
11237 Item_Id
=> State_Id
,
11239 Encap_Id
=> Encap_Id
,
11242 -- The Part_Of indicator transforms the abstract state into
11243 -- a constituent of the encapsulating state or single
11244 -- concurrent type.
11247 pragma Assert
(Present
(Encap_Id
));
11248 Constits
:= Part_Of_Constituents
(Encap_Id
);
11250 if No
(Constits
) then
11251 Constits
:= New_Elmt_List
;
11252 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
11255 Append_Elmt
(State_Id
, Constits
);
11256 Set_Encapsulating_State
(State_Id
, Encap_Id
);
11258 end Analyze_Part_Of_Option
;
11260 ----------------------------
11261 -- Check_Duplicate_Option --
11262 ----------------------------
11264 procedure Check_Duplicate_Option
11266 Status
: in out Boolean)
11270 SPARK_Msg_N
("duplicate state option", Opt
);
11274 end Check_Duplicate_Option
;
11276 ------------------------------
11277 -- Check_Duplicate_Property --
11278 ------------------------------
11280 procedure Check_Duplicate_Property
11282 Status
: in out Boolean)
11286 SPARK_Msg_N
("duplicate external property", Prop
);
11290 end Check_Duplicate_Property
;
11292 -----------------------------
11293 -- Check_Ghost_Synchronous --
11294 -----------------------------
11296 procedure Check_Ghost_Synchronous
is
11298 -- A synchronized abstract state cannot be Ghost and vice
11299 -- versa (SPARK RM 6.9(19)).
11301 if Ghost_Seen
and Synchronous_Seen
then
11302 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
11304 end Check_Ghost_Synchronous
;
11306 ---------------------------
11307 -- Create_Abstract_State --
11308 ---------------------------
11310 procedure Create_Abstract_State
11317 -- The abstract state may be semi-declared when the related
11318 -- package was withed through a limited with clause. In that
11319 -- case reuse the entity to fully declare the state.
11321 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
11322 State_Id
:= Entity
(Decl
);
11324 -- Otherwise the elaboration of pragma Abstract_State
11325 -- declares the state.
11328 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
11330 if Present
(Decl
) then
11331 Set_Entity
(Decl
, State_Id
);
11335 -- Null states never come from source
11337 Set_Comes_From_Source
(State_Id
, not Is_Null
);
11338 Set_Parent
(State_Id
, State
);
11339 Set_Ekind
(State_Id
, E_Abstract_State
);
11340 Set_Etype
(State_Id
, Standard_Void_Type
);
11341 Set_Encapsulating_State
(State_Id
, Empty
);
11343 -- An abstract state declared within a Ghost region becomes
11344 -- Ghost (SPARK RM 6.9(2)).
11346 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
11347 Set_Is_Ghost_Entity
(State_Id
);
11350 -- Establish a link between the state declaration and the
11351 -- abstract state entity. Note that a null state remains as
11352 -- N_Null and does not carry any linkages.
11354 if not Is_Null
then
11355 if Present
(Decl
) then
11356 Set_Entity
(Decl
, State_Id
);
11357 Set_Etype
(Decl
, Standard_Void_Type
);
11360 -- Every non-null state must be defined, nameable and
11363 Push_Scope
(Pack_Id
);
11364 Generate_Definition
(State_Id
);
11365 Enter_Name
(State_Id
);
11368 end Create_Abstract_State
;
11375 -- Start of processing for Analyze_Abstract_State
11378 -- A package with a null abstract state is not allowed to
11379 -- declare additional states.
11383 ("package & has null abstract state", State
, Pack_Id
);
11385 -- Null states appear as internally generated entities
11387 elsif Nkind
(State
) = N_Null
then
11388 Create_Abstract_State
11389 (Nam
=> New_Internal_Name
('S'),
11391 Loc
=> Sloc
(State
),
11395 -- Catch a case where a null state appears in a list of
11396 -- non-null states.
11398 if Non_Null_Seen
then
11400 ("package & has non-null abstract state",
11404 -- Simple state declaration
11406 elsif Nkind
(State
) = N_Identifier
then
11407 Create_Abstract_State
11408 (Nam
=> Chars
(State
),
11410 Loc
=> Sloc
(State
),
11412 Non_Null_Seen
:= True;
11414 -- State declaration with various options. This construct
11415 -- appears as an extension aggregate in the tree.
11417 elsif Nkind
(State
) = N_Extension_Aggregate
then
11418 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11419 Create_Abstract_State
11420 (Nam
=> Chars
(Ancestor_Part
(State
)),
11421 Decl
=> Ancestor_Part
(State
),
11422 Loc
=> Sloc
(Ancestor_Part
(State
)),
11424 Non_Null_Seen
:= True;
11427 ("state name must be an identifier",
11428 Ancestor_Part
(State
));
11431 -- Options External, Ghost and Synchronous appear as
11434 Opt
:= First
(Expressions
(State
));
11435 while Present
(Opt
) loop
11436 if Nkind
(Opt
) = N_Identifier
then
11440 if Chars
(Opt
) = Name_External
then
11441 Check_Duplicate_Option
(Opt
, External_Seen
);
11442 Analyze_External_Option
(Opt
);
11446 elsif Chars
(Opt
) = Name_Ghost
then
11447 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11448 Check_Ghost_Synchronous
;
11450 if Present
(State_Id
) then
11451 Set_Is_Ghost_Entity
(State_Id
);
11456 elsif Chars
(Opt
) = Name_Synchronous
then
11457 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11458 Check_Ghost_Synchronous
;
11460 -- Option Part_Of without an encapsulating state is
11461 -- illegal (SPARK RM 7.1.4(9)).
11463 elsif Chars
(Opt
) = Name_Part_Of
then
11465 ("indicator Part_Of must denote abstract state, "
11466 & "single protected type or single task type",
11469 -- Do not emit an error message when a previous state
11470 -- declaration with options was not parenthesized as
11471 -- the option is actually another state declaration.
11473 -- with Abstract_State
11474 -- (State_1 with ..., -- missing parentheses
11475 -- (State_2 with ...),
11476 -- State_3) -- ok state declaration
11478 elsif Missing_Parentheses
then
11481 -- Otherwise the option is not allowed. Note that it
11482 -- is not possible to distinguish between an option
11483 -- and a state declaration when a previous state with
11484 -- options not properly parentheses.
11486 -- with Abstract_State
11487 -- (State_1 with ..., -- missing parentheses
11488 -- State_2); -- could be an option
11492 ("simple option not allowed in state declaration",
11496 -- Catch a case where missing parentheses around a state
11497 -- declaration with options cause a subsequent state
11498 -- declaration with options to be treated as an option.
11500 -- with Abstract_State
11501 -- (State_1 with ..., -- missing parentheses
11502 -- (State_2 with ...))
11504 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11505 Missing_Parentheses
:= True;
11507 ("state declaration must be parenthesized",
11508 Ancestor_Part
(State
));
11510 -- Otherwise the option is malformed
11513 SPARK_Msg_N
("malformed option", Opt
);
11519 -- Options External and Part_Of appear as component
11522 Opt
:= First
(Component_Associations
(State
));
11523 while Present
(Opt
) loop
11524 Opt_Nam
:= First
(Choices
(Opt
));
11526 if Nkind
(Opt_Nam
) = N_Identifier
then
11527 if Chars
(Opt_Nam
) = Name_External
then
11528 Analyze_External_Option
(Opt
);
11530 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11531 Analyze_Part_Of_Option
(Opt
);
11534 SPARK_Msg_N
("invalid state option", Opt
);
11537 SPARK_Msg_N
("invalid state option", Opt
);
11543 -- Any other attempt to declare a state is illegal
11546 Malformed_State_Error
(State
);
11550 -- Guard against a junk state. In such cases no entity is
11551 -- generated and the subsequent checks cannot be applied.
11553 if Present
(State_Id
) then
11555 -- Verify whether the state does not introduce an illegal
11556 -- hidden state within a package subject to a null abstract
11559 Check_No_Hidden_State
(State_Id
);
11561 -- Check whether the lack of option Part_Of agrees with the
11562 -- placement of the abstract state with respect to the state
11565 if not Part_Of_Seen
then
11566 Check_Missing_Part_Of
(State_Id
);
11569 -- Associate the state with its related package
11571 if No
(Abstract_States
(Pack_Id
)) then
11572 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11575 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11577 end Analyze_Abstract_State
;
11579 ---------------------------
11580 -- Malformed_State_Error --
11581 ---------------------------
11583 procedure Malformed_State_Error
(State
: Node_Id
) is
11585 Error_Msg_N
("malformed abstract state declaration", State
);
11587 -- An abstract state with a simple option is being declared
11588 -- with "=>" rather than the legal "with". The state appears
11589 -- as a component association.
11591 if Nkind
(State
) = N_Component_Association
then
11592 Error_Msg_N
("\use WITH to specify simple option", State
);
11594 end Malformed_State_Error
;
11598 Pack_Decl
: Node_Id
;
11599 Pack_Id
: Entity_Id
;
11603 -- Start of processing for Abstract_State
11607 Check_No_Identifiers
;
11608 Check_Arg_Count
(1);
11610 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11612 -- Ensure the proper placement of the pragma. Abstract states must
11613 -- be associated with a package declaration.
11615 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11616 N_Package_Declaration
)
11620 -- Otherwise the pragma is associated with an illegal construct
11627 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11629 -- A pragma that applies to a Ghost entity becomes Ghost for the
11630 -- purposes of legality checks and removal of ignored Ghost code.
11632 Mark_Ghost_Pragma
(N
, Pack_Id
);
11633 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11635 -- Chain the pragma on the contract for completeness
11637 Add_Contract_Item
(N
, Pack_Id
);
11639 -- The legality checks of pragmas Abstract_State, Initializes, and
11640 -- Initial_Condition are affected by the SPARK mode in effect. In
11641 -- addition, these three pragmas are subject to an inherent order:
11643 -- 1) Abstract_State
11645 -- 3) Initial_Condition
11647 -- Analyze all these pragmas in the order outlined above
11649 Analyze_If_Present
(Pragma_SPARK_Mode
);
11650 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11652 -- Multiple non-null abstract states appear as an aggregate
11654 if Nkind
(States
) = N_Aggregate
then
11655 State
:= First
(Expressions
(States
));
11656 while Present
(State
) loop
11657 Analyze_Abstract_State
(State
, Pack_Id
);
11661 -- An abstract state with a simple option is being illegaly
11662 -- declared with "=>" rather than "with". In this case the
11663 -- state declaration appears as a component association.
11665 if Present
(Component_Associations
(States
)) then
11666 State
:= First
(Component_Associations
(States
));
11667 while Present
(State
) loop
11668 Malformed_State_Error
(State
);
11673 -- Various forms of a single abstract state. Note that these may
11674 -- include malformed state declarations.
11677 Analyze_Abstract_State
(States
, Pack_Id
);
11680 Analyze_If_Present
(Pragma_Initializes
);
11681 Analyze_If_Present
(Pragma_Initial_Condition
);
11682 end Abstract_State
;
11690 -- Note: this pragma also has some specific processing in Par.Prag
11691 -- because we want to set the Ada version mode during parsing.
11693 when Pragma_Ada_83
=>
11695 Check_Arg_Count
(0);
11697 -- We really should check unconditionally for proper configuration
11698 -- pragma placement, since we really don't want mixed Ada modes
11699 -- within a single unit, and the GNAT reference manual has always
11700 -- said this was a configuration pragma, but we did not check and
11701 -- are hesitant to add the check now.
11703 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11704 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11705 -- or Ada 2012 mode.
11707 if Ada_Version
>= Ada_2005
then
11708 Check_Valid_Configuration_Pragma
;
11711 -- Now set Ada 83 mode
11713 if Latest_Ada_Only
then
11714 Error_Pragma
("??pragma% ignored");
11716 Ada_Version
:= Ada_83
;
11717 Ada_Version_Explicit
:= Ada_83
;
11718 Ada_Version_Pragma
:= N
;
11727 -- Note: this pragma also has some specific processing in Par.Prag
11728 -- because we want to set the Ada 83 version mode during parsing.
11730 when Pragma_Ada_95
=>
11732 Check_Arg_Count
(0);
11734 -- We really should check unconditionally for proper configuration
11735 -- pragma placement, since we really don't want mixed Ada modes
11736 -- within a single unit, and the GNAT reference manual has always
11737 -- said this was a configuration pragma, but we did not check and
11738 -- are hesitant to add the check now.
11740 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11741 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11743 if Ada_Version
>= Ada_2005
then
11744 Check_Valid_Configuration_Pragma
;
11747 -- Now set Ada 95 mode
11749 if Latest_Ada_Only
then
11750 Error_Pragma
("??pragma% ignored");
11752 Ada_Version
:= Ada_95
;
11753 Ada_Version_Explicit
:= Ada_95
;
11754 Ada_Version_Pragma
:= N
;
11757 ---------------------
11758 -- Ada_05/Ada_2005 --
11759 ---------------------
11762 -- pragma Ada_05 (LOCAL_NAME);
11764 -- pragma Ada_2005;
11765 -- pragma Ada_2005 (LOCAL_NAME):
11767 -- Note: these pragmas also have some specific processing in Par.Prag
11768 -- because we want to set the Ada 2005 version mode during parsing.
11770 -- The one argument form is used for managing the transition from
11771 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11772 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11773 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11774 -- mode, a preference rule is established which does not choose
11775 -- such an entity unless it is unambiguously specified. This avoids
11776 -- extra subprograms marked this way from generating ambiguities in
11777 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11778 -- intended for exclusive use in the GNAT run-time library.
11789 if Arg_Count
= 1 then
11790 Check_Arg_Is_Local_Name
(Arg1
);
11791 E_Id
:= Get_Pragma_Arg
(Arg1
);
11793 if Etype
(E_Id
) = Any_Type
then
11797 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
11798 Record_Rep_Item
(Entity
(E_Id
), N
);
11801 Check_Arg_Count
(0);
11803 -- For Ada_2005 we unconditionally enforce the documented
11804 -- configuration pragma placement, since we do not want to
11805 -- tolerate mixed modes in a unit involving Ada 2005. That
11806 -- would cause real difficulties for those cases where there
11807 -- are incompatibilities between Ada 95 and Ada 2005.
11809 Check_Valid_Configuration_Pragma
;
11811 -- Now set appropriate Ada mode
11813 if Latest_Ada_Only
then
11814 Error_Pragma
("??pragma% ignored");
11816 Ada_Version
:= Ada_2005
;
11817 Ada_Version_Explicit
:= Ada_2005
;
11818 Ada_Version_Pragma
:= N
;
11823 ---------------------
11824 -- Ada_12/Ada_2012 --
11825 ---------------------
11828 -- pragma Ada_12 (LOCAL_NAME);
11830 -- pragma Ada_2012;
11831 -- pragma Ada_2012 (LOCAL_NAME):
11833 -- Note: these pragmas also have some specific processing in Par.Prag
11834 -- because we want to set the Ada 2012 version mode during parsing.
11836 -- The one argument form is used for managing the transition from Ada
11837 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11838 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
11839 -- mode will generate a warning. In addition, in any pre-Ada_2012
11840 -- mode, a preference rule is established which does not choose
11841 -- such an entity unless it is unambiguously specified. This avoids
11842 -- extra subprograms marked this way from generating ambiguities in
11843 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11844 -- intended for exclusive use in the GNAT run-time library.
11855 if Arg_Count
= 1 then
11856 Check_Arg_Is_Local_Name
(Arg1
);
11857 E_Id
:= Get_Pragma_Arg
(Arg1
);
11859 if Etype
(E_Id
) = Any_Type
then
11863 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
11864 Record_Rep_Item
(Entity
(E_Id
), N
);
11867 Check_Arg_Count
(0);
11869 -- For Ada_2012 we unconditionally enforce the documented
11870 -- configuration pragma placement, since we do not want to
11871 -- tolerate mixed modes in a unit involving Ada 2012. That
11872 -- would cause real difficulties for those cases where there
11873 -- are incompatibilities between Ada 95 and Ada 2012. We could
11874 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11876 Check_Valid_Configuration_Pragma
;
11878 -- Now set appropriate Ada mode
11880 Ada_Version
:= Ada_2012
;
11881 Ada_Version_Explicit
:= Ada_2012
;
11882 Ada_Version_Pragma
:= N
;
11890 -- pragma Ada_2020;
11892 -- Note: this pragma also has some specific processing in Par.Prag
11893 -- because we want to set the Ada 2020 version mode during parsing.
11895 when Pragma_Ada_2020
=>
11898 Check_Arg_Count
(0);
11900 Check_Valid_Configuration_Pragma
;
11902 -- Now set appropriate Ada mode
11904 Ada_Version
:= Ada_2020
;
11905 Ada_Version_Explicit
:= Ada_2020
;
11906 Ada_Version_Pragma
:= N
;
11908 ----------------------
11909 -- All_Calls_Remote --
11910 ----------------------
11912 -- pragma All_Calls_Remote [(library_package_NAME)];
11914 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
11915 Lib_Entity
: Entity_Id
;
11918 Check_Ada_83_Warning
;
11919 Check_Valid_Library_Unit_Pragma
;
11921 if Nkind
(N
) = N_Null_Statement
then
11925 Lib_Entity
:= Find_Lib_Unit_Name
;
11927 -- A pragma that applies to a Ghost entity becomes Ghost for the
11928 -- purposes of legality checks and removal of ignored Ghost code.
11930 Mark_Ghost_Pragma
(N
, Lib_Entity
);
11932 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11934 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
11935 if not Is_Remote_Call_Interface
(Lib_Entity
) then
11936 Error_Pragma
("pragma% only apply to rci unit");
11938 -- Set flag for entity of the library unit
11941 Set_Has_All_Calls_Remote
(Lib_Entity
);
11944 end All_Calls_Remote
;
11946 ---------------------------
11947 -- Allow_Integer_Address --
11948 ---------------------------
11950 -- pragma Allow_Integer_Address;
11952 when Pragma_Allow_Integer_Address
=>
11954 Check_Valid_Configuration_Pragma
;
11955 Check_Arg_Count
(0);
11957 -- If Address is a private type, then set the flag to allow
11958 -- integer address values. If Address is not private, then this
11959 -- pragma has no purpose, so it is simply ignored. Not clear if
11960 -- there are any such targets now.
11962 if Opt
.Address_Is_Private
then
11963 Opt
.Allow_Integer_Address
:= True;
11971 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11972 -- ARG ::= NAME | EXPRESSION
11974 -- The first two arguments are by convention intended to refer to an
11975 -- external tool and a tool-specific function. These arguments are
11978 when Pragma_Annotate
=> Annotate
: declare
11985 Check_At_Least_N_Arguments
(1);
11987 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
11989 -- Determine whether the last argument is "Entity => local_NAME"
11990 -- and if it is, perform the required semantic checks. Remove the
11991 -- argument from further processing.
11993 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
11994 and then Chars
(Nam_Arg
) = Name_Entity
11996 Check_Arg_Is_Local_Name
(Nam_Arg
);
11997 Arg_Count
:= Arg_Count
- 1;
11999 -- A pragma that applies to a Ghost entity becomes Ghost for
12000 -- the purposes of legality checks and removal of ignored Ghost
12003 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12004 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12006 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12009 -- Not allowed in compiler units (bootstrap issues)
12011 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
12014 -- Continue the processing with last argument removed for now
12016 Check_Arg_Is_Identifier
(Arg1
);
12017 Check_No_Identifiers
;
12020 -- The second parameter is optional, it is never analyzed
12025 -- Otherwise there is a second parameter
12028 -- The second parameter must be an identifier
12030 Check_Arg_Is_Identifier
(Arg2
);
12032 -- Process the remaining parameters (if any)
12034 Arg
:= Next
(Arg2
);
12035 while Present
(Arg
) loop
12036 Expr
:= Get_Pragma_Arg
(Arg
);
12039 if Is_Entity_Name
(Expr
) then
12042 -- For string literals, we assume Standard_String as the
12043 -- type, unless the string contains wide or wide_wide
12046 elsif Nkind
(Expr
) = N_String_Literal
then
12047 if Has_Wide_Wide_Character
(Expr
) then
12048 Resolve
(Expr
, Standard_Wide_Wide_String
);
12049 elsif Has_Wide_Character
(Expr
) then
12050 Resolve
(Expr
, Standard_Wide_String
);
12052 Resolve
(Expr
, Standard_String
);
12055 elsif Is_Overloaded
(Expr
) then
12056 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
12067 -------------------------------------------------
12068 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12069 -------------------------------------------------
12072 -- ( [Check => ] Boolean_EXPRESSION
12073 -- [, [Message =>] Static_String_EXPRESSION]);
12075 -- pragma Assert_And_Cut
12076 -- ( [Check => ] Boolean_EXPRESSION
12077 -- [, [Message =>] Static_String_EXPRESSION]);
12080 -- ( [Check => ] Boolean_EXPRESSION
12081 -- [, [Message =>] Static_String_EXPRESSION]);
12083 -- pragma Loop_Invariant
12084 -- ( [Check => ] Boolean_EXPRESSION
12085 -- [, [Message =>] Static_String_EXPRESSION]);
12088 | Pragma_Assert_And_Cut
12090 | Pragma_Loop_Invariant
12093 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
12094 -- Determine whether expression Expr contains a Loop_Entry
12095 -- attribute reference.
12097 -------------------------
12098 -- Contains_Loop_Entry --
12099 -------------------------
12101 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
12102 Has_Loop_Entry
: Boolean := False;
12104 function Process
(N
: Node_Id
) return Traverse_Result
;
12105 -- Process function for traversal to look for Loop_Entry
12111 function Process
(N
: Node_Id
) return Traverse_Result
is
12113 if Nkind
(N
) = N_Attribute_Reference
12114 and then Attribute_Name
(N
) = Name_Loop_Entry
12116 Has_Loop_Entry
:= True;
12123 procedure Traverse
is new Traverse_Proc
(Process
);
12125 -- Start of processing for Contains_Loop_Entry
12129 return Has_Loop_Entry
;
12130 end Contains_Loop_Entry
;
12135 New_Args
: List_Id
;
12137 -- Start of processing for Assert
12140 -- Assert is an Ada 2005 RM-defined pragma
12142 if Prag_Id
= Pragma_Assert
then
12145 -- The remaining ones are GNAT pragmas
12151 Check_At_Least_N_Arguments
(1);
12152 Check_At_Most_N_Arguments
(2);
12153 Check_Arg_Order
((Name_Check
, Name_Message
));
12154 Check_Optional_Identifier
(Arg1
, Name_Check
);
12155 Expr
:= Get_Pragma_Arg
(Arg1
);
12157 -- Special processing for Loop_Invariant, Loop_Variant or for
12158 -- other cases where a Loop_Entry attribute is present. If the
12159 -- assertion pragma contains attribute Loop_Entry, ensure that
12160 -- the related pragma is within a loop.
12162 if Prag_Id
= Pragma_Loop_Invariant
12163 or else Prag_Id
= Pragma_Loop_Variant
12164 or else Contains_Loop_Entry
(Expr
)
12166 Check_Loop_Pragma_Placement
;
12168 -- Perform preanalysis to deal with embedded Loop_Entry
12171 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
12174 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12175 -- a corresponding Check pragma:
12177 -- pragma Check (name, condition [, msg]);
12179 -- Where name is the identifier matching the pragma name. So
12180 -- rewrite pragma in this manner, transfer the message argument
12181 -- if present, and analyze the result
12183 -- Note: When dealing with a semantically analyzed tree, the
12184 -- information that a Check node N corresponds to a source Assert,
12185 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12186 -- pragma kind of Original_Node(N).
12188 New_Args
:= New_List
(
12189 Make_Pragma_Argument_Association
(Loc
,
12190 Expression
=> Make_Identifier
(Loc
, Pname
)),
12191 Make_Pragma_Argument_Association
(Sloc
(Expr
),
12192 Expression
=> Expr
));
12194 if Arg_Count
> 1 then
12195 Check_Optional_Identifier
(Arg2
, Name_Message
);
12197 -- Provide semantic annnotations for optional argument, for
12198 -- ASIS use, before rewriting.
12200 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
12201 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
12204 -- Rewrite as Check pragma
12208 Chars
=> Name_Check
,
12209 Pragma_Argument_Associations
=> New_Args
));
12214 ----------------------
12215 -- Assertion_Policy --
12216 ----------------------
12218 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12220 -- The following form is Ada 2012 only, but we allow it in all modes
12222 -- Pragma Assertion_Policy (
12223 -- ASSERTION_KIND => POLICY_IDENTIFIER
12224 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12226 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12228 -- RM_ASSERTION_KIND ::= Assert |
12229 -- Static_Predicate |
12230 -- Dynamic_Predicate |
12235 -- Type_Invariant |
12236 -- Type_Invariant'Class
12238 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12240 -- Contract_Cases |
12242 -- Default_Initial_Condition |
12244 -- Initial_Condition |
12245 -- Loop_Invariant |
12251 -- Statement_Assertions
12253 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12254 -- ID_ASSERTION_KIND list contains implementation-defined additions
12255 -- recognized by GNAT. The effect is to control the behavior of
12256 -- identically named aspects and pragmas, depending on the specified
12257 -- policy identifier:
12259 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12261 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12262 -- implementation-defined addition that results in totally ignoring
12263 -- the corresponding assertion. If Disable is specified, then the
12264 -- argument of the assertion is not even analyzed. This is useful
12265 -- when the aspect/pragma argument references entities in a with'ed
12266 -- package that is replaced by a dummy package in the final build.
12268 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12269 -- and Type_Invariant'Class were recognized by the parser and
12270 -- transformed into references to the special internal identifiers
12271 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12272 -- processing is required here.
12274 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
12275 procedure Resolve_Suppressible
(Policy
: Node_Id
);
12276 -- Converts the assertion policy 'Suppressible' to either Check or
12277 -- Ignore based on whether checks are suppressed via -gnatp.
12279 --------------------------
12280 -- Resolve_Suppressible --
12281 --------------------------
12283 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
12284 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
12288 -- Transform policy argument Suppressible into either Ignore or
12289 -- Check depending on whether checks are enabled or suppressed.
12291 if Chars
(Arg
) = Name_Suppressible
then
12292 if Suppress_Checks
then
12293 Nam
:= Name_Ignore
;
12298 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
12300 end Resolve_Suppressible
;
12312 -- This can always appear as a configuration pragma
12314 if Is_Configuration_Pragma
then
12317 -- It can also appear in a declarative part or package spec in Ada
12318 -- 2012 mode. We allow this in other modes, but in that case we
12319 -- consider that we have an Ada 2012 pragma on our hands.
12322 Check_Is_In_Decl_Part_Or_Package_Spec
;
12326 -- One argument case with no identifier (first form above)
12329 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
12330 or else Chars
(Arg1
) = No_Name
)
12332 Check_Arg_Is_One_Of
(Arg1
,
12333 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12335 Resolve_Suppressible
(Arg1
);
12337 -- Treat one argument Assertion_Policy as equivalent to:
12339 -- pragma Check_Policy (Assertion, policy)
12341 -- So rewrite pragma in that manner and link on to the chain
12342 -- of Check_Policy pragmas, marking the pragma as analyzed.
12344 Policy
:= Get_Pragma_Arg
(Arg1
);
12348 Chars
=> Name_Check_Policy
,
12349 Pragma_Argument_Associations
=> New_List
(
12350 Make_Pragma_Argument_Association
(Loc
,
12351 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
12353 Make_Pragma_Argument_Association
(Loc
,
12355 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
12358 -- Here if we have two or more arguments
12361 Check_At_Least_N_Arguments
(1);
12364 -- Loop through arguments
12367 while Present
(Arg
) loop
12368 LocP
:= Sloc
(Arg
);
12370 -- Kind must be specified
12372 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12373 or else Chars
(Arg
) = No_Name
12376 ("missing assertion kind for pragma%", Arg
);
12379 -- Check Kind and Policy have allowed forms
12381 Kind
:= Chars
(Arg
);
12382 Policy
:= Get_Pragma_Arg
(Arg
);
12384 if not Is_Valid_Assertion_Kind
(Kind
) then
12386 ("invalid assertion kind for pragma%", Arg
);
12389 Check_Arg_Is_One_Of
(Arg
,
12390 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12392 Resolve_Suppressible
(Arg
);
12394 if Kind
= Name_Ghost
then
12396 -- The Ghost policy must be either Check or Ignore
12397 -- (SPARK RM 6.9(6)).
12399 if not Nam_In
(Chars
(Policy
), Name_Check
,
12403 ("argument of pragma % Ghost must be Check or "
12404 & "Ignore", Policy
);
12407 -- Pragma Assertion_Policy specifying a Ghost policy
12408 -- cannot occur within a Ghost subprogram or package
12409 -- (SPARK RM 6.9(14)).
12411 if Ghost_Mode
> None
then
12413 ("pragma % cannot appear within ghost subprogram or "
12418 -- Rewrite the Assertion_Policy pragma as a series of
12419 -- Check_Policy pragmas of the form:
12421 -- Check_Policy (Kind, Policy);
12423 -- Note: the insertion of the pragmas cannot be done with
12424 -- Insert_Action because in the configuration case, there
12425 -- are no scopes on the scope stack and the mechanism will
12428 Insert_Before_And_Analyze
(N
,
12430 Chars
=> Name_Check_Policy
,
12431 Pragma_Argument_Associations
=> New_List
(
12432 Make_Pragma_Argument_Association
(LocP
,
12433 Expression
=> Make_Identifier
(LocP
, Kind
)),
12434 Make_Pragma_Argument_Association
(LocP
,
12435 Expression
=> Policy
))));
12440 -- Rewrite the Assertion_Policy pragma as null since we have
12441 -- now inserted all the equivalent Check pragmas.
12443 Rewrite
(N
, Make_Null_Statement
(Loc
));
12446 end Assertion_Policy
;
12448 ------------------------------
12449 -- Assume_No_Invalid_Values --
12450 ------------------------------
12452 -- pragma Assume_No_Invalid_Values (On | Off);
12454 when Pragma_Assume_No_Invalid_Values
=>
12456 Check_Valid_Configuration_Pragma
;
12457 Check_Arg_Count
(1);
12458 Check_No_Identifiers
;
12459 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12461 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12462 Assume_No_Invalid_Values
:= True;
12464 Assume_No_Invalid_Values
:= False;
12467 --------------------------
12468 -- Attribute_Definition --
12469 --------------------------
12471 -- pragma Attribute_Definition
12472 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12473 -- [Entity =>] LOCAL_NAME,
12474 -- [Expression =>] EXPRESSION | NAME);
12476 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12477 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12482 Check_Arg_Count
(3);
12483 Check_Optional_Identifier
(Arg1
, "attribute");
12484 Check_Optional_Identifier
(Arg2
, "entity");
12485 Check_Optional_Identifier
(Arg3
, "expression");
12487 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12488 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12492 Check_Arg_Is_Local_Name
(Arg2
);
12494 -- If the attribute is not recognized, then issue a warning (not
12495 -- an error), and ignore the pragma.
12497 Aname
:= Chars
(Attribute_Designator
);
12499 if not Is_Attribute_Name
(Aname
) then
12500 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12504 -- Otherwise, rewrite the pragma as an attribute definition clause
12507 Make_Attribute_Definition_Clause
(Loc
,
12508 Name
=> Get_Pragma_Arg
(Arg2
),
12510 Expression
=> Get_Pragma_Arg
(Arg3
)));
12512 end Attribute_Definition
;
12514 ------------------------------------------------------------------
12515 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12516 ------------------------------------------------------------------
12518 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12519 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12520 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12521 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12523 when Pragma_Async_Readers
12524 | Pragma_Async_Writers
12525 | Pragma_Effective_Reads
12526 | Pragma_Effective_Writes
12528 Async_Effective
: declare
12529 Obj_Decl
: Node_Id
;
12530 Obj_Id
: Entity_Id
;
12534 Check_No_Identifiers
;
12535 Check_At_Most_N_Arguments
(1);
12537 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12539 -- Object declaration
12541 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12544 -- Otherwise the pragma is associated with an illegal construact
12551 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12553 -- Perform minimal verification to ensure that the argument is at
12554 -- least a variable. Subsequent finer grained checks will be done
12555 -- at the end of the declarative region the contains the pragma.
12557 if Ekind
(Obj_Id
) = E_Variable
then
12559 -- A pragma that applies to a Ghost entity becomes Ghost for
12560 -- the purposes of legality checks and removal of ignored Ghost
12563 Mark_Ghost_Pragma
(N
, Obj_Id
);
12565 -- Chain the pragma on the contract for further processing by
12566 -- Analyze_External_Property_In_Decl_Part.
12568 Add_Contract_Item
(N
, Obj_Id
);
12570 -- Analyze the Boolean expression (if any)
12572 if Present
(Arg1
) then
12573 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12576 -- Otherwise the external property applies to a constant
12579 Error_Pragma
("pragma % must apply to a volatile object");
12581 end Async_Effective
;
12587 -- pragma Asynchronous (LOCAL_NAME);
12589 when Pragma_Asynchronous
=> Asynchronous
: declare
12592 Formal
: Entity_Id
;
12597 procedure Process_Async_Pragma
;
12598 -- Common processing for procedure and access-to-procedure case
12600 --------------------------
12601 -- Process_Async_Pragma --
12602 --------------------------
12604 procedure Process_Async_Pragma
is
12607 Set_Is_Asynchronous
(Nm
);
12611 -- The formals should be of mode IN (RM E.4.1(6))
12614 while Present
(S
) loop
12615 Formal
:= Defining_Identifier
(S
);
12617 if Nkind
(Formal
) = N_Defining_Identifier
12618 and then Ekind
(Formal
) /= E_In_Parameter
12621 ("pragma% procedure can only have IN parameter",
12628 Set_Is_Asynchronous
(Nm
);
12629 end Process_Async_Pragma
;
12631 -- Start of processing for pragma Asynchronous
12634 Check_Ada_83_Warning
;
12635 Check_No_Identifiers
;
12636 Check_Arg_Count
(1);
12637 Check_Arg_Is_Local_Name
(Arg1
);
12639 if Debug_Flag_U
then
12643 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12644 Analyze
(Get_Pragma_Arg
(Arg1
));
12645 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12647 -- A pragma that applies to a Ghost entity becomes Ghost for the
12648 -- purposes of legality checks and removal of ignored Ghost code.
12650 Mark_Ghost_Pragma
(N
, Nm
);
12652 if not Is_Remote_Call_Interface
(C_Ent
)
12653 and then not Is_Remote_Types
(C_Ent
)
12655 -- This pragma should only appear in an RCI or Remote Types
12656 -- unit (RM E.4.1(4)).
12659 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12662 if Ekind
(Nm
) = E_Procedure
12663 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12665 if not Is_Remote_Call_Interface
(Nm
) then
12667 ("pragma% cannot be applied on non-remote procedure",
12671 L
:= Parameter_Specifications
(Parent
(Nm
));
12672 Process_Async_Pragma
;
12675 elsif Ekind
(Nm
) = E_Function
then
12677 ("pragma% cannot be applied to function", Arg1
);
12679 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12680 if Is_Record_Type
(Nm
) then
12682 -- A record type that is the Equivalent_Type for a remote
12683 -- access-to-subprogram type.
12685 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
12688 -- A non-expanded RAS type (distribution is not enabled)
12690 Decl
:= Declaration_Node
(Nm
);
12693 if Nkind
(Decl
) = N_Full_Type_Declaration
12694 and then Nkind
(Type_Definition
(Decl
)) =
12695 N_Access_Procedure_Definition
12697 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
12698 Process_Async_Pragma
;
12700 if Is_Asynchronous
(Nm
)
12701 and then Expander_Active
12702 and then Get_PCS_Name
/= Name_No_DSA
12704 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
12709 ("pragma% cannot reference access-to-function type",
12713 -- Only other possibility is Access-to-class-wide type
12715 elsif Is_Access_Type
(Nm
)
12716 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
12718 Check_First_Subtype
(Arg1
);
12719 Set_Is_Asynchronous
(Nm
);
12720 if Expander_Active
then
12721 RACW_Type_Is_Asynchronous
(Nm
);
12725 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12733 -- pragma Atomic (LOCAL_NAME);
12735 when Pragma_Atomic
=>
12736 Process_Atomic_Independent_Shared_Volatile
;
12738 -----------------------
12739 -- Atomic_Components --
12740 -----------------------
12742 -- pragma Atomic_Components (array_LOCAL_NAME);
12744 -- This processing is shared by Volatile_Components
12746 when Pragma_Atomic_Components
12747 | Pragma_Volatile_Components
12749 Atomic_Components
: declare
12756 Check_Ada_83_Warning
;
12757 Check_No_Identifiers
;
12758 Check_Arg_Count
(1);
12759 Check_Arg_Is_Local_Name
(Arg1
);
12760 E_Id
:= Get_Pragma_Arg
(Arg1
);
12762 if Etype
(E_Id
) = Any_Type
then
12766 E
:= Entity
(E_Id
);
12768 -- A pragma that applies to a Ghost entity becomes Ghost for the
12769 -- purposes of legality checks and removal of ignored Ghost code.
12771 Mark_Ghost_Pragma
(N
, E
);
12772 Check_Duplicate_Pragma
(E
);
12774 if Rep_Item_Too_Early
(E
, N
)
12776 Rep_Item_Too_Late
(E
, N
)
12781 D
:= Declaration_Node
(E
);
12784 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
12786 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
12787 and then Nkind
(D
) = N_Object_Declaration
12788 and then Nkind
(Object_Definition
(D
)) =
12789 N_Constrained_Array_Definition
)
12791 -- The flag is set on the object, or on the base type
12793 if Nkind
(D
) /= N_Object_Declaration
then
12794 E
:= Base_Type
(E
);
12797 -- Atomic implies both Independent and Volatile
12799 if Prag_Id
= Pragma_Atomic_Components
then
12800 Set_Has_Atomic_Components
(E
);
12801 Set_Has_Independent_Components
(E
);
12804 Set_Has_Volatile_Components
(E
);
12807 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
12809 end Atomic_Components
;
12811 --------------------
12812 -- Attach_Handler --
12813 --------------------
12815 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12817 when Pragma_Attach_Handler
=>
12818 Check_Ada_83_Warning
;
12819 Check_No_Identifiers
;
12820 Check_Arg_Count
(2);
12822 if No_Run_Time_Mode
then
12823 Error_Msg_CRT
("Attach_Handler pragma", N
);
12825 Check_Interrupt_Or_Attach_Handler
;
12827 -- The expression that designates the attribute may depend on a
12828 -- discriminant, and is therefore a per-object expression, to
12829 -- be expanded in the init proc. If expansion is enabled, then
12830 -- perform semantic checks on a copy only.
12835 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
12838 -- In Relaxed_RM_Semantics mode, we allow any static
12839 -- integer value, for compatibility with other compilers.
12841 if Relaxed_RM_Semantics
12842 and then Nkind
(Parg2
) = N_Integer_Literal
12844 Typ
:= Standard_Integer
;
12846 Typ
:= RTE
(RE_Interrupt_ID
);
12849 if Expander_Active
then
12850 Temp
:= New_Copy_Tree
(Parg2
);
12851 Set_Parent
(Temp
, N
);
12852 Preanalyze_And_Resolve
(Temp
, Typ
);
12855 Resolve
(Parg2
, Typ
);
12859 Process_Interrupt_Or_Attach_Handler
;
12862 --------------------
12863 -- C_Pass_By_Copy --
12864 --------------------
12866 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12868 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
12874 Check_Valid_Configuration_Pragma
;
12875 Check_Arg_Count
(1);
12876 Check_Optional_Identifier
(Arg1
, "max_size");
12878 Arg
:= Get_Pragma_Arg
(Arg1
);
12879 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
12881 Val
:= Expr_Value
(Arg
);
12885 ("maximum size for pragma% must be positive", Arg1
);
12887 elsif UI_Is_In_Int_Range
(Val
) then
12888 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
12890 -- If a giant value is given, Int'Last will do well enough.
12891 -- If sometime someone complains that a record larger than
12892 -- two gigabytes is not copied, we will worry about it then.
12895 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
12897 end C_Pass_By_Copy
;
12903 -- pragma Check ([Name =>] CHECK_KIND,
12904 -- [Check =>] Boolean_EXPRESSION
12905 -- [,[Message =>] String_EXPRESSION]);
12907 -- CHECK_KIND ::= IDENTIFIER |
12910 -- Invariant'Class |
12911 -- Type_Invariant'Class
12913 -- The identifiers Assertions and Statement_Assertions are not
12914 -- allowed, since they have special meaning for Check_Policy.
12916 -- WARNING: The code below manages Ghost regions. Return statements
12917 -- must be replaced by gotos which jump to the end of the code and
12918 -- restore the Ghost mode.
12920 when Pragma_Check
=> Check
: declare
12921 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
12922 -- Save the Ghost mode to restore on exit
12928 pragma Warnings
(Off
, Str
);
12931 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12932 -- the mode now to ensure that any nodes generated during analysis
12933 -- and expansion are marked as Ghost.
12935 Set_Ghost_Mode
(N
);
12938 Check_At_Least_N_Arguments
(2);
12939 Check_At_Most_N_Arguments
(3);
12940 Check_Optional_Identifier
(Arg1
, Name_Name
);
12941 Check_Optional_Identifier
(Arg2
, Name_Check
);
12943 if Arg_Count
= 3 then
12944 Check_Optional_Identifier
(Arg3
, Name_Message
);
12945 Str
:= Get_Pragma_Arg
(Arg3
);
12948 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
12949 Check_Arg_Is_Identifier
(Arg1
);
12950 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
12952 -- Check forbidden name Assertions or Statement_Assertions
12955 when Name_Assertions
=>
12957 ("""Assertions"" is not allowed as a check kind for "
12958 & "pragma%", Arg1
);
12960 when Name_Statement_Assertions
=>
12962 ("""Statement_Assertions"" is not allowed as a check kind "
12963 & "for pragma%", Arg1
);
12969 -- Check applicable policy. We skip this if Checked/Ignored status
12970 -- is already set (e.g. in the case of a pragma from an aspect).
12972 if Is_Checked
(N
) or else Is_Ignored
(N
) then
12975 -- For a non-source pragma that is a rewriting of another pragma,
12976 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12978 elsif Is_Rewrite_Substitution
(N
)
12979 and then Nkind
(Original_Node
(N
)) = N_Pragma
12980 and then Original_Node
(N
) /= N
12982 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12983 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12985 -- Otherwise query the applicable policy at this point
12988 case Check_Kind
(Cname
) is
12989 when Name_Ignore
=>
12990 Set_Is_Ignored
(N
, True);
12991 Set_Is_Checked
(N
, False);
12994 Set_Is_Ignored
(N
, False);
12995 Set_Is_Checked
(N
, True);
12997 -- For disable, rewrite pragma as null statement and skip
12998 -- rest of the analysis of the pragma.
13000 when Name_Disable
=>
13001 Rewrite
(N
, Make_Null_Statement
(Loc
));
13005 -- No other possibilities
13008 raise Program_Error
;
13012 -- If check kind was not Disable, then continue pragma analysis
13014 Expr
:= Get_Pragma_Arg
(Arg2
);
13016 -- Deal with SCO generation
13018 if Is_Checked
(N
) and then not Split_PPC
(N
) then
13019 Set_SCO_Pragma_Enabled
(Loc
);
13022 -- Deal with analyzing the string argument
13024 if Arg_Count
= 3 then
13026 -- If checks are not on we don't want any expansion (since
13027 -- such expansion would not get properly deleted) but
13028 -- we do want to analyze (to get proper references).
13029 -- The Preanalyze_And_Resolve routine does just what we want
13031 if Is_Ignored
(N
) then
13032 Preanalyze_And_Resolve
(Str
, Standard_String
);
13034 -- Otherwise we need a proper analysis and expansion
13037 Analyze_And_Resolve
(Str
, Standard_String
);
13041 -- Now you might think we could just do the same with the Boolean
13042 -- expression if checks are off (and expansion is on) and then
13043 -- rewrite the check as a null statement. This would work but we
13044 -- would lose the useful warnings about an assertion being bound
13045 -- to fail even if assertions are turned off.
13047 -- So instead we wrap the boolean expression in an if statement
13048 -- that looks like:
13050 -- if False and then condition then
13054 -- The reason we do this rewriting during semantic analysis rather
13055 -- than as part of normal expansion is that we cannot analyze and
13056 -- expand the code for the boolean expression directly, or it may
13057 -- cause insertion of actions that would escape the attempt to
13058 -- suppress the check code.
13060 -- Note that the Sloc for the if statement corresponds to the
13061 -- argument condition, not the pragma itself. The reason for
13062 -- this is that we may generate a warning if the condition is
13063 -- False at compile time, and we do not want to delete this
13064 -- warning when we delete the if statement.
13066 if Expander_Active
and Is_Ignored
(N
) then
13067 Eloc
:= Sloc
(Expr
);
13070 Make_If_Statement
(Eloc
,
13072 Make_And_Then
(Eloc
,
13073 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
13074 Right_Opnd
=> Expr
),
13075 Then_Statements
=> New_List
(
13076 Make_Null_Statement
(Eloc
))));
13078 -- Now go ahead and analyze the if statement
13080 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13082 -- One rather special treatment. If we are now in Eliminated
13083 -- overflow mode, then suppress overflow checking since we do
13084 -- not want to drag in the bignum stuff if we are in Ignore
13085 -- mode anyway. This is particularly important if we are using
13086 -- a configurable run time that does not support bignum ops.
13088 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
13090 Svo
: constant Boolean :=
13091 Scope_Suppress
.Suppress
(Overflow_Check
);
13093 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
13094 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
13096 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
13097 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
13100 -- Not that special case
13106 -- All done with this check
13108 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13110 -- Check is active or expansion not active. In these cases we can
13111 -- just go ahead and analyze the boolean with no worries.
13114 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13115 Analyze_And_Resolve
(Expr
, Any_Boolean
);
13116 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13119 Restore_Ghost_Mode
(Saved_GM
);
13122 --------------------------
13123 -- Check_Float_Overflow --
13124 --------------------------
13126 -- pragma Check_Float_Overflow;
13128 when Pragma_Check_Float_Overflow
=>
13130 Check_Valid_Configuration_Pragma
;
13131 Check_Arg_Count
(0);
13132 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
13138 -- pragma Check_Name (check_IDENTIFIER);
13140 when Pragma_Check_Name
=>
13142 Check_No_Identifiers
;
13143 Check_Valid_Configuration_Pragma
;
13144 Check_Arg_Count
(1);
13145 Check_Arg_Is_Identifier
(Arg1
);
13148 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
13151 for J
in Check_Names
.First
.. Check_Names
.Last
loop
13152 if Check_Names
.Table
(J
) = Nam
then
13157 Check_Names
.Append
(Nam
);
13164 -- This is the old style syntax, which is still allowed in all modes:
13166 -- pragma Check_Policy ([Name =>] CHECK_KIND
13167 -- [Policy =>] POLICY_IDENTIFIER);
13169 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13171 -- CHECK_KIND ::= IDENTIFIER |
13174 -- Type_Invariant'Class |
13177 -- This is the new style syntax, compatible with Assertion_Policy
13178 -- and also allowed in all modes.
13180 -- Pragma Check_Policy (
13181 -- CHECK_KIND => POLICY_IDENTIFIER
13182 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13184 -- Note: the identifiers Name and Policy are not allowed as
13185 -- Check_Kind values. This avoids ambiguities between the old and
13186 -- new form syntax.
13188 when Pragma_Check_Policy
=> Check_Policy
: declare
13193 Check_At_Least_N_Arguments
(1);
13195 -- A Check_Policy pragma can appear either as a configuration
13196 -- pragma, or in a declarative part or a package spec (see RM
13197 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13198 -- followed for Check_Policy).
13200 if not Is_Configuration_Pragma
then
13201 Check_Is_In_Decl_Part_Or_Package_Spec
;
13204 -- Figure out if we have the old or new syntax. We have the
13205 -- old syntax if the first argument has no identifier, or the
13206 -- identifier is Name.
13208 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
13209 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
13213 Check_Arg_Count
(2);
13214 Check_Optional_Identifier
(Arg1
, Name_Name
);
13215 Kind
:= Get_Pragma_Arg
(Arg1
);
13216 Rewrite_Assertion_Kind
(Kind
,
13217 From_Policy
=> Comes_From_Source
(N
));
13218 Check_Arg_Is_Identifier
(Arg1
);
13220 -- Check forbidden check kind
13222 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
13223 Error_Msg_Name_2
:= Chars
(Kind
);
13225 ("pragma% does not allow% as check name", Arg1
);
13230 Check_Optional_Identifier
(Arg2
, Name_Policy
);
13231 Check_Arg_Is_One_Of
13233 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
13235 -- And chain pragma on the Check_Policy_List for search
13237 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
13238 Opt
.Check_Policy_List
:= N
;
13240 -- For the new syntax, what we do is to convert each argument to
13241 -- an old syntax equivalent. We do that because we want to chain
13242 -- old style Check_Policy pragmas for the search (we don't want
13243 -- to have to deal with multiple arguments in the search).
13254 while Present
(Arg
) loop
13255 LocP
:= Sloc
(Arg
);
13256 Argx
:= Get_Pragma_Arg
(Arg
);
13258 -- Kind must be specified
13260 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13261 or else Chars
(Arg
) = No_Name
13264 ("missing assertion kind for pragma%", Arg
);
13267 -- Construct equivalent old form syntax Check_Policy
13268 -- pragma and insert it to get remaining checks.
13272 Chars
=> Name_Check_Policy
,
13273 Pragma_Argument_Associations
=> New_List
(
13274 Make_Pragma_Argument_Association
(LocP
,
13276 Make_Identifier
(LocP
, Chars
(Arg
))),
13277 Make_Pragma_Argument_Association
(Sloc
(Argx
),
13278 Expression
=> Argx
)));
13282 -- For a configuration pragma, insert old form in
13283 -- the corresponding file.
13285 if Is_Configuration_Pragma
then
13286 Insert_After
(N
, New_P
);
13290 Insert_Action
(N
, New_P
);
13294 -- Rewrite original Check_Policy pragma to null, since we
13295 -- have converted it into a series of old syntax pragmas.
13297 Rewrite
(N
, Make_Null_Statement
(Loc
));
13307 -- pragma Comment (static_string_EXPRESSION)
13309 -- Processing for pragma Comment shares the circuitry for pragma
13310 -- Ident. The only differences are that Ident enforces a limit of 31
13311 -- characters on its argument, and also enforces limitations on
13312 -- placement for DEC compatibility. Pragma Comment shares neither of
13313 -- these restrictions.
13315 -------------------
13316 -- Common_Object --
13317 -------------------
13319 -- pragma Common_Object (
13320 -- [Internal =>] LOCAL_NAME
13321 -- [, [External =>] EXTERNAL_SYMBOL]
13322 -- [, [Size =>] EXTERNAL_SYMBOL]);
13324 -- Processing for this pragma is shared with Psect_Object
13326 ------------------------
13327 -- Compile_Time_Error --
13328 ------------------------
13330 -- pragma Compile_Time_Error
13331 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13333 when Pragma_Compile_Time_Error
=>
13335 Process_Compile_Time_Warning_Or_Error
;
13337 --------------------------
13338 -- Compile_Time_Warning --
13339 --------------------------
13341 -- pragma Compile_Time_Warning
13342 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13344 when Pragma_Compile_Time_Warning
=>
13346 Process_Compile_Time_Warning_Or_Error
;
13348 ---------------------------
13349 -- Compiler_Unit_Warning --
13350 ---------------------------
13352 -- pragma Compiler_Unit_Warning;
13356 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13357 -- errors not warnings. This means that we had introduced a big extra
13358 -- inertia to compiler changes, since even if we implemented a new
13359 -- feature, and even if all versions to be used for bootstrapping
13360 -- implemented this new feature, we could not use it, since old
13361 -- compilers would give errors for using this feature in units
13362 -- having Compiler_Unit pragmas.
13364 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13365 -- problem. We no longer have any units mentioning Compiler_Unit,
13366 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13367 -- and thus generates a warning which can be ignored. So that deals
13368 -- with the problem of old compilers not implementing the newer form
13371 -- Newer compilers recognize the new pragma, but generate warning
13372 -- messages instead of errors, which again can be ignored in the
13373 -- case of an old compiler which implements a wanted new feature
13374 -- but at the time felt like warning about it for older compilers.
13376 -- We retain Compiler_Unit so that new compilers can be used to build
13377 -- older run-times that use this pragma. That's an unusual case, but
13378 -- it's easy enough to handle, so why not?
13380 when Pragma_Compiler_Unit
13381 | Pragma_Compiler_Unit_Warning
13384 Check_Arg_Count
(0);
13386 -- Only recognized in main unit
13388 if Current_Sem_Unit
= Main_Unit
then
13389 Compiler_Unit
:= True;
13392 -----------------------------
13393 -- Complete_Representation --
13394 -----------------------------
13396 -- pragma Complete_Representation;
13398 when Pragma_Complete_Representation
=>
13400 Check_Arg_Count
(0);
13402 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13404 ("pragma & must appear within record representation clause");
13407 ----------------------------
13408 -- Complex_Representation --
13409 ----------------------------
13411 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13413 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13420 Check_Arg_Count
(1);
13421 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13422 Check_Arg_Is_Local_Name
(Arg1
);
13423 E_Id
:= Get_Pragma_Arg
(Arg1
);
13425 if Etype
(E_Id
) = Any_Type
then
13429 E
:= Entity
(E_Id
);
13431 if not Is_Record_Type
(E
) then
13433 ("argument for pragma% must be record type", Arg1
);
13436 Ent
:= First_Entity
(E
);
13439 or else No
(Next_Entity
(Ent
))
13440 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13441 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13442 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13445 ("record for pragma% must have two fields of the same "
13446 & "floating-point type", Arg1
);
13449 Set_Has_Complex_Representation
(Base_Type
(E
));
13451 -- We need to treat the type has having a non-standard
13452 -- representation, for back-end purposes, even though in
13453 -- general a complex will have the default representation
13454 -- of a record with two real components.
13456 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13458 end Complex_Representation
;
13460 -------------------------
13461 -- Component_Alignment --
13462 -------------------------
13464 -- pragma Component_Alignment (
13465 -- [Form =>] ALIGNMENT_CHOICE
13466 -- [, [Name =>] type_LOCAL_NAME]);
13468 -- ALIGNMENT_CHOICE ::=
13470 -- | Component_Size_4
13474 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13475 Args
: Args_List
(1 .. 2);
13476 Names
: constant Name_List
(1 .. 2) := (
13480 Form
: Node_Id
renames Args
(1);
13481 Name
: Node_Id
renames Args
(2);
13483 Atype
: Component_Alignment_Kind
;
13488 Gather_Associations
(Names
, Args
);
13491 Error_Pragma
("missing Form argument for pragma%");
13494 Check_Arg_Is_Identifier
(Form
);
13496 -- Get proper alignment, note that Default = Component_Size on all
13497 -- machines we have so far, and we want to set this value rather
13498 -- than the default value to indicate that it has been explicitly
13499 -- set (and thus will not get overridden by the default component
13500 -- alignment for the current scope)
13502 if Chars
(Form
) = Name_Component_Size
then
13503 Atype
:= Calign_Component_Size
;
13505 elsif Chars
(Form
) = Name_Component_Size_4
then
13506 Atype
:= Calign_Component_Size_4
;
13508 elsif Chars
(Form
) = Name_Default
then
13509 Atype
:= Calign_Component_Size
;
13511 elsif Chars
(Form
) = Name_Storage_Unit
then
13512 Atype
:= Calign_Storage_Unit
;
13516 ("invalid Form parameter for pragma%", Form
);
13519 -- The pragma appears in a configuration file
13521 if No
(Parent
(N
)) then
13522 Check_Valid_Configuration_Pragma
;
13524 -- Capture the component alignment in a global variable when
13525 -- the pragma appears in a configuration file. Note that the
13526 -- scope stack is empty at this point and cannot be used to
13527 -- store the alignment value.
13529 Configuration_Component_Alignment
:= Atype
;
13531 -- Case with no name, supplied, affects scope table entry
13533 elsif No
(Name
) then
13535 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13537 -- Case of name supplied
13540 Check_Arg_Is_Local_Name
(Name
);
13542 Typ
:= Entity
(Name
);
13545 or else Rep_Item_Too_Early
(Typ
, N
)
13549 Typ
:= Underlying_Type
(Typ
);
13552 if not Is_Record_Type
(Typ
)
13553 and then not Is_Array_Type
(Typ
)
13556 ("Name parameter of pragma% must identify record or "
13557 & "array type", Name
);
13560 -- An explicit Component_Alignment pragma overrides an
13561 -- implicit pragma Pack, but not an explicit one.
13563 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13564 Set_Is_Packed
(Base_Type
(Typ
), False);
13565 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13568 end Component_AlignmentP
;
13570 --------------------------------
13571 -- Constant_After_Elaboration --
13572 --------------------------------
13574 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13576 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13578 Obj_Decl
: Node_Id
;
13579 Obj_Id
: Entity_Id
;
13583 Check_No_Identifiers
;
13584 Check_At_Most_N_Arguments
(1);
13586 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13588 -- Object declaration
13590 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
13593 -- Otherwise the pragma is associated with an illegal construct
13600 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13602 -- The object declaration must be a library-level variable which
13603 -- is either explicitly initialized or obtains a value during the
13604 -- elaboration of a package body (SPARK RM 3.3.1).
13606 if Ekind
(Obj_Id
) = E_Variable
then
13607 if not Is_Library_Level_Entity
(Obj_Id
) then
13609 ("pragma % must apply to a library level variable");
13613 -- Otherwise the pragma applies to a constant, which is illegal
13616 Error_Pragma
("pragma % must apply to a variable declaration");
13620 -- A pragma that applies to a Ghost entity becomes Ghost for the
13621 -- purposes of legality checks and removal of ignored Ghost code.
13623 Mark_Ghost_Pragma
(N
, Obj_Id
);
13625 -- Chain the pragma on the contract for completeness
13627 Add_Contract_Item
(N
, Obj_Id
);
13629 -- Analyze the Boolean expression (if any)
13631 if Present
(Arg1
) then
13632 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13634 end Constant_After_Elaboration
;
13636 --------------------
13637 -- Contract_Cases --
13638 --------------------
13640 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13642 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13644 -- CASE_GUARD ::= boolean_EXPRESSION | others
13646 -- CONSEQUENCE ::= boolean_EXPRESSION
13648 -- Characteristics:
13650 -- * Analysis - The annotation undergoes initial checks to verify
13651 -- the legal placement and context. Secondary checks preanalyze the
13654 -- Analyze_Contract_Cases_In_Decl_Part
13656 -- * Expansion - The annotation is expanded during the expansion of
13657 -- the related subprogram [body] contract as performed in:
13659 -- Expand_Subprogram_Contract
13661 -- * Template - The annotation utilizes the generic template of the
13662 -- related subprogram [body] when it is:
13664 -- aspect on subprogram declaration
13665 -- aspect on stand alone subprogram body
13666 -- pragma on stand alone subprogram body
13668 -- The annotation must prepare its own template when it is:
13670 -- pragma on subprogram declaration
13672 -- * Globals - Capture of global references must occur after full
13675 -- * Instance - The annotation is instantiated automatically when
13676 -- the related generic subprogram [body] is instantiated except for
13677 -- the "pragma on subprogram declaration" case. In that scenario
13678 -- the annotation must instantiate itself.
13680 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13681 Spec_Id
: Entity_Id
;
13682 Subp_Decl
: Node_Id
;
13683 Subp_Spec
: Node_Id
;
13687 Check_No_Identifiers
;
13688 Check_Arg_Count
(1);
13690 -- Ensure the proper placement of the pragma. Contract_Cases must
13691 -- be associated with a subprogram declaration or a body that acts
13695 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13699 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13702 -- Generic subprogram
13704 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13707 -- Body acts as spec
13709 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13710 and then No
(Corresponding_Spec
(Subp_Decl
))
13714 -- Body stub acts as spec
13716 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13717 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13723 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13724 Subp_Spec
:= Specification
(Subp_Decl
);
13726 -- Pragma Contract_Cases is forbidden on null procedures, as
13727 -- this may lead to potential ambiguities in behavior when
13728 -- interface null procedures are involved.
13730 if Nkind
(Subp_Spec
) = N_Procedure_Specification
13731 and then Null_Present
(Subp_Spec
)
13733 Error_Msg_N
(Fix_Error
13734 ("pragma % cannot apply to null procedure"), N
);
13743 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13745 -- A pragma that applies to a Ghost entity becomes Ghost for the
13746 -- purposes of legality checks and removal of ignored Ghost code.
13748 Mark_Ghost_Pragma
(N
, Spec_Id
);
13749 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13751 -- Chain the pragma on the contract for further processing by
13752 -- Analyze_Contract_Cases_In_Decl_Part.
13754 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13756 -- Fully analyze the pragma when it appears inside an entry
13757 -- or subprogram body because it cannot benefit from forward
13760 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13762 N_Subprogram_Body_Stub
)
13764 -- The legality checks of pragma Contract_Cases are affected by
13765 -- the SPARK mode in effect and the volatility of the context.
13766 -- Analyze all pragmas in a specific order.
13768 Analyze_If_Present
(Pragma_SPARK_Mode
);
13769 Analyze_If_Present
(Pragma_Volatile_Function
);
13770 Analyze_Contract_Cases_In_Decl_Part
(N
);
13772 end Contract_Cases
;
13778 -- pragma Controlled (first_subtype_LOCAL_NAME);
13780 when Pragma_Controlled
=> Controlled
: declare
13784 Check_No_Identifiers
;
13785 Check_Arg_Count
(1);
13786 Check_Arg_Is_Local_Name
(Arg1
);
13787 Arg
:= Get_Pragma_Arg
(Arg1
);
13789 if not Is_Entity_Name
(Arg
)
13790 or else not Is_Access_Type
(Entity
(Arg
))
13792 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
13794 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
13802 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13803 -- [Entity =>] LOCAL_NAME);
13805 when Pragma_Convention
=> Convention
: declare
13808 pragma Warnings
(Off
, C
);
13809 pragma Warnings
(Off
, E
);
13812 Check_Arg_Order
((Name_Convention
, Name_Entity
));
13813 Check_Ada_83_Warning
;
13814 Check_Arg_Count
(2);
13815 Process_Convention
(C
, E
);
13817 -- A pragma that applies to a Ghost entity becomes Ghost for the
13818 -- purposes of legality checks and removal of ignored Ghost code.
13820 Mark_Ghost_Pragma
(N
, E
);
13823 ---------------------------
13824 -- Convention_Identifier --
13825 ---------------------------
13827 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13828 -- [Convention =>] convention_IDENTIFIER);
13830 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
13836 Check_Arg_Order
((Name_Name
, Name_Convention
));
13837 Check_Arg_Count
(2);
13838 Check_Optional_Identifier
(Arg1
, Name_Name
);
13839 Check_Optional_Identifier
(Arg2
, Name_Convention
);
13840 Check_Arg_Is_Identifier
(Arg1
);
13841 Check_Arg_Is_Identifier
(Arg2
);
13842 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
13843 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
13845 if Is_Convention_Name
(Cname
) then
13846 Record_Convention_Identifier
13847 (Idnam
, Get_Convention_Id
(Cname
));
13850 ("second arg for % pragma must be convention", Arg2
);
13852 end Convention_Identifier
;
13858 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13860 when Pragma_CPP_Class
=>
13863 if Warn_On_Obsolescent_Feature
then
13865 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13866 & "effect; replace it by pragma import?j?", N
);
13869 Check_Arg_Count
(1);
13873 Chars
=> Name_Import
,
13874 Pragma_Argument_Associations
=> New_List
(
13875 Make_Pragma_Argument_Association
(Loc
,
13876 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
13877 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
13880 ---------------------
13881 -- CPP_Constructor --
13882 ---------------------
13884 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13885 -- [, [External_Name =>] static_string_EXPRESSION ]
13886 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13888 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
13891 Def_Id
: Entity_Id
;
13892 Tag_Typ
: Entity_Id
;
13896 Check_At_Least_N_Arguments
(1);
13897 Check_At_Most_N_Arguments
(3);
13898 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13899 Check_Arg_Is_Local_Name
(Arg1
);
13901 Id
:= Get_Pragma_Arg
(Arg1
);
13902 Find_Program_Unit_Name
(Id
);
13904 -- If we did not find the name, we are done
13906 if Etype
(Id
) = Any_Type
then
13910 Def_Id
:= Entity
(Id
);
13912 -- Check if already defined as constructor
13914 if Is_Constructor
(Def_Id
) then
13916 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
13920 if Ekind
(Def_Id
) = E_Function
13921 and then (Is_CPP_Class
(Etype
(Def_Id
))
13922 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
13924 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
13926 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
13928 ("'C'P'P constructor must be defined in the scope of "
13929 & "its returned type", Arg1
);
13932 if Arg_Count
>= 2 then
13933 Set_Imported
(Def_Id
);
13934 Set_Is_Public
(Def_Id
);
13935 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
13938 Set_Has_Completion
(Def_Id
);
13939 Set_Is_Constructor
(Def_Id
);
13940 Set_Convention
(Def_Id
, Convention_CPP
);
13942 -- Imported C++ constructors are not dispatching primitives
13943 -- because in C++ they don't have a dispatch table slot.
13944 -- However, in Ada the constructor has the profile of a
13945 -- function that returns a tagged type and therefore it has
13946 -- been treated as a primitive operation during semantic
13947 -- analysis. We now remove it from the list of primitive
13948 -- operations of the type.
13950 if Is_Tagged_Type
(Etype
(Def_Id
))
13951 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
13952 and then Is_Dispatching_Operation
(Def_Id
)
13954 Tag_Typ
:= Etype
(Def_Id
);
13956 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
13957 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
13961 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
13962 Set_Is_Dispatching_Operation
(Def_Id
, False);
13965 -- For backward compatibility, if the constructor returns a
13966 -- class wide type, and we internally change the return type to
13967 -- the corresponding root type.
13969 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
13970 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
13974 ("pragma% requires function returning a 'C'P'P_Class type",
13977 end CPP_Constructor
;
13983 when Pragma_CPP_Virtual
=>
13986 if Warn_On_Obsolescent_Feature
then
13988 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13996 when Pragma_CPP_Vtable
=>
13999 if Warn_On_Obsolescent_Feature
then
14001 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14009 -- pragma CPU (EXPRESSION);
14011 when Pragma_CPU
=> CPU
: declare
14012 P
: constant Node_Id
:= Parent
(N
);
14018 Check_No_Identifiers
;
14019 Check_Arg_Count
(1);
14023 if Nkind
(P
) = N_Subprogram_Body
then
14024 Check_In_Main_Program
;
14026 Arg
:= Get_Pragma_Arg
(Arg1
);
14027 Analyze_And_Resolve
(Arg
, Any_Integer
);
14029 Ent
:= Defining_Unit_Name
(Specification
(P
));
14031 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
14032 Ent
:= Defining_Identifier
(Ent
);
14037 if not Is_OK_Static_Expression
(Arg
) then
14038 Flag_Non_Static_Expr
14039 ("main subprogram affinity is not static!", Arg
);
14042 -- If constraint error, then we already signalled an error
14044 elsif Raises_Constraint_Error
(Arg
) then
14047 -- Otherwise check in range
14051 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
14052 -- This is the entity System.Multiprocessors.CPU_Range;
14054 Val
: constant Uint
:= Expr_Value
(Arg
);
14057 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
14059 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
14062 ("main subprogram CPU is out of range", Arg1
);
14068 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
14072 elsif Nkind
(P
) = N_Task_Definition
then
14073 Arg
:= Get_Pragma_Arg
(Arg1
);
14074 Ent
:= Defining_Identifier
(Parent
(P
));
14076 -- The expression must be analyzed in the special manner
14077 -- described in "Handling of Default and Per-Object
14078 -- Expressions" in sem.ads.
14080 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
14082 -- Anything else is incorrect
14088 -- Check duplicate pragma before we chain the pragma in the Rep
14089 -- Item chain of Ent.
14091 Check_Duplicate_Pragma
(Ent
);
14092 Record_Rep_Item
(Ent
, N
);
14095 --------------------
14096 -- Deadline_Floor --
14097 --------------------
14099 -- pragma Deadline_Floor (time_span_EXPRESSION);
14101 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
14102 P
: constant Node_Id
:= Parent
(N
);
14108 Check_No_Identifiers
;
14109 Check_Arg_Count
(1);
14111 Arg
:= Get_Pragma_Arg
(Arg1
);
14113 -- The expression must be analyzed in the special manner described
14114 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14116 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
14118 -- Only protected types allowed
14120 if Nkind
(P
) /= N_Protected_Definition
then
14124 Ent
:= Defining_Identifier
(Parent
(P
));
14126 -- Check duplicate pragma before we chain the pragma in the Rep
14127 -- Item chain of Ent.
14129 Check_Duplicate_Pragma
(Ent
);
14130 Record_Rep_Item
(Ent
, N
);
14132 end Deadline_Floor
;
14138 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14140 when Pragma_Debug
=> Debug
: declare
14147 -- The condition for executing the call is that the expander
14148 -- is active and that we are not ignoring this debug pragma.
14153 (Expander_Active
and then not Is_Ignored
(N
)),
14156 if not Is_Ignored
(N
) then
14157 Set_SCO_Pragma_Enabled
(Loc
);
14160 if Arg_Count
= 2 then
14162 Make_And_Then
(Loc
,
14163 Left_Opnd
=> Relocate_Node
(Cond
),
14164 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
14165 Call
:= Get_Pragma_Arg
(Arg2
);
14167 Call
:= Get_Pragma_Arg
(Arg1
);
14171 N_Indexed_Component
,
14175 N_Selected_Component
)
14177 -- If this pragma Debug comes from source, its argument was
14178 -- parsed as a name form (which is syntactically identical).
14179 -- In a generic context a parameterless call will be left as
14180 -- an expanded name (if global) or selected_component if local.
14181 -- Change it to a procedure call statement now.
14183 Change_Name_To_Procedure_Call_Statement
(Call
);
14185 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
14187 -- Already in the form of a procedure call statement: nothing
14188 -- to do (could happen in case of an internally generated
14194 -- All other cases: diagnose error
14197 ("argument of pragma ""Debug"" is not procedure call",
14202 -- Rewrite into a conditional with an appropriate condition. We
14203 -- wrap the procedure call in a block so that overhead from e.g.
14204 -- use of the secondary stack does not generate execution overhead
14205 -- for suppressed conditions.
14207 -- Normally the analysis that follows will freeze the subprogram
14208 -- being called. However, if the call is to a null procedure,
14209 -- we want to freeze it before creating the block, because the
14210 -- analysis that follows may be done with expansion disabled, in
14211 -- which case the body will not be generated, leading to spurious
14214 if Nkind
(Call
) = N_Procedure_Call_Statement
14215 and then Is_Entity_Name
(Name
(Call
))
14217 Analyze
(Name
(Call
));
14218 Freeze_Before
(N
, Entity
(Name
(Call
)));
14222 Make_Implicit_If_Statement
(N
,
14224 Then_Statements
=> New_List
(
14225 Make_Block_Statement
(Loc
,
14226 Handled_Statement_Sequence
=>
14227 Make_Handled_Sequence_Of_Statements
(Loc
,
14228 Statements
=> New_List
(Relocate_Node
(Call
)))))));
14231 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14232 -- after analysis of the normally rewritten node, to capture all
14233 -- references to entities, which avoids issuing wrong warnings
14234 -- about unused entities.
14236 if GNATprove_Mode
then
14237 Rewrite
(N
, Make_Null_Statement
(Loc
));
14245 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14247 when Pragma_Debug_Policy
=>
14249 Check_Arg_Count
(1);
14250 Check_No_Identifiers
;
14251 Check_Arg_Is_Identifier
(Arg1
);
14253 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14254 -- rewrite it that way, and let the rest of the checking come
14255 -- from analyzing the rewritten pragma.
14259 Chars
=> Name_Check_Policy
,
14260 Pragma_Argument_Associations
=> New_List
(
14261 Make_Pragma_Argument_Association
(Loc
,
14262 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
14264 Make_Pragma_Argument_Association
(Loc
,
14265 Expression
=> Get_Pragma_Arg
(Arg1
)))));
14268 -------------------------------
14269 -- Default_Initial_Condition --
14270 -------------------------------
14272 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14274 when Pragma_Default_Initial_Condition
=> DIC
: declare
14281 Check_No_Identifiers
;
14282 Check_At_Most_N_Arguments
(1);
14286 while Present
(Stmt
) loop
14288 -- Skip prior pragmas, but check for duplicates
14290 if Nkind
(Stmt
) = N_Pragma
then
14291 if Pragma_Name
(Stmt
) = Pname
then
14298 -- Skip internally generated code. Note that derived type
14299 -- declarations of untagged types with discriminants are
14300 -- rewritten as private type declarations.
14302 elsif not Comes_From_Source
(Stmt
)
14303 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
14307 -- The associated private type [extension] has been found, stop
14310 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
14311 N_Private_Type_Declaration
)
14313 Typ
:= Defining_Entity
(Stmt
);
14316 -- The pragma does not apply to a legal construct, issue an
14317 -- error and stop the analysis.
14324 Stmt
:= Prev
(Stmt
);
14327 -- The pragma does not apply to a legal construct, issue an error
14328 -- and stop the analysis.
14335 -- A pragma that applies to a Ghost entity becomes Ghost for the
14336 -- purposes of legality checks and removal of ignored Ghost code.
14338 Mark_Ghost_Pragma
(N
, Typ
);
14340 -- The pragma signals that the type defines its own DIC assertion
14343 Set_Has_Own_DIC
(Typ
);
14345 -- Chain the pragma on the rep item chain for further processing
14347 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
14349 -- Create the declaration of the procedure which verifies the
14350 -- assertion expression of pragma DIC at runtime.
14352 Build_DIC_Procedure_Declaration
(Typ
);
14355 ----------------------------------
14356 -- Default_Scalar_Storage_Order --
14357 ----------------------------------
14359 -- pragma Default_Scalar_Storage_Order
14360 -- (High_Order_First | Low_Order_First);
14362 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
14363 Default
: Character;
14367 Check_Arg_Count
(1);
14369 -- Default_Scalar_Storage_Order can appear as a configuration
14370 -- pragma, or in a declarative part of a package spec.
14372 if not Is_Configuration_Pragma
then
14373 Check_Is_In_Decl_Part_Or_Package_Spec
;
14376 Check_No_Identifiers
;
14377 Check_Arg_Is_One_Of
14378 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
14379 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14380 Default
:= Fold_Upper
(Name_Buffer
(1));
14382 if not Support_Nondefault_SSO_On_Target
14383 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
14385 if Warn_On_Unrecognized_Pragma
then
14387 ("non-default Scalar_Storage_Order not supported "
14388 & "on target?g?", N
);
14390 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
14393 -- Here set the specified default
14396 Opt
.Default_SSO
:= Default
;
14400 --------------------------
14401 -- Default_Storage_Pool --
14402 --------------------------
14404 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14406 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
14411 Check_Arg_Count
(1);
14413 -- Default_Storage_Pool can appear as a configuration pragma, or
14414 -- in a declarative part of a package spec.
14416 if not Is_Configuration_Pragma
then
14417 Check_Is_In_Decl_Part_Or_Package_Spec
;
14420 if From_Aspect_Specification
(N
) then
14422 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
14424 if not In_Open_Scopes
(E
) then
14426 ("aspect must apply to package or subprogram", N
);
14431 if Present
(Arg1
) then
14432 Pool
:= Get_Pragma_Arg
(Arg1
);
14434 -- Case of Default_Storage_Pool (null);
14436 if Nkind
(Pool
) = N_Null
then
14439 -- This is an odd case, this is not really an expression,
14440 -- so we don't have a type for it. So just set the type to
14443 Set_Etype
(Pool
, Empty
);
14445 -- Case of Default_Storage_Pool (storage_pool_NAME);
14448 -- If it's a configuration pragma, then the only allowed
14449 -- argument is "null".
14451 if Is_Configuration_Pragma
then
14452 Error_Pragma_Arg
("NULL expected", Arg1
);
14455 -- The expected type for a non-"null" argument is
14456 -- Root_Storage_Pool'Class, and the pool must be a variable.
14458 Analyze_And_Resolve
14459 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
14461 if Is_Variable
(Pool
) then
14463 -- A pragma that applies to a Ghost entity becomes Ghost
14464 -- for the purposes of legality checks and removal of
14465 -- ignored Ghost code.
14467 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14471 ("default storage pool must be a variable", Arg1
);
14475 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14476 -- access type will use this information to set the appropriate
14477 -- attributes of the access type. If the pragma appears in a
14478 -- generic unit it is ignored, given that it may refer to a
14481 if not Inside_A_Generic
then
14482 Default_Pool
:= Pool
;
14485 end Default_Storage_Pool
;
14491 -- pragma Depends (DEPENDENCY_RELATION);
14493 -- DEPENDENCY_RELATION ::=
14495 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14497 -- DEPENDENCY_CLAUSE ::=
14498 -- OUTPUT_LIST =>[+] INPUT_LIST
14499 -- | NULL_DEPENDENCY_CLAUSE
14501 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14503 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14505 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14507 -- OUTPUT ::= NAME | FUNCTION_RESULT
14510 -- where FUNCTION_RESULT is a function Result attribute_reference
14512 -- Characteristics:
14514 -- * Analysis - The annotation undergoes initial checks to verify
14515 -- the legal placement and context. Secondary checks fully analyze
14516 -- the dependency clauses in:
14518 -- Analyze_Depends_In_Decl_Part
14520 -- * Expansion - None.
14522 -- * Template - The annotation utilizes the generic template of the
14523 -- related subprogram [body] when it is:
14525 -- aspect on subprogram declaration
14526 -- aspect on stand alone subprogram body
14527 -- pragma on stand alone subprogram body
14529 -- The annotation must prepare its own template when it is:
14531 -- pragma on subprogram declaration
14533 -- * Globals - Capture of global references must occur after full
14536 -- * Instance - The annotation is instantiated automatically when
14537 -- the related generic subprogram [body] is instantiated except for
14538 -- the "pragma on subprogram declaration" case. In that scenario
14539 -- the annotation must instantiate itself.
14541 when Pragma_Depends
=> Depends
: declare
14543 Spec_Id
: Entity_Id
;
14544 Subp_Decl
: Node_Id
;
14547 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14551 -- Chain the pragma on the contract for further processing by
14552 -- Analyze_Depends_In_Decl_Part.
14554 Add_Contract_Item
(N
, Spec_Id
);
14556 -- Fully analyze the pragma when it appears inside an entry
14557 -- or subprogram body because it cannot benefit from forward
14560 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14562 N_Subprogram_Body_Stub
)
14564 -- The legality checks of pragmas Depends and Global are
14565 -- affected by the SPARK mode in effect and the volatility
14566 -- of the context. In addition these two pragmas are subject
14567 -- to an inherent order:
14572 -- Analyze all these pragmas in the order outlined above
14574 Analyze_If_Present
(Pragma_SPARK_Mode
);
14575 Analyze_If_Present
(Pragma_Volatile_Function
);
14576 Analyze_If_Present
(Pragma_Global
);
14577 Analyze_Depends_In_Decl_Part
(N
);
14582 ---------------------
14583 -- Detect_Blocking --
14584 ---------------------
14586 -- pragma Detect_Blocking;
14588 when Pragma_Detect_Blocking
=>
14590 Check_Arg_Count
(0);
14591 Check_Valid_Configuration_Pragma
;
14592 Detect_Blocking
:= True;
14594 ------------------------------------
14595 -- Disable_Atomic_Synchronization --
14596 ------------------------------------
14598 -- pragma Disable_Atomic_Synchronization [(Entity)];
14600 when Pragma_Disable_Atomic_Synchronization
=>
14602 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14604 -------------------
14605 -- Discard_Names --
14606 -------------------
14608 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14610 when Pragma_Discard_Names
=> Discard_Names
: declare
14615 Check_Ada_83_Warning
;
14617 -- Deal with configuration pragma case
14619 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14620 Global_Discard_Names
:= True;
14623 -- Otherwise, check correct appropriate context
14626 Check_Is_In_Decl_Part_Or_Package_Spec
;
14628 if Arg_Count
= 0 then
14630 -- If there is no parameter, then from now on this pragma
14631 -- applies to any enumeration, exception or tagged type
14632 -- defined in the current declarative part, and recursively
14633 -- to any nested scope.
14635 Set_Discard_Names
(Current_Scope
);
14639 Check_Arg_Count
(1);
14640 Check_Optional_Identifier
(Arg1
, Name_On
);
14641 Check_Arg_Is_Local_Name
(Arg1
);
14643 E_Id
:= Get_Pragma_Arg
(Arg1
);
14645 if Etype
(E_Id
) = Any_Type
then
14649 E
:= Entity
(E_Id
);
14651 -- A pragma that applies to a Ghost entity becomes Ghost for
14652 -- the purposes of legality checks and removal of ignored
14655 Mark_Ghost_Pragma
(N
, E
);
14657 if (Is_First_Subtype
(E
)
14659 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14660 or else Ekind
(E
) = E_Exception
14662 Set_Discard_Names
(E
);
14663 Record_Rep_Item
(E
, N
);
14667 ("inappropriate entity for pragma%", Arg1
);
14673 ------------------------
14674 -- Dispatching_Domain --
14675 ------------------------
14677 -- pragma Dispatching_Domain (EXPRESSION);
14679 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14680 P
: constant Node_Id
:= Parent
(N
);
14686 Check_No_Identifiers
;
14687 Check_Arg_Count
(1);
14689 -- This pragma is born obsolete, but not the aspect
14691 if not From_Aspect_Specification
(N
) then
14693 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14696 if Nkind
(P
) = N_Task_Definition
then
14697 Arg
:= Get_Pragma_Arg
(Arg1
);
14698 Ent
:= Defining_Identifier
(Parent
(P
));
14700 -- A pragma that applies to a Ghost entity becomes Ghost for
14701 -- the purposes of legality checks and removal of ignored Ghost
14704 Mark_Ghost_Pragma
(N
, Ent
);
14706 -- The expression must be analyzed in the special manner
14707 -- described in "Handling of Default and Per-Object
14708 -- Expressions" in sem.ads.
14710 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14712 -- Check duplicate pragma before we chain the pragma in the Rep
14713 -- Item chain of Ent.
14715 Check_Duplicate_Pragma
(Ent
);
14716 Record_Rep_Item
(Ent
, N
);
14718 -- Anything else is incorrect
14723 end Dispatching_Domain
;
14729 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14731 when Pragma_Elaborate
=> Elaborate
: declare
14736 -- Pragma must be in context items list of a compilation unit
14738 if not Is_In_Context_Clause
then
14742 -- Must be at least one argument
14744 if Arg_Count
= 0 then
14745 Error_Pragma
("pragma% requires at least one argument");
14748 -- In Ada 83 mode, there can be no items following it in the
14749 -- context list except other pragmas and implicit with clauses
14750 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14751 -- placement rule does not apply.
14753 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14755 while Present
(Citem
) loop
14756 if Nkind
(Citem
) = N_Pragma
14757 or else (Nkind
(Citem
) = N_With_Clause
14758 and then Implicit_With
(Citem
))
14763 ("(Ada 83) pragma% must be at end of context clause");
14770 -- Finally, the arguments must all be units mentioned in a with
14771 -- clause in the same context clause. Note we already checked (in
14772 -- Par.Prag) that the arguments are all identifiers or selected
14776 Outer
: while Present
(Arg
) loop
14777 Citem
:= First
(List_Containing
(N
));
14778 Inner
: while Citem
/= N
loop
14779 if Nkind
(Citem
) = N_With_Clause
14780 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14782 Set_Elaborate_Present
(Citem
, True);
14783 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14785 -- With the pragma present, elaboration calls on
14786 -- subprograms from the named unit need no further
14787 -- checks, as long as the pragma appears in the current
14788 -- compilation unit. If the pragma appears in some unit
14789 -- in the context, there might still be a need for an
14790 -- Elaborate_All_Desirable from the current compilation
14791 -- to the named unit, so we keep the check enabled.
14793 if In_Extended_Main_Source_Unit
(N
) then
14795 -- This does not apply in SPARK mode, where we allow
14796 -- pragma Elaborate, but we don't trust it to be right
14797 -- so we will still insist on the Elaborate_All.
14799 if SPARK_Mode
/= On
then
14800 Set_Suppress_Elaboration_Warnings
14801 (Entity
(Name
(Citem
)));
14813 ("argument of pragma% is not withed unit", Arg
);
14819 -- Give a warning if operating in static mode with one of the
14820 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14823 and not Dynamic_Elaboration_Checks
14825 -- pragma Elaborate not allowed in SPARK mode anyway. We
14826 -- already complained about it, no point in generating any
14827 -- further complaint.
14829 and SPARK_Mode
/= On
14832 ("?l?use of pragma Elaborate may not be safe", N
);
14834 ("?l?use pragma Elaborate_All instead if possible", N
);
14838 -------------------
14839 -- Elaborate_All --
14840 -------------------
14842 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14844 when Pragma_Elaborate_All
=> Elaborate_All
: declare
14849 Check_Ada_83_Warning
;
14851 -- Pragma must be in context items list of a compilation unit
14853 if not Is_In_Context_Clause
then
14857 -- Must be at least one argument
14859 if Arg_Count
= 0 then
14860 Error_Pragma
("pragma% requires at least one argument");
14863 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14864 -- have to appear at the end of the context clause, but may
14865 -- appear mixed in with other items, even in Ada 83 mode.
14867 -- Final check: the arguments must all be units mentioned in
14868 -- a with clause in the same context clause. Note that we
14869 -- already checked (in Par.Prag) that all the arguments are
14870 -- either identifiers or selected components.
14873 Outr
: while Present
(Arg
) loop
14874 Citem
:= First
(List_Containing
(N
));
14875 Innr
: while Citem
/= N
loop
14876 if Nkind
(Citem
) = N_With_Clause
14877 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14879 Set_Elaborate_All_Present
(Citem
, True);
14880 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14882 -- Suppress warnings and elaboration checks on the named
14883 -- unit if the pragma is in the current compilation, as
14884 -- for pragma Elaborate.
14886 if In_Extended_Main_Source_Unit
(N
) then
14887 Set_Suppress_Elaboration_Warnings
14888 (Entity
(Name
(Citem
)));
14897 Set_Error_Posted
(N
);
14899 ("argument of pragma% is not withed unit", Arg
);
14906 --------------------
14907 -- Elaborate_Body --
14908 --------------------
14910 -- pragma Elaborate_Body [( library_unit_NAME )];
14912 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
14913 Cunit_Node
: Node_Id
;
14914 Cunit_Ent
: Entity_Id
;
14917 Check_Ada_83_Warning
;
14918 Check_Valid_Library_Unit_Pragma
;
14920 if Nkind
(N
) = N_Null_Statement
then
14924 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
14925 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14927 -- A pragma that applies to a Ghost entity becomes Ghost for the
14928 -- purposes of legality checks and removal of ignored Ghost code.
14930 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
14932 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
14935 Error_Pragma
("pragma% must refer to a spec, not a body");
14937 Set_Body_Required
(Cunit_Node
, True);
14938 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
14940 -- If we are in dynamic elaboration mode, then we suppress
14941 -- elaboration warnings for the unit, since it is definitely
14942 -- fine NOT to do dynamic checks at the first level (and such
14943 -- checks will be suppressed because no elaboration boolean
14944 -- is created for Elaborate_Body packages).
14946 -- But in the static model of elaboration, Elaborate_Body is
14947 -- definitely NOT good enough to ensure elaboration safety on
14948 -- its own, since the body may WITH other units that are not
14949 -- safe from an elaboration point of view, so a client must
14950 -- still do an Elaborate_All on such units.
14952 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14953 -- Elaborate_Body always suppressed elab warnings.
14955 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
14956 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
14959 end Elaborate_Body
;
14961 ------------------------
14962 -- Elaboration_Checks --
14963 ------------------------
14965 -- pragma Elaboration_Checks (Static | Dynamic);
14967 when Pragma_Elaboration_Checks
=>
14969 Check_Arg_Count
(1);
14970 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
14972 -- Set flag accordingly (ignore attempt at dynamic elaboration
14973 -- checks in SPARK mode).
14975 Dynamic_Elaboration_Checks
:=
14976 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
14982 -- pragma Eliminate (
14983 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14984 -- [Entity =>] IDENTIFIER |
14985 -- SELECTED_COMPONENT |
14987 -- [, Source_Location => SOURCE_TRACE]);
14989 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14990 -- SOURCE_TRACE ::= STRING_LITERAL
14992 when Pragma_Eliminate
=> Eliminate
: declare
14993 Args
: Args_List
(1 .. 5);
14994 Names
: constant Name_List
(1 .. 5) := (
14997 Name_Parameter_Types
,
14999 Name_Source_Location
);
15001 -- Note : Parameter_Types and Result_Type are leftovers from
15002 -- prior implementations of the pragma. They are not generated
15003 -- by the gnatelim tool, and play no role in selecting which
15004 -- of a set of overloaded names is chosen for elimination.
15006 Unit_Name
: Node_Id
renames Args
(1);
15007 Entity
: Node_Id
renames Args
(2);
15008 Parameter_Types
: Node_Id
renames Args
(3);
15009 Result_Type
: Node_Id
renames Args
(4);
15010 Source_Location
: Node_Id
renames Args
(5);
15014 Check_Valid_Configuration_Pragma
;
15015 Gather_Associations
(Names
, Args
);
15017 if No
(Unit_Name
) then
15018 Error_Pragma
("missing Unit_Name argument for pragma%");
15022 and then (Present
(Parameter_Types
)
15024 Present
(Result_Type
)
15026 Present
(Source_Location
))
15028 Error_Pragma
("missing Entity argument for pragma%");
15031 if (Present
(Parameter_Types
)
15033 Present
(Result_Type
))
15035 Present
(Source_Location
)
15038 ("parameter profile and source location cannot be used "
15039 & "together in pragma%");
15042 Process_Eliminate_Pragma
15051 -----------------------------------
15052 -- Enable_Atomic_Synchronization --
15053 -----------------------------------
15055 -- pragma Enable_Atomic_Synchronization [(Entity)];
15057 when Pragma_Enable_Atomic_Synchronization
=>
15059 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
15066 -- [ Convention =>] convention_IDENTIFIER,
15067 -- [ Entity =>] LOCAL_NAME
15068 -- [, [External_Name =>] static_string_EXPRESSION ]
15069 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15071 when Pragma_Export
=> Export
: declare
15073 Def_Id
: Entity_Id
;
15075 pragma Warnings
(Off
, C
);
15078 Check_Ada_83_Warning
;
15082 Name_External_Name
,
15085 Check_At_Least_N_Arguments
(2);
15086 Check_At_Most_N_Arguments
(4);
15088 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15089 -- pragma Export (Entity, "external name");
15091 if Relaxed_RM_Semantics
15092 and then Arg_Count
= 2
15093 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
15096 Def_Id
:= Get_Pragma_Arg
(Arg1
);
15099 if not Is_Entity_Name
(Def_Id
) then
15100 Error_Pragma_Arg
("entity name required", Arg1
);
15103 Def_Id
:= Entity
(Def_Id
);
15104 Set_Exported
(Def_Id
, Arg1
);
15107 Process_Convention
(C
, Def_Id
);
15109 -- A pragma that applies to a Ghost entity becomes Ghost for
15110 -- the purposes of legality checks and removal of ignored Ghost
15113 Mark_Ghost_Pragma
(N
, Def_Id
);
15115 if Ekind
(Def_Id
) /= E_Constant
then
15116 Note_Possible_Modification
15117 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15120 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
15121 Set_Exported
(Def_Id
, Arg2
);
15124 -- If the entity is a deferred constant, propagate the information
15125 -- to the full view, because gigi elaborates the full view only.
15127 if Ekind
(Def_Id
) = E_Constant
15128 and then Present
(Full_View
(Def_Id
))
15131 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
15133 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
15134 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
15135 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
15140 ---------------------
15141 -- Export_Function --
15142 ---------------------
15144 -- pragma Export_Function (
15145 -- [Internal =>] LOCAL_NAME
15146 -- [, [External =>] EXTERNAL_SYMBOL]
15147 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15148 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15149 -- [, [Mechanism =>] MECHANISM]
15150 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15152 -- EXTERNAL_SYMBOL ::=
15154 -- | static_string_EXPRESSION
15156 -- PARAMETER_TYPES ::=
15158 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15160 -- TYPE_DESIGNATOR ::=
15162 -- | subtype_Name ' Access
15166 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15168 -- MECHANISM_ASSOCIATION ::=
15169 -- [formal_parameter_NAME =>] MECHANISM_NAME
15171 -- MECHANISM_NAME ::=
15175 when Pragma_Export_Function
=> Export_Function
: declare
15176 Args
: Args_List
(1 .. 6);
15177 Names
: constant Name_List
(1 .. 6) := (
15180 Name_Parameter_Types
,
15183 Name_Result_Mechanism
);
15185 Internal
: Node_Id
renames Args
(1);
15186 External
: Node_Id
renames Args
(2);
15187 Parameter_Types
: Node_Id
renames Args
(3);
15188 Result_Type
: Node_Id
renames Args
(4);
15189 Mechanism
: Node_Id
renames Args
(5);
15190 Result_Mechanism
: Node_Id
renames Args
(6);
15194 Gather_Associations
(Names
, Args
);
15195 Process_Extended_Import_Export_Subprogram_Pragma
(
15196 Arg_Internal
=> Internal
,
15197 Arg_External
=> External
,
15198 Arg_Parameter_Types
=> Parameter_Types
,
15199 Arg_Result_Type
=> Result_Type
,
15200 Arg_Mechanism
=> Mechanism
,
15201 Arg_Result_Mechanism
=> Result_Mechanism
);
15202 end Export_Function
;
15204 -------------------
15205 -- Export_Object --
15206 -------------------
15208 -- pragma Export_Object (
15209 -- [Internal =>] LOCAL_NAME
15210 -- [, [External =>] EXTERNAL_SYMBOL]
15211 -- [, [Size =>] EXTERNAL_SYMBOL]);
15213 -- EXTERNAL_SYMBOL ::=
15215 -- | static_string_EXPRESSION
15217 -- PARAMETER_TYPES ::=
15219 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15221 -- TYPE_DESIGNATOR ::=
15223 -- | subtype_Name ' Access
15227 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15229 -- MECHANISM_ASSOCIATION ::=
15230 -- [formal_parameter_NAME =>] MECHANISM_NAME
15232 -- MECHANISM_NAME ::=
15236 when Pragma_Export_Object
=> Export_Object
: declare
15237 Args
: Args_List
(1 .. 3);
15238 Names
: constant Name_List
(1 .. 3) := (
15243 Internal
: Node_Id
renames Args
(1);
15244 External
: Node_Id
renames Args
(2);
15245 Size
: Node_Id
renames Args
(3);
15249 Gather_Associations
(Names
, Args
);
15250 Process_Extended_Import_Export_Object_Pragma
(
15251 Arg_Internal
=> Internal
,
15252 Arg_External
=> External
,
15256 ----------------------
15257 -- Export_Procedure --
15258 ----------------------
15260 -- pragma Export_Procedure (
15261 -- [Internal =>] LOCAL_NAME
15262 -- [, [External =>] EXTERNAL_SYMBOL]
15263 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15264 -- [, [Mechanism =>] MECHANISM]);
15266 -- EXTERNAL_SYMBOL ::=
15268 -- | static_string_EXPRESSION
15270 -- PARAMETER_TYPES ::=
15272 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15274 -- TYPE_DESIGNATOR ::=
15276 -- | subtype_Name ' Access
15280 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15282 -- MECHANISM_ASSOCIATION ::=
15283 -- [formal_parameter_NAME =>] MECHANISM_NAME
15285 -- MECHANISM_NAME ::=
15289 when Pragma_Export_Procedure
=> Export_Procedure
: declare
15290 Args
: Args_List
(1 .. 4);
15291 Names
: constant Name_List
(1 .. 4) := (
15294 Name_Parameter_Types
,
15297 Internal
: Node_Id
renames Args
(1);
15298 External
: Node_Id
renames Args
(2);
15299 Parameter_Types
: Node_Id
renames Args
(3);
15300 Mechanism
: Node_Id
renames Args
(4);
15304 Gather_Associations
(Names
, Args
);
15305 Process_Extended_Import_Export_Subprogram_Pragma
(
15306 Arg_Internal
=> Internal
,
15307 Arg_External
=> External
,
15308 Arg_Parameter_Types
=> Parameter_Types
,
15309 Arg_Mechanism
=> Mechanism
);
15310 end Export_Procedure
;
15316 -- pragma Export_Value (
15317 -- [Value =>] static_integer_EXPRESSION,
15318 -- [Link_Name =>] static_string_EXPRESSION);
15320 when Pragma_Export_Value
=>
15322 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
15323 Check_Arg_Count
(2);
15325 Check_Optional_Identifier
(Arg1
, Name_Value
);
15326 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15328 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
15329 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15331 -----------------------------
15332 -- Export_Valued_Procedure --
15333 -----------------------------
15335 -- pragma Export_Valued_Procedure (
15336 -- [Internal =>] LOCAL_NAME
15337 -- [, [External =>] EXTERNAL_SYMBOL,]
15338 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15339 -- [, [Mechanism =>] MECHANISM]);
15341 -- EXTERNAL_SYMBOL ::=
15343 -- | static_string_EXPRESSION
15345 -- PARAMETER_TYPES ::=
15347 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15349 -- TYPE_DESIGNATOR ::=
15351 -- | subtype_Name ' Access
15355 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15357 -- MECHANISM_ASSOCIATION ::=
15358 -- [formal_parameter_NAME =>] MECHANISM_NAME
15360 -- MECHANISM_NAME ::=
15364 when Pragma_Export_Valued_Procedure
=>
15365 Export_Valued_Procedure
: declare
15366 Args
: Args_List
(1 .. 4);
15367 Names
: constant Name_List
(1 .. 4) := (
15370 Name_Parameter_Types
,
15373 Internal
: Node_Id
renames Args
(1);
15374 External
: Node_Id
renames Args
(2);
15375 Parameter_Types
: Node_Id
renames Args
(3);
15376 Mechanism
: Node_Id
renames Args
(4);
15380 Gather_Associations
(Names
, Args
);
15381 Process_Extended_Import_Export_Subprogram_Pragma
(
15382 Arg_Internal
=> Internal
,
15383 Arg_External
=> External
,
15384 Arg_Parameter_Types
=> Parameter_Types
,
15385 Arg_Mechanism
=> Mechanism
);
15386 end Export_Valued_Procedure
;
15388 -------------------
15389 -- Extend_System --
15390 -------------------
15392 -- pragma Extend_System ([Name =>] Identifier);
15394 when Pragma_Extend_System
=>
15396 Check_Valid_Configuration_Pragma
;
15397 Check_Arg_Count
(1);
15398 Check_Optional_Identifier
(Arg1
, Name_Name
);
15399 Check_Arg_Is_Identifier
(Arg1
);
15401 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15404 and then Name_Buffer
(1 .. 4) = "aux_"
15406 if Present
(System_Extend_Pragma_Arg
) then
15407 if Chars
(Get_Pragma_Arg
(Arg1
)) =
15408 Chars
(Expression
(System_Extend_Pragma_Arg
))
15412 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
15413 Error_Pragma
("pragma% conflicts with that #");
15417 System_Extend_Pragma_Arg
:= Arg1
;
15419 if not GNAT_Mode
then
15420 System_Extend_Unit
:= Arg1
;
15424 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
15427 ------------------------
15428 -- Extensions_Allowed --
15429 ------------------------
15431 -- pragma Extensions_Allowed (ON | OFF);
15433 when Pragma_Extensions_Allowed
=>
15435 Check_Arg_Count
(1);
15436 Check_No_Identifiers
;
15437 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
15439 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
15440 Extensions_Allowed
:= True;
15441 Ada_Version
:= Ada_Version_Type
'Last;
15444 Extensions_Allowed
:= False;
15445 Ada_Version
:= Ada_Version_Explicit
;
15446 Ada_Version_Pragma
:= Empty
;
15449 ------------------------
15450 -- Extensions_Visible --
15451 ------------------------
15453 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15455 -- Characteristics:
15457 -- * Analysis - The annotation is fully analyzed immediately upon
15458 -- elaboration as its expression must be static.
15460 -- * Expansion - None.
15462 -- * Template - The annotation utilizes the generic template of the
15463 -- related subprogram [body] when it is:
15465 -- aspect on subprogram declaration
15466 -- aspect on stand alone subprogram body
15467 -- pragma on stand alone subprogram body
15469 -- The annotation must prepare its own template when it is:
15471 -- pragma on subprogram declaration
15473 -- * Globals - Capture of global references must occur after full
15476 -- * Instance - The annotation is instantiated automatically when
15477 -- the related generic subprogram [body] is instantiated except for
15478 -- the "pragma on subprogram declaration" case. In that scenario
15479 -- the annotation must instantiate itself.
15481 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15482 Formal
: Entity_Id
;
15483 Has_OK_Formal
: Boolean := False;
15484 Spec_Id
: Entity_Id
;
15485 Subp_Decl
: Node_Id
;
15489 Check_No_Identifiers
;
15490 Check_At_Most_N_Arguments
(1);
15493 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15495 -- Abstract subprogram declaration
15497 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15500 -- Generic subprogram declaration
15502 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15505 -- Body acts as spec
15507 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15508 and then No
(Corresponding_Spec
(Subp_Decl
))
15512 -- Body stub acts as spec
15514 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15515 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15519 -- Subprogram declaration
15521 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15524 -- Otherwise the pragma is associated with an illegal construct
15527 Error_Pragma
("pragma % must apply to a subprogram");
15531 -- Mark the pragma as Ghost if the related subprogram is also
15532 -- Ghost. This also ensures that any expansion performed further
15533 -- below will produce Ghost nodes.
15535 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15536 Mark_Ghost_Pragma
(N
, Spec_Id
);
15538 -- Chain the pragma on the contract for completeness
15540 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15542 -- The legality checks of pragma Extension_Visible are affected
15543 -- by the SPARK mode in effect. Analyze all pragmas in specific
15546 Analyze_If_Present
(Pragma_SPARK_Mode
);
15548 -- Examine the formals of the related subprogram
15550 Formal
:= First_Formal
(Spec_Id
);
15551 while Present
(Formal
) loop
15553 -- At least one of the formals is of a specific tagged type,
15554 -- the pragma is legal.
15556 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15557 Has_OK_Formal
:= True;
15560 -- A generic subprogram with at least one formal of a private
15561 -- type ensures the legality of the pragma because the actual
15562 -- may be specifically tagged. Note that this is verified by
15563 -- the check above at instantiation time.
15565 elsif Is_Private_Type
(Etype
(Formal
))
15566 and then Is_Generic_Type
(Etype
(Formal
))
15568 Has_OK_Formal
:= True;
15572 Next_Formal
(Formal
);
15575 if not Has_OK_Formal
then
15576 Error_Msg_Name_1
:= Pname
;
15577 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15579 ("\subprogram & lacks parameter of specific tagged or "
15580 & "generic private type", N
, Spec_Id
);
15585 -- Analyze the Boolean expression (if any)
15587 if Present
(Arg1
) then
15588 Check_Static_Boolean_Expression
15589 (Expression
(Get_Argument
(N
, Spec_Id
)));
15591 end Extensions_Visible
;
15597 -- pragma External (
15598 -- [ Convention =>] convention_IDENTIFIER,
15599 -- [ Entity =>] LOCAL_NAME
15600 -- [, [External_Name =>] static_string_EXPRESSION ]
15601 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15603 when Pragma_External
=> External
: declare
15606 pragma Warnings
(Off
, C
);
15613 Name_External_Name
,
15615 Check_At_Least_N_Arguments
(2);
15616 Check_At_Most_N_Arguments
(4);
15617 Process_Convention
(C
, E
);
15619 -- A pragma that applies to a Ghost entity becomes Ghost for the
15620 -- purposes of legality checks and removal of ignored Ghost code.
15622 Mark_Ghost_Pragma
(N
, E
);
15624 Note_Possible_Modification
15625 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15626 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
15627 Set_Exported
(E
, Arg2
);
15630 --------------------------
15631 -- External_Name_Casing --
15632 --------------------------
15634 -- pragma External_Name_Casing (
15635 -- UPPERCASE | LOWERCASE
15636 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15638 when Pragma_External_Name_Casing
=>
15640 Check_No_Identifiers
;
15642 if Arg_Count
= 2 then
15643 Check_Arg_Is_One_Of
15644 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15646 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15648 Opt
.External_Name_Exp_Casing
:= As_Is
;
15650 when Name_Uppercase
=>
15651 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15653 when Name_Lowercase
=>
15654 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15661 Check_Arg_Count
(1);
15664 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15666 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15667 when Name_Uppercase
=>
15668 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15670 when Name_Lowercase
=>
15671 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15681 -- pragma Fast_Math;
15683 when Pragma_Fast_Math
=>
15685 Check_No_Identifiers
;
15686 Check_Valid_Configuration_Pragma
;
15689 --------------------------
15690 -- Favor_Top_Level --
15691 --------------------------
15693 -- pragma Favor_Top_Level (type_NAME);
15695 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15700 Check_No_Identifiers
;
15701 Check_Arg_Count
(1);
15702 Check_Arg_Is_Local_Name
(Arg1
);
15703 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15705 -- A pragma that applies to a Ghost entity becomes Ghost for the
15706 -- purposes of legality checks and removal of ignored Ghost code.
15708 Mark_Ghost_Pragma
(N
, Typ
);
15710 -- If it's an access-to-subprogram type (in particular, not a
15711 -- subtype), set the flag on that type.
15713 if Is_Access_Subprogram_Type
(Typ
) then
15714 Set_Can_Use_Internal_Rep
(Typ
, False);
15716 -- Otherwise it's an error (name denotes the wrong sort of entity)
15720 ("access-to-subprogram type expected",
15721 Get_Pragma_Arg
(Arg1
));
15723 end Favor_Top_Level
;
15725 ---------------------------
15726 -- Finalize_Storage_Only --
15727 ---------------------------
15729 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15731 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15732 Assoc
: constant Node_Id
:= Arg1
;
15733 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15738 Check_No_Identifiers
;
15739 Check_Arg_Count
(1);
15740 Check_Arg_Is_Local_Name
(Arg1
);
15742 Find_Type
(Type_Id
);
15743 Typ
:= Entity
(Type_Id
);
15746 or else Rep_Item_Too_Early
(Typ
, N
)
15750 Typ
:= Underlying_Type
(Typ
);
15753 if not Is_Controlled
(Typ
) then
15754 Error_Pragma
("pragma% must specify controlled type");
15757 Check_First_Subtype
(Arg1
);
15759 if Finalize_Storage_Only
(Typ
) then
15760 Error_Pragma
("duplicate pragma%, only one allowed");
15762 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15763 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15765 end Finalize_Storage
;
15771 -- pragma Ghost [ (boolean_EXPRESSION) ];
15773 when Pragma_Ghost
=> Ghost
: declare
15777 Orig_Stmt
: Node_Id
;
15778 Prev_Id
: Entity_Id
;
15783 Check_No_Identifiers
;
15784 Check_At_Most_N_Arguments
(1);
15788 while Present
(Stmt
) loop
15790 -- Skip prior pragmas, but check for duplicates
15792 if Nkind
(Stmt
) = N_Pragma
then
15793 if Pragma_Name
(Stmt
) = Pname
then
15800 -- Task unit declared without a definition cannot be subject to
15801 -- pragma Ghost (SPARK RM 6.9(19)).
15803 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15804 N_Task_Type_Declaration
)
15806 Error_Pragma
("pragma % cannot apply to a task type");
15809 -- Skip internally generated code
15811 elsif not Comes_From_Source
(Stmt
) then
15812 Orig_Stmt
:= Original_Node
(Stmt
);
15814 -- When pragma Ghost applies to an untagged derivation, the
15815 -- derivation is transformed into a [sub]type declaration.
15817 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15818 N_Subtype_Declaration
)
15819 and then Comes_From_Source
(Orig_Stmt
)
15820 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15821 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15822 N_Derived_Type_Definition
15824 Id
:= Defining_Entity
(Stmt
);
15827 -- When pragma Ghost applies to an object declaration which
15828 -- is initialized by means of a function call that returns
15829 -- on the secondary stack, the object declaration becomes a
15832 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
15833 and then Comes_From_Source
(Orig_Stmt
)
15834 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
15836 Id
:= Defining_Entity
(Stmt
);
15839 -- When pragma Ghost applies to an expression function, the
15840 -- expression function is transformed into a subprogram.
15842 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
15843 and then Comes_From_Source
(Orig_Stmt
)
15844 and then Nkind
(Orig_Stmt
) = N_Expression_Function
15846 Id
:= Defining_Entity
(Stmt
);
15850 -- The pragma applies to a legal construct, stop the traversal
15852 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
15853 N_Full_Type_Declaration
,
15854 N_Generic_Subprogram_Declaration
,
15855 N_Object_Declaration
,
15856 N_Private_Extension_Declaration
,
15857 N_Private_Type_Declaration
,
15858 N_Subprogram_Declaration
,
15859 N_Subtype_Declaration
)
15861 Id
:= Defining_Entity
(Stmt
);
15864 -- The pragma does not apply to a legal construct, issue an
15865 -- error and stop the analysis.
15869 ("pragma % must apply to an object, package, subprogram "
15874 Stmt
:= Prev
(Stmt
);
15877 Context
:= Parent
(N
);
15879 -- Handle compilation units
15881 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
15882 Context
:= Unit
(Parent
(Context
));
15885 -- Protected and task types cannot be subject to pragma Ghost
15886 -- (SPARK RM 6.9(19)).
15888 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
15890 Error_Pragma
("pragma % cannot apply to a protected type");
15893 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
15894 Error_Pragma
("pragma % cannot apply to a task type");
15900 -- When pragma Ghost is associated with a [generic] package, it
15901 -- appears in the visible declarations.
15903 if Nkind
(Context
) = N_Package_Specification
15904 and then Present
(Visible_Declarations
(Context
))
15905 and then List_Containing
(N
) = Visible_Declarations
(Context
)
15907 Id
:= Defining_Entity
(Context
);
15909 -- Pragma Ghost applies to a stand alone subprogram body
15911 elsif Nkind
(Context
) = N_Subprogram_Body
15912 and then No
(Corresponding_Spec
(Context
))
15914 Id
:= Defining_Entity
(Context
);
15916 -- Pragma Ghost applies to a subprogram declaration that acts
15917 -- as a compilation unit.
15919 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
15920 Id
:= Defining_Entity
(Context
);
15922 -- Pragma Ghost applies to a generic subprogram
15924 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
15925 Id
:= Defining_Entity
(Specification
(Context
));
15931 ("pragma % must apply to an object, package, subprogram or "
15936 -- Handle completions of types and constants that are subject to
15939 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
15940 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
15942 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
15943 Error_Msg_Name_1
:= Pname
;
15945 -- The full declaration of a deferred constant cannot be
15946 -- subject to pragma Ghost unless the deferred declaration
15947 -- is also Ghost (SPARK RM 6.9(9)).
15949 if Ekind
(Prev_Id
) = E_Constant
then
15950 Error_Msg_Name_1
:= Pname
;
15951 Error_Msg_NE
(Fix_Error
15952 ("pragma % must apply to declaration of deferred "
15953 & "constant &"), N
, Id
);
15956 -- Pragma Ghost may appear on the full view of an incomplete
15957 -- type because the incomplete declaration lacks aspects and
15958 -- cannot be subject to pragma Ghost.
15960 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
15963 -- The full declaration of a type cannot be subject to
15964 -- pragma Ghost unless the partial view is also Ghost
15965 -- (SPARK RM 6.9(9)).
15968 Error_Msg_NE
(Fix_Error
15969 ("pragma % must apply to partial view of type &"),
15975 -- A synchronized object cannot be subject to pragma Ghost
15976 -- (SPARK RM 6.9(19)).
15978 elsif Ekind
(Id
) = E_Variable
then
15979 if Is_Protected_Type
(Etype
(Id
)) then
15980 Error_Pragma
("pragma % cannot apply to a protected object");
15983 elsif Is_Task_Type
(Etype
(Id
)) then
15984 Error_Pragma
("pragma % cannot apply to a task object");
15989 -- Analyze the Boolean expression (if any)
15991 if Present
(Arg1
) then
15992 Expr
:= Get_Pragma_Arg
(Arg1
);
15994 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
15996 if Is_OK_Static_Expression
(Expr
) then
15998 -- "Ghostness" cannot be turned off once enabled within a
15999 -- region (SPARK RM 6.9(6)).
16001 if Is_False
(Expr_Value
(Expr
))
16002 and then Ghost_Mode
> None
16005 ("pragma % with value False cannot appear in enabled "
16010 -- Otherwie the expression is not static
16014 ("expression of pragma % must be static", Expr
);
16019 Set_Is_Ghost_Entity
(Id
);
16026 -- pragma Global (GLOBAL_SPECIFICATION);
16028 -- GLOBAL_SPECIFICATION ::=
16031 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16033 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16035 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16036 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16037 -- GLOBAL_ITEM ::= NAME
16039 -- Characteristics:
16041 -- * Analysis - The annotation undergoes initial checks to verify
16042 -- the legal placement and context. Secondary checks fully analyze
16043 -- the dependency clauses in:
16045 -- Analyze_Global_In_Decl_Part
16047 -- * Expansion - None.
16049 -- * Template - The annotation utilizes the generic template of the
16050 -- related subprogram [body] when it is:
16052 -- aspect on subprogram declaration
16053 -- aspect on stand alone subprogram body
16054 -- pragma on stand alone subprogram body
16056 -- The annotation must prepare its own template when it is:
16058 -- pragma on subprogram declaration
16060 -- * Globals - Capture of global references must occur after full
16063 -- * Instance - The annotation is instantiated automatically when
16064 -- the related generic subprogram [body] is instantiated except for
16065 -- the "pragma on subprogram declaration" case. In that scenario
16066 -- the annotation must instantiate itself.
16068 when Pragma_Global
=> Global
: declare
16070 Spec_Id
: Entity_Id
;
16071 Subp_Decl
: Node_Id
;
16074 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16078 -- Chain the pragma on the contract for further processing by
16079 -- Analyze_Global_In_Decl_Part.
16081 Add_Contract_Item
(N
, Spec_Id
);
16083 -- Fully analyze the pragma when it appears inside an entry
16084 -- or subprogram body because it cannot benefit from forward
16087 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
16089 N_Subprogram_Body_Stub
)
16091 -- The legality checks of pragmas Depends and Global are
16092 -- affected by the SPARK mode in effect and the volatility
16093 -- of the context. In addition these two pragmas are subject
16094 -- to an inherent order:
16099 -- Analyze all these pragmas in the order outlined above
16101 Analyze_If_Present
(Pragma_SPARK_Mode
);
16102 Analyze_If_Present
(Pragma_Volatile_Function
);
16103 Analyze_Global_In_Decl_Part
(N
);
16104 Analyze_If_Present
(Pragma_Depends
);
16113 -- pragma Ident (static_string_EXPRESSION)
16115 -- Note: pragma Comment shares this processing. Pragma Ident is
16116 -- identical in effect to pragma Commment.
16118 when Pragma_Comment
16126 Check_Arg_Count
(1);
16127 Check_No_Identifiers
;
16128 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16131 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
16138 GP
:= Parent
(Parent
(N
));
16140 if Nkind_In
(GP
, N_Package_Declaration
,
16141 N_Generic_Package_Declaration
)
16146 -- If we have a compilation unit, then record the ident value,
16147 -- checking for improper duplication.
16149 if Nkind
(GP
) = N_Compilation_Unit
then
16150 CS
:= Ident_String
(Current_Sem_Unit
);
16152 if Present
(CS
) then
16154 -- If we have multiple instances, concatenate them, but
16155 -- not in ASIS, where we want the original tree.
16157 if not ASIS_Mode
then
16158 Start_String
(Strval
(CS
));
16159 Store_String_Char
(' ');
16160 Store_String_Chars
(Strval
(Str
));
16161 Set_Strval
(CS
, End_String
);
16165 Set_Ident_String
(Current_Sem_Unit
, Str
);
16168 -- For subunits, we just ignore the Ident, since in GNAT these
16169 -- are not separate object files, and hence not separate units
16170 -- in the unit table.
16172 elsif Nkind
(GP
) = N_Subunit
then
16178 -------------------
16179 -- Ignore_Pragma --
16180 -------------------
16182 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16184 -- Entirely handled in the parser, nothing to do here
16186 when Pragma_Ignore_Pragma
=>
16189 ----------------------------
16190 -- Implementation_Defined --
16191 ----------------------------
16193 -- pragma Implementation_Defined (LOCAL_NAME);
16195 -- Marks previously declared entity as implementation defined. For
16196 -- an overloaded entity, applies to the most recent homonym.
16198 -- pragma Implementation_Defined;
16200 -- The form with no arguments appears anywhere within a scope, most
16201 -- typically a package spec, and indicates that all entities that are
16202 -- defined within the package spec are Implementation_Defined.
16204 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
16209 Check_No_Identifiers
;
16211 -- Form with no arguments
16213 if Arg_Count
= 0 then
16214 Set_Is_Implementation_Defined
(Current_Scope
);
16216 -- Form with one argument
16219 Check_Arg_Count
(1);
16220 Check_Arg_Is_Local_Name
(Arg1
);
16221 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
16222 Set_Is_Implementation_Defined
(Ent
);
16224 end Implementation_Defined
;
16230 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
16232 -- IMPLEMENTATION_KIND ::=
16233 -- By_Entry | By_Protected_Procedure | By_Any | Optional
16235 -- "By_Any" and "Optional" are treated as synonyms in order to
16236 -- support Ada 2012 aspect Synchronization.
16238 when Pragma_Implemented
=> Implemented
: declare
16239 Proc_Id
: Entity_Id
;
16244 Check_Arg_Count
(2);
16245 Check_No_Identifiers
;
16246 Check_Arg_Is_Identifier
(Arg1
);
16247 Check_Arg_Is_Local_Name
(Arg1
);
16248 Check_Arg_Is_One_Of
(Arg2
,
16251 Name_By_Protected_Procedure
,
16254 -- Extract the name of the local procedure
16256 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16258 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16259 -- primitive procedure of a synchronized tagged type.
16261 if Ekind
(Proc_Id
) = E_Procedure
16262 and then Is_Primitive
(Proc_Id
)
16263 and then Present
(First_Formal
(Proc_Id
))
16265 Typ
:= Etype
(First_Formal
(Proc_Id
));
16267 if Is_Tagged_Type
(Typ
)
16270 -- Check for a protected, a synchronized or a task interface
16272 ((Is_Interface
(Typ
)
16273 and then Is_Synchronized_Interface
(Typ
))
16275 -- Check for a protected type or a task type that implements
16279 (Is_Concurrent_Record_Type
(Typ
)
16280 and then Present
(Interfaces
(Typ
)))
16282 -- In analysis-only mode, examine original protected type
16285 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
16286 and then Present
(Interface_List
(Parent
(Typ
))))
16288 -- Check for a private record extension with keyword
16292 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
16293 E_Record_Subtype_With_Private
)
16294 and then Synchronized_Present
(Parent
(Typ
))))
16299 ("controlling formal must be of synchronized tagged type",
16304 -- Procedures declared inside a protected type must be accepted
16306 elsif Ekind
(Proc_Id
) = E_Procedure
16307 and then Is_Protected_Type
(Scope
(Proc_Id
))
16311 -- The first argument is not a primitive procedure
16315 ("pragma % must be applied to a primitive procedure", Arg1
);
16319 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16320 -- By_Protected_Procedure to the primitive procedure of a task
16323 if Chars
(Arg2
) = Name_By_Protected_Procedure
16324 and then Is_Interface
(Typ
)
16325 and then Is_Task_Interface
(Typ
)
16328 ("implementation kind By_Protected_Procedure cannot be "
16329 & "applied to a task interface primitive", Arg2
);
16333 Record_Rep_Item
(Proc_Id
, N
);
16336 ----------------------
16337 -- Implicit_Packing --
16338 ----------------------
16340 -- pragma Implicit_Packing;
16342 when Pragma_Implicit_Packing
=>
16344 Check_Arg_Count
(0);
16345 Implicit_Packing
:= True;
16352 -- [Convention =>] convention_IDENTIFIER,
16353 -- [Entity =>] LOCAL_NAME
16354 -- [, [External_Name =>] static_string_EXPRESSION ]
16355 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16357 when Pragma_Import
=>
16358 Check_Ada_83_Warning
;
16362 Name_External_Name
,
16365 Check_At_Least_N_Arguments
(2);
16366 Check_At_Most_N_Arguments
(4);
16367 Process_Import_Or_Interface
;
16369 ---------------------
16370 -- Import_Function --
16371 ---------------------
16373 -- pragma Import_Function (
16374 -- [Internal =>] LOCAL_NAME,
16375 -- [, [External =>] EXTERNAL_SYMBOL]
16376 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16377 -- [, [Result_Type =>] SUBTYPE_MARK]
16378 -- [, [Mechanism =>] MECHANISM]
16379 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16381 -- EXTERNAL_SYMBOL ::=
16383 -- | static_string_EXPRESSION
16385 -- PARAMETER_TYPES ::=
16387 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16389 -- TYPE_DESIGNATOR ::=
16391 -- | subtype_Name ' Access
16395 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16397 -- MECHANISM_ASSOCIATION ::=
16398 -- [formal_parameter_NAME =>] MECHANISM_NAME
16400 -- MECHANISM_NAME ::=
16404 when Pragma_Import_Function
=> Import_Function
: declare
16405 Args
: Args_List
(1 .. 6);
16406 Names
: constant Name_List
(1 .. 6) := (
16409 Name_Parameter_Types
,
16412 Name_Result_Mechanism
);
16414 Internal
: Node_Id
renames Args
(1);
16415 External
: Node_Id
renames Args
(2);
16416 Parameter_Types
: Node_Id
renames Args
(3);
16417 Result_Type
: Node_Id
renames Args
(4);
16418 Mechanism
: Node_Id
renames Args
(5);
16419 Result_Mechanism
: Node_Id
renames Args
(6);
16423 Gather_Associations
(Names
, Args
);
16424 Process_Extended_Import_Export_Subprogram_Pragma
(
16425 Arg_Internal
=> Internal
,
16426 Arg_External
=> External
,
16427 Arg_Parameter_Types
=> Parameter_Types
,
16428 Arg_Result_Type
=> Result_Type
,
16429 Arg_Mechanism
=> Mechanism
,
16430 Arg_Result_Mechanism
=> Result_Mechanism
);
16431 end Import_Function
;
16433 -------------------
16434 -- Import_Object --
16435 -------------------
16437 -- pragma Import_Object (
16438 -- [Internal =>] LOCAL_NAME
16439 -- [, [External =>] EXTERNAL_SYMBOL]
16440 -- [, [Size =>] EXTERNAL_SYMBOL]);
16442 -- EXTERNAL_SYMBOL ::=
16444 -- | static_string_EXPRESSION
16446 when Pragma_Import_Object
=> Import_Object
: declare
16447 Args
: Args_List
(1 .. 3);
16448 Names
: constant Name_List
(1 .. 3) := (
16453 Internal
: Node_Id
renames Args
(1);
16454 External
: Node_Id
renames Args
(2);
16455 Size
: Node_Id
renames Args
(3);
16459 Gather_Associations
(Names
, Args
);
16460 Process_Extended_Import_Export_Object_Pragma
(
16461 Arg_Internal
=> Internal
,
16462 Arg_External
=> External
,
16466 ----------------------
16467 -- Import_Procedure --
16468 ----------------------
16470 -- pragma Import_Procedure (
16471 -- [Internal =>] LOCAL_NAME
16472 -- [, [External =>] EXTERNAL_SYMBOL]
16473 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16474 -- [, [Mechanism =>] MECHANISM]);
16476 -- EXTERNAL_SYMBOL ::=
16478 -- | static_string_EXPRESSION
16480 -- PARAMETER_TYPES ::=
16482 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16484 -- TYPE_DESIGNATOR ::=
16486 -- | subtype_Name ' Access
16490 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16492 -- MECHANISM_ASSOCIATION ::=
16493 -- [formal_parameter_NAME =>] MECHANISM_NAME
16495 -- MECHANISM_NAME ::=
16499 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16500 Args
: Args_List
(1 .. 4);
16501 Names
: constant Name_List
(1 .. 4) := (
16504 Name_Parameter_Types
,
16507 Internal
: Node_Id
renames Args
(1);
16508 External
: Node_Id
renames Args
(2);
16509 Parameter_Types
: Node_Id
renames Args
(3);
16510 Mechanism
: Node_Id
renames Args
(4);
16514 Gather_Associations
(Names
, Args
);
16515 Process_Extended_Import_Export_Subprogram_Pragma
(
16516 Arg_Internal
=> Internal
,
16517 Arg_External
=> External
,
16518 Arg_Parameter_Types
=> Parameter_Types
,
16519 Arg_Mechanism
=> Mechanism
);
16520 end Import_Procedure
;
16522 -----------------------------
16523 -- Import_Valued_Procedure --
16524 -----------------------------
16526 -- pragma Import_Valued_Procedure (
16527 -- [Internal =>] LOCAL_NAME
16528 -- [, [External =>] EXTERNAL_SYMBOL]
16529 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16530 -- [, [Mechanism =>] MECHANISM]);
16532 -- EXTERNAL_SYMBOL ::=
16534 -- | static_string_EXPRESSION
16536 -- PARAMETER_TYPES ::=
16538 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16540 -- TYPE_DESIGNATOR ::=
16542 -- | subtype_Name ' Access
16546 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16548 -- MECHANISM_ASSOCIATION ::=
16549 -- [formal_parameter_NAME =>] MECHANISM_NAME
16551 -- MECHANISM_NAME ::=
16555 when Pragma_Import_Valued_Procedure
=>
16556 Import_Valued_Procedure
: declare
16557 Args
: Args_List
(1 .. 4);
16558 Names
: constant Name_List
(1 .. 4) := (
16561 Name_Parameter_Types
,
16564 Internal
: Node_Id
renames Args
(1);
16565 External
: Node_Id
renames Args
(2);
16566 Parameter_Types
: Node_Id
renames Args
(3);
16567 Mechanism
: Node_Id
renames Args
(4);
16571 Gather_Associations
(Names
, Args
);
16572 Process_Extended_Import_Export_Subprogram_Pragma
(
16573 Arg_Internal
=> Internal
,
16574 Arg_External
=> External
,
16575 Arg_Parameter_Types
=> Parameter_Types
,
16576 Arg_Mechanism
=> Mechanism
);
16577 end Import_Valued_Procedure
;
16583 -- pragma Independent (LOCAL_NAME);
16585 when Pragma_Independent
=>
16586 Process_Atomic_Independent_Shared_Volatile
;
16588 ----------------------------
16589 -- Independent_Components --
16590 ----------------------------
16592 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16594 when Pragma_Independent_Components
=> Independent_Components
: declare
16602 Check_Ada_83_Warning
;
16604 Check_No_Identifiers
;
16605 Check_Arg_Count
(1);
16606 Check_Arg_Is_Local_Name
(Arg1
);
16607 E_Id
:= Get_Pragma_Arg
(Arg1
);
16609 if Etype
(E_Id
) = Any_Type
then
16613 E
:= Entity
(E_Id
);
16615 -- A pragma that applies to a Ghost entity becomes Ghost for the
16616 -- purposes of legality checks and removal of ignored Ghost code.
16618 Mark_Ghost_Pragma
(N
, E
);
16620 -- Check duplicate before we chain ourselves
16622 Check_Duplicate_Pragma
(E
);
16624 -- Check appropriate entity
16626 if Rep_Item_Too_Early
(E
, N
)
16628 Rep_Item_Too_Late
(E
, N
)
16633 D
:= Declaration_Node
(E
);
16636 -- The flag is set on the base type, or on the object
16638 if K
= N_Full_Type_Declaration
16639 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16641 Set_Has_Independent_Components
(Base_Type
(E
));
16642 Record_Independence_Check
(N
, Base_Type
(E
));
16644 -- For record type, set all components independent
16646 if Is_Record_Type
(E
) then
16647 C
:= First_Component
(E
);
16648 while Present
(C
) loop
16649 Set_Is_Independent
(C
);
16650 Next_Component
(C
);
16654 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16655 and then Nkind
(D
) = N_Object_Declaration
16656 and then Nkind
(Object_Definition
(D
)) =
16657 N_Constrained_Array_Definition
16659 Set_Has_Independent_Components
(E
);
16660 Record_Independence_Check
(N
, E
);
16663 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16665 end Independent_Components
;
16667 -----------------------
16668 -- Initial_Condition --
16669 -----------------------
16671 -- pragma Initial_Condition (boolean_EXPRESSION);
16673 -- Characteristics:
16675 -- * Analysis - The annotation undergoes initial checks to verify
16676 -- the legal placement and context. Secondary checks preanalyze the
16679 -- Analyze_Initial_Condition_In_Decl_Part
16681 -- * Expansion - The annotation is expanded during the expansion of
16682 -- the package body whose declaration is subject to the annotation
16685 -- Expand_Pragma_Initial_Condition
16687 -- * Template - The annotation utilizes the generic template of the
16688 -- related package declaration.
16690 -- * Globals - Capture of global references must occur after full
16693 -- * Instance - The annotation is instantiated automatically when
16694 -- the related generic package is instantiated.
16696 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16697 Pack_Decl
: Node_Id
;
16698 Pack_Id
: Entity_Id
;
16702 Check_No_Identifiers
;
16703 Check_Arg_Count
(1);
16705 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16707 -- Ensure the proper placement of the pragma. Initial_Condition
16708 -- must be associated with a package declaration.
16710 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16711 N_Package_Declaration
)
16715 -- Otherwise the pragma is associated with an illegal context
16722 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16724 -- A pragma that applies to a Ghost entity becomes Ghost for the
16725 -- purposes of legality checks and removal of ignored Ghost code.
16727 Mark_Ghost_Pragma
(N
, Pack_Id
);
16729 -- Chain the pragma on the contract for further processing by
16730 -- Analyze_Initial_Condition_In_Decl_Part.
16732 Add_Contract_Item
(N
, Pack_Id
);
16734 -- The legality checks of pragmas Abstract_State, Initializes, and
16735 -- Initial_Condition are affected by the SPARK mode in effect. In
16736 -- addition, these three pragmas are subject to an inherent order:
16738 -- 1) Abstract_State
16740 -- 3) Initial_Condition
16742 -- Analyze all these pragmas in the order outlined above
16744 Analyze_If_Present
(Pragma_SPARK_Mode
);
16745 Analyze_If_Present
(Pragma_Abstract_State
);
16746 Analyze_If_Present
(Pragma_Initializes
);
16747 end Initial_Condition
;
16749 ------------------------
16750 -- Initialize_Scalars --
16751 ------------------------
16753 -- pragma Initialize_Scalars;
16755 when Pragma_Initialize_Scalars
=>
16757 Check_Arg_Count
(0);
16758 Check_Valid_Configuration_Pragma
;
16759 Check_Restriction
(No_Initialize_Scalars
, N
);
16761 -- Initialize_Scalars creates false positives in CodePeer, and
16762 -- incorrect negative results in GNATprove mode, so ignore this
16763 -- pragma in these modes.
16765 if not Restriction_Active
(No_Initialize_Scalars
)
16766 and then not (CodePeer_Mode
or GNATprove_Mode
)
16768 Init_Or_Norm_Scalars
:= True;
16769 Initialize_Scalars
:= True;
16776 -- pragma Initializes (INITIALIZATION_LIST);
16778 -- INITIALIZATION_LIST ::=
16780 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16782 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16787 -- | (INPUT {, INPUT})
16791 -- Characteristics:
16793 -- * Analysis - The annotation undergoes initial checks to verify
16794 -- the legal placement and context. Secondary checks preanalyze the
16797 -- Analyze_Initializes_In_Decl_Part
16799 -- * Expansion - None.
16801 -- * Template - The annotation utilizes the generic template of the
16802 -- related package declaration.
16804 -- * Globals - Capture of global references must occur after full
16807 -- * Instance - The annotation is instantiated automatically when
16808 -- the related generic package is instantiated.
16810 when Pragma_Initializes
=> Initializes
: declare
16811 Pack_Decl
: Node_Id
;
16812 Pack_Id
: Entity_Id
;
16816 Check_No_Identifiers
;
16817 Check_Arg_Count
(1);
16819 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16821 -- Ensure the proper placement of the pragma. Initializes must be
16822 -- associated with a package declaration.
16824 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16825 N_Package_Declaration
)
16829 -- Otherwise the pragma is associated with an illegal construc
16836 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16838 -- A pragma that applies to a Ghost entity becomes Ghost for the
16839 -- purposes of legality checks and removal of ignored Ghost code.
16841 Mark_Ghost_Pragma
(N
, Pack_Id
);
16842 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
16844 -- Chain the pragma on the contract for further processing by
16845 -- Analyze_Initializes_In_Decl_Part.
16847 Add_Contract_Item
(N
, Pack_Id
);
16849 -- The legality checks of pragmas Abstract_State, Initializes, and
16850 -- Initial_Condition are affected by the SPARK mode in effect. In
16851 -- addition, these three pragmas are subject to an inherent order:
16853 -- 1) Abstract_State
16855 -- 3) Initial_Condition
16857 -- Analyze all these pragmas in the order outlined above
16859 Analyze_If_Present
(Pragma_SPARK_Mode
);
16860 Analyze_If_Present
(Pragma_Abstract_State
);
16861 Analyze_If_Present
(Pragma_Initial_Condition
);
16868 -- pragma Inline ( NAME {, NAME} );
16870 when Pragma_Inline
=>
16872 -- Pragma always active unless in GNATprove mode. It is disabled
16873 -- in GNATprove mode because frontend inlining is applied
16874 -- independently of pragmas Inline and Inline_Always for
16875 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16878 if not GNATprove_Mode
then
16880 -- Inline status is Enabled if option -gnatn is specified.
16881 -- However this status determines only the value of the
16882 -- Is_Inlined flag on the subprogram and does not prevent
16883 -- the pragma itself from being recorded for later use,
16884 -- in particular for a later modification of Is_Inlined
16885 -- independently of the -gnatn option.
16887 -- In other words, if -gnatn is specified for a unit, then
16888 -- all Inline pragmas processed for the compilation of this
16889 -- unit, including those in the spec of other units, are
16890 -- activated, so subprograms will be inlined across units.
16892 -- If -gnatn is not specified, no Inline pragma is activated
16893 -- here, which means that subprograms will not be inlined
16894 -- across units. The Is_Inlined flag will nevertheless be
16895 -- set later when bodies are analyzed, so subprograms will
16896 -- be inlined within the unit.
16898 if Inline_Active
then
16899 Process_Inline
(Enabled
);
16901 Process_Inline
(Disabled
);
16905 -------------------
16906 -- Inline_Always --
16907 -------------------
16909 -- pragma Inline_Always ( NAME {, NAME} );
16911 when Pragma_Inline_Always
=>
16914 -- Pragma always active unless in CodePeer mode or GNATprove
16915 -- mode. It is disabled in CodePeer mode because inlining is
16916 -- not helpful, and enabling it caused walk order issues. It
16917 -- is disabled in GNATprove mode because frontend inlining is
16918 -- applied independently of pragmas Inline and Inline_Always for
16919 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16922 if not CodePeer_Mode
and not GNATprove_Mode
then
16923 Process_Inline
(Enabled
);
16926 --------------------
16927 -- Inline_Generic --
16928 --------------------
16930 -- pragma Inline_Generic (NAME {, NAME});
16932 when Pragma_Inline_Generic
=>
16934 Process_Generic_List
;
16936 ----------------------
16937 -- Inspection_Point --
16938 ----------------------
16940 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16942 when Pragma_Inspection_Point
=> Inspection_Point
: declare
16949 if Arg_Count
> 0 then
16952 Exp
:= Get_Pragma_Arg
(Arg
);
16955 if not Is_Entity_Name
(Exp
)
16956 or else not Is_Object
(Entity
(Exp
))
16958 Error_Pragma_Arg
("object name required", Arg
);
16962 exit when No
(Arg
);
16965 end Inspection_Point
;
16971 -- pragma Interface (
16972 -- [ Convention =>] convention_IDENTIFIER,
16973 -- [ Entity =>] LOCAL_NAME
16974 -- [, [External_Name =>] static_string_EXPRESSION ]
16975 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16977 when Pragma_Interface
=>
16982 Name_External_Name
,
16984 Check_At_Least_N_Arguments
(2);
16985 Check_At_Most_N_Arguments
(4);
16986 Process_Import_Or_Interface
;
16988 -- In Ada 2005, the permission to use Interface (a reserved word)
16989 -- as a pragma name is considered an obsolescent feature, and this
16990 -- pragma was already obsolescent in Ada 95.
16992 if Ada_Version
>= Ada_95
then
16994 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16996 if Warn_On_Obsolescent_Feature
then
16998 ("pragma Interface is an obsolescent feature?j?", N
);
17000 ("|use pragma Import instead?j?", N
);
17004 --------------------
17005 -- Interface_Name --
17006 --------------------
17008 -- pragma Interface_Name (
17009 -- [ Entity =>] LOCAL_NAME
17010 -- [,[External_Name =>] static_string_EXPRESSION ]
17011 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17013 when Pragma_Interface_Name
=> Interface_Name
: declare
17015 Def_Id
: Entity_Id
;
17016 Hom_Id
: Entity_Id
;
17022 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
17023 Check_At_Least_N_Arguments
(2);
17024 Check_At_Most_N_Arguments
(3);
17025 Id
:= Get_Pragma_Arg
(Arg1
);
17028 -- This is obsolete from Ada 95 on, but it is an implementation
17029 -- defined pragma, so we do not consider that it violates the
17030 -- restriction (No_Obsolescent_Features).
17032 if Ada_Version
>= Ada_95
then
17033 if Warn_On_Obsolescent_Feature
then
17035 ("pragma Interface_Name is an obsolescent feature?j?", N
);
17037 ("|use pragma Import instead?j?", N
);
17041 if not Is_Entity_Name
(Id
) then
17043 ("first argument for pragma% must be entity name", Arg1
);
17044 elsif Etype
(Id
) = Any_Type
then
17047 Def_Id
:= Entity
(Id
);
17050 -- Special DEC-compatible processing for the object case, forces
17051 -- object to be imported.
17053 if Ekind
(Def_Id
) = E_Variable
then
17054 Kill_Size_Check_Code
(Def_Id
);
17055 Note_Possible_Modification
(Id
, Sure
=> False);
17057 -- Initialization is not allowed for imported variable
17059 if Present
(Expression
(Parent
(Def_Id
)))
17060 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
17062 Error_Msg_Sloc
:= Sloc
(Def_Id
);
17064 ("no initialization allowed for declaration of& #",
17068 -- For compatibility, support VADS usage of providing both
17069 -- pragmas Interface and Interface_Name to obtain the effect
17070 -- of a single Import pragma.
17072 if Is_Imported
(Def_Id
)
17073 and then Present
(First_Rep_Item
(Def_Id
))
17074 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
17075 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
17080 Set_Imported
(Def_Id
);
17083 Set_Is_Public
(Def_Id
);
17084 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17087 -- Otherwise must be subprogram
17089 elsif not Is_Subprogram
(Def_Id
) then
17091 ("argument of pragma% is not subprogram", Arg1
);
17094 Check_At_Most_N_Arguments
(3);
17098 -- Loop through homonyms
17101 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
17103 if Is_Imported
(Def_Id
) then
17104 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17108 exit when From_Aspect_Specification
(N
);
17109 Hom_Id
:= Homonym
(Hom_Id
);
17111 exit when No
(Hom_Id
)
17112 or else Scope
(Hom_Id
) /= Current_Scope
;
17117 ("argument of pragma% is not imported subprogram",
17121 end Interface_Name
;
17123 -----------------------
17124 -- Interrupt_Handler --
17125 -----------------------
17127 -- pragma Interrupt_Handler (handler_NAME);
17129 when Pragma_Interrupt_Handler
=>
17130 Check_Ada_83_Warning
;
17131 Check_Arg_Count
(1);
17132 Check_No_Identifiers
;
17134 if No_Run_Time_Mode
then
17135 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
17137 Check_Interrupt_Or_Attach_Handler
;
17138 Process_Interrupt_Or_Attach_Handler
;
17141 ------------------------
17142 -- Interrupt_Priority --
17143 ------------------------
17145 -- pragma Interrupt_Priority [(EXPRESSION)];
17147 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
17148 P
: constant Node_Id
:= Parent
(N
);
17153 Check_Ada_83_Warning
;
17155 if Arg_Count
/= 0 then
17156 Arg
:= Get_Pragma_Arg
(Arg1
);
17157 Check_Arg_Count
(1);
17158 Check_No_Identifiers
;
17160 -- The expression must be analyzed in the special manner
17161 -- described in "Handling of Default and Per-Object
17162 -- Expressions" in sem.ads.
17164 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
17167 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
17172 Ent
:= Defining_Identifier
(Parent
(P
));
17174 -- Check duplicate pragma before we chain the pragma in the Rep
17175 -- Item chain of Ent.
17177 Check_Duplicate_Pragma
(Ent
);
17178 Record_Rep_Item
(Ent
, N
);
17180 -- Check the No_Task_At_Interrupt_Priority restriction
17182 if Nkind
(P
) = N_Task_Definition
then
17183 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
17186 end Interrupt_Priority
;
17188 ---------------------
17189 -- Interrupt_State --
17190 ---------------------
17192 -- pragma Interrupt_State (
17193 -- [Name =>] INTERRUPT_ID,
17194 -- [State =>] INTERRUPT_STATE);
17196 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
17197 -- INTERRUPT_STATE => System | Runtime | User
17199 -- Note: if the interrupt id is given as an identifier, then it must
17200 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
17201 -- given as a static integer expression which must be in the range of
17202 -- Ada.Interrupts.Interrupt_ID.
17204 when Pragma_Interrupt_State
=> Interrupt_State
: declare
17205 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
17206 -- This is the entity Ada.Interrupts.Interrupt_ID;
17208 State_Type
: Character;
17209 -- Set to 's'/'r'/'u' for System/Runtime/User
17212 -- Index to entry in Interrupt_States table
17215 -- Value of interrupt
17217 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17218 -- The first argument to the pragma
17220 Int_Ent
: Entity_Id
;
17221 -- Interrupt entity in Ada.Interrupts.Names
17225 Check_Arg_Order
((Name_Name
, Name_State
));
17226 Check_Arg_Count
(2);
17228 Check_Optional_Identifier
(Arg1
, Name_Name
);
17229 Check_Optional_Identifier
(Arg2
, Name_State
);
17230 Check_Arg_Is_Identifier
(Arg2
);
17232 -- First argument is identifier
17234 if Nkind
(Arg1X
) = N_Identifier
then
17236 -- Search list of names in Ada.Interrupts.Names
17238 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
17240 if No
(Int_Ent
) then
17241 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
17243 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
17244 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
17248 Next_Entity
(Int_Ent
);
17251 -- First argument is not an identifier, so it must be a static
17252 -- expression of type Ada.Interrupts.Interrupt_ID.
17255 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
17256 Int_Val
:= Expr_Value
(Arg1X
);
17258 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
17260 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
17263 ("value not in range of type "
17264 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
17270 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17271 when Name_Runtime
=> State_Type
:= 'r';
17272 when Name_System
=> State_Type
:= 's';
17273 when Name_User
=> State_Type
:= 'u';
17276 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
17279 -- Check if entry is already stored
17281 IST_Num
:= Interrupt_States
.First
;
17283 -- If entry not found, add it
17285 if IST_Num
> Interrupt_States
.Last
then
17286 Interrupt_States
.Append
17287 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
17288 Interrupt_State
=> State_Type
,
17289 Pragma_Loc
=> Loc
));
17292 -- Case of entry for the same entry
17294 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
17297 -- If state matches, done, no need to make redundant entry
17300 State_Type
= Interrupt_States
.Table
(IST_Num
).
17303 -- Otherwise if state does not match, error
17306 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
17308 ("state conflicts with that given #", Arg2
);
17312 IST_Num
:= IST_Num
+ 1;
17314 end Interrupt_State
;
17320 -- pragma Invariant
17321 -- ([Entity =>] type_LOCAL_NAME,
17322 -- [Check =>] EXPRESSION
17323 -- [,[Message =>] String_Expression]);
17325 when Pragma_Invariant
=> Invariant
: declare
17332 Check_At_Least_N_Arguments
(2);
17333 Check_At_Most_N_Arguments
(3);
17334 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17335 Check_Optional_Identifier
(Arg2
, Name_Check
);
17337 if Arg_Count
= 3 then
17338 Check_Optional_Identifier
(Arg3
, Name_Message
);
17339 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
17342 Check_Arg_Is_Local_Name
(Arg1
);
17344 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
17345 Find_Type
(Typ_Arg
);
17346 Typ
:= Entity
(Typ_Arg
);
17348 -- Nothing to do of the related type is erroneous in some way
17350 if Typ
= Any_Type
then
17353 -- AI12-0041: Invariants are allowed in interface types
17355 elsif Is_Interface
(Typ
) then
17358 -- An invariant must apply to a private type, or appear in the
17359 -- private part of a package spec and apply to a completion.
17360 -- a class-wide invariant can only appear on a private declaration
17361 -- or private extension, not a completion.
17363 -- A [class-wide] invariant may be associated a [limited] private
17364 -- type or a private extension.
17366 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
17368 E_Record_Type_With_Private
)
17372 -- A non-class-wide invariant may be associated with the full view
17373 -- of a [limited] private type or a private extension.
17375 elsif Has_Private_Declaration
(Typ
)
17376 and then not Class_Present
(N
)
17380 -- A class-wide invariant may appear on the partial view only
17382 elsif Class_Present
(N
) then
17384 ("pragma % only allowed for private type", Arg1
);
17387 -- A regular invariant may appear on both views
17391 ("pragma % only allowed for private type or corresponding "
17392 & "full view", Arg1
);
17396 -- An invariant associated with an abstract type (this includes
17397 -- interfaces) must be class-wide.
17399 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
17401 ("pragma % not allowed for abstract type", Arg1
);
17405 -- A pragma that applies to a Ghost entity becomes Ghost for the
17406 -- purposes of legality checks and removal of ignored Ghost code.
17408 Mark_Ghost_Pragma
(N
, Typ
);
17410 -- The pragma defines a type-specific invariant, the type is said
17411 -- to have invariants of its "own".
17413 Set_Has_Own_Invariants
(Typ
);
17415 -- If the invariant is class-wide, then it can be inherited by
17416 -- derived or interface implementing types. The type is said to
17417 -- have "inheritable" invariants.
17419 if Class_Present
(N
) then
17420 Set_Has_Inheritable_Invariants
(Typ
);
17423 -- Chain the pragma on to the rep item chain, for processing when
17424 -- the type is frozen.
17426 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17428 -- Create the declaration of the invariant procedure that will
17429 -- verify the invariant at run time. Interfaces are treated as the
17430 -- partial view of a private type in order to achieve uniformity
17431 -- with the general case. As a result, an interface receives only
17432 -- a "partial" invariant procedure, which is never called.
17434 Build_Invariant_Procedure_Declaration
17436 Partial_Invariant
=> Is_Interface
(Typ
));
17443 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17445 when Pragma_Keep_Names
=> Keep_Names
: declare
17450 Check_Arg_Count
(1);
17451 Check_Optional_Identifier
(Arg1
, Name_On
);
17452 Check_Arg_Is_Local_Name
(Arg1
);
17454 Arg
:= Get_Pragma_Arg
(Arg1
);
17457 if Etype
(Arg
) = Any_Type
then
17461 if not Is_Entity_Name
(Arg
)
17462 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
17465 ("pragma% requires a local enumeration type", Arg1
);
17468 Set_Discard_Names
(Entity
(Arg
), False);
17475 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17477 when Pragma_License
=>
17480 -- Do not analyze pragma any further in CodePeer mode, to avoid
17481 -- extraneous errors in this implementation-dependent pragma,
17482 -- which has a different profile on other compilers.
17484 if CodePeer_Mode
then
17488 Check_Arg_Count
(1);
17489 Check_No_Identifiers
;
17490 Check_Valid_Configuration_Pragma
;
17491 Check_Arg_Is_Identifier
(Arg1
);
17494 Sind
: constant Source_File_Index
:=
17495 Source_Index
(Current_Sem_Unit
);
17498 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17500 Set_License
(Sind
, GPL
);
17502 when Name_Modified_GPL
=>
17503 Set_License
(Sind
, Modified_GPL
);
17505 when Name_Restricted
=>
17506 Set_License
(Sind
, Restricted
);
17508 when Name_Unrestricted
=>
17509 Set_License
(Sind
, Unrestricted
);
17512 Error_Pragma_Arg
("invalid license name", Arg1
);
17520 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17522 when Pragma_Link_With
=> Link_With
: declare
17528 if Operating_Mode
= Generate_Code
17529 and then In_Extended_Main_Source_Unit
(N
)
17531 Check_At_Least_N_Arguments
(1);
17532 Check_No_Identifiers
;
17533 Check_Is_In_Decl_Part_Or_Package_Spec
;
17534 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17538 while Present
(Arg
) loop
17539 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17541 -- Store argument, converting sequences of spaces to a
17542 -- single null character (this is one of the differences
17543 -- in processing between Link_With and Linker_Options).
17545 Arg_Store
: declare
17546 C
: constant Char_Code
:= Get_Char_Code
(' ');
17547 S
: constant String_Id
:=
17548 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17549 L
: constant Nat
:= String_Length
(S
);
17552 procedure Skip_Spaces
;
17553 -- Advance F past any spaces
17559 procedure Skip_Spaces
is
17561 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17566 -- Start of processing for Arg_Store
17569 Skip_Spaces
; -- skip leading spaces
17571 -- Loop through characters, changing any embedded
17572 -- sequence of spaces to a single null character (this
17573 -- is how Link_With/Linker_Options differ)
17576 if Get_String_Char
(S
, F
) = C
then
17579 Store_String_Char
(ASCII
.NUL
);
17582 Store_String_Char
(Get_String_Char
(S
, F
));
17590 if Present
(Arg
) then
17591 Store_String_Char
(ASCII
.NUL
);
17595 Store_Linker_Option_String
(End_String
);
17603 -- pragma Linker_Alias (
17604 -- [Entity =>] LOCAL_NAME
17605 -- [Target =>] static_string_EXPRESSION);
17607 when Pragma_Linker_Alias
=>
17609 Check_Arg_Order
((Name_Entity
, Name_Target
));
17610 Check_Arg_Count
(2);
17611 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17612 Check_Optional_Identifier
(Arg2
, Name_Target
);
17613 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17614 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17616 -- The only processing required is to link this item on to the
17617 -- list of rep items for the given entity. This is accomplished
17618 -- by the call to Rep_Item_Too_Late (when no error is detected
17619 -- and False is returned).
17621 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17624 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17627 ------------------------
17628 -- Linker_Constructor --
17629 ------------------------
17631 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17633 -- Code is shared with Linker_Destructor
17635 -----------------------
17636 -- Linker_Destructor --
17637 -----------------------
17639 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17641 when Pragma_Linker_Constructor
17642 | Pragma_Linker_Destructor
17644 Linker_Constructor
: declare
17650 Check_Arg_Count
(1);
17651 Check_No_Identifiers
;
17652 Check_Arg_Is_Local_Name
(Arg1
);
17653 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17655 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17657 if not Is_Library_Level_Entity
(Proc
) then
17659 ("argument for pragma% must be library level entity", Arg1
);
17662 -- The only processing required is to link this item on to the
17663 -- list of rep items for the given entity. This is accomplished
17664 -- by the call to Rep_Item_Too_Late (when no error is detected
17665 -- and False is returned).
17667 if Rep_Item_Too_Late
(Proc
, N
) then
17670 Set_Has_Gigi_Rep_Item
(Proc
);
17672 end Linker_Constructor
;
17674 --------------------
17675 -- Linker_Options --
17676 --------------------
17678 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17680 when Pragma_Linker_Options
=> Linker_Options
: declare
17684 Check_Ada_83_Warning
;
17685 Check_No_Identifiers
;
17686 Check_Arg_Count
(1);
17687 Check_Is_In_Decl_Part_Or_Package_Spec
;
17688 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17689 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17692 while Present
(Arg
) loop
17693 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17694 Store_String_Char
(ASCII
.NUL
);
17696 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17700 if Operating_Mode
= Generate_Code
17701 and then In_Extended_Main_Source_Unit
(N
)
17703 Store_Linker_Option_String
(End_String
);
17705 end Linker_Options
;
17707 --------------------
17708 -- Linker_Section --
17709 --------------------
17711 -- pragma Linker_Section (
17712 -- [Entity =>] LOCAL_NAME
17713 -- [Section =>] static_string_EXPRESSION);
17715 when Pragma_Linker_Section
=> Linker_Section
: declare
17720 Ghost_Error_Posted
: Boolean := False;
17721 -- Flag set when an error concerning the illegal mix of Ghost and
17722 -- non-Ghost subprograms is emitted.
17724 Ghost_Id
: Entity_Id
:= Empty
;
17725 -- The entity of the first Ghost subprogram encountered while
17726 -- processing the arguments of the pragma.
17730 Check_Arg_Order
((Name_Entity
, Name_Section
));
17731 Check_Arg_Count
(2);
17732 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17733 Check_Optional_Identifier
(Arg2
, Name_Section
);
17734 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17735 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17737 -- Check kind of entity
17739 Arg
:= Get_Pragma_Arg
(Arg1
);
17740 Ent
:= Entity
(Arg
);
17742 case Ekind
(Ent
) is
17744 -- Objects (constants and variables) and types. For these cases
17745 -- all we need to do is to set the Linker_Section_pragma field,
17746 -- checking that we do not have a duplicate.
17752 LPE
:= Linker_Section_Pragma
(Ent
);
17754 if Present
(LPE
) then
17755 Error_Msg_Sloc
:= Sloc
(LPE
);
17757 ("Linker_Section already specified for &#", Arg1
, Ent
);
17760 Set_Linker_Section_Pragma
(Ent
, N
);
17762 -- A pragma that applies to a Ghost entity becomes Ghost for
17763 -- the purposes of legality checks and removal of ignored
17766 Mark_Ghost_Pragma
(N
, Ent
);
17770 when Subprogram_Kind
=>
17772 -- Aspect case, entity already set
17774 if From_Aspect_Specification
(N
) then
17775 Set_Linker_Section_Pragma
17776 (Entity
(Corresponding_Aspect
(N
)), N
);
17778 -- Pragma case, we must climb the homonym chain, but skip
17779 -- any for which the linker section is already set.
17783 if No
(Linker_Section_Pragma
(Ent
)) then
17784 Set_Linker_Section_Pragma
(Ent
, N
);
17786 -- A pragma that applies to a Ghost entity becomes
17787 -- Ghost for the purposes of legality checks and
17788 -- removal of ignored Ghost code.
17790 Mark_Ghost_Pragma
(N
, Ent
);
17792 -- Capture the entity of the first Ghost subprogram
17793 -- being processed for error detection purposes.
17795 if Is_Ghost_Entity
(Ent
) then
17796 if No
(Ghost_Id
) then
17800 -- Otherwise the subprogram is non-Ghost. It is
17801 -- illegal to mix references to Ghost and non-Ghost
17802 -- entities (SPARK RM 6.9).
17804 elsif Present
(Ghost_Id
)
17805 and then not Ghost_Error_Posted
17807 Ghost_Error_Posted
:= True;
17809 Error_Msg_Name_1
:= Pname
;
17811 ("pragma % cannot mention ghost and "
17812 & "non-ghost subprograms", N
);
17814 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17816 ("\& # declared as ghost", N
, Ghost_Id
);
17818 Error_Msg_Sloc
:= Sloc
(Ent
);
17820 ("\& # declared as non-ghost", N
, Ent
);
17824 Ent
:= Homonym
(Ent
);
17826 or else Scope
(Ent
) /= Current_Scope
;
17830 -- All other cases are illegal
17834 ("pragma% applies only to objects, subprograms, and types",
17837 end Linker_Section
;
17843 -- pragma List (On | Off)
17845 -- There is nothing to do here, since we did all the processing for
17846 -- this pragma in Par.Prag (so that it works properly even in syntax
17849 when Pragma_List
=>
17856 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17858 when Pragma_Lock_Free
=> Lock_Free
: declare
17859 P
: constant Node_Id
:= Parent
(N
);
17865 Check_No_Identifiers
;
17866 Check_At_Most_N_Arguments
(1);
17868 -- Protected definition case
17870 if Nkind
(P
) = N_Protected_Definition
then
17871 Ent
:= Defining_Identifier
(Parent
(P
));
17875 if Arg_Count
= 1 then
17876 Arg
:= Get_Pragma_Arg
(Arg1
);
17877 Val
:= Is_True
(Static_Boolean
(Arg
));
17879 -- No arguments (expression is considered to be True)
17885 -- Check duplicate pragma before we chain the pragma in the Rep
17886 -- Item chain of Ent.
17888 Check_Duplicate_Pragma
(Ent
);
17889 Record_Rep_Item
(Ent
, N
);
17890 Set_Uses_Lock_Free
(Ent
, Val
);
17892 -- Anything else is incorrect placement
17899 --------------------
17900 -- Locking_Policy --
17901 --------------------
17903 -- pragma Locking_Policy (policy_IDENTIFIER);
17905 when Pragma_Locking_Policy
=> declare
17906 subtype LP_Range
is Name_Id
17907 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
17912 Check_Ada_83_Warning
;
17913 Check_Arg_Count
(1);
17914 Check_No_Identifiers
;
17915 Check_Arg_Is_Locking_Policy
(Arg1
);
17916 Check_Valid_Configuration_Pragma
;
17917 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17920 when Name_Ceiling_Locking
=> LP
:= 'C';
17921 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
17922 when Name_Inheritance_Locking
=> LP
:= 'I';
17925 if Locking_Policy
/= ' '
17926 and then Locking_Policy
/= LP
17928 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17929 Error_Pragma
("locking policy incompatible with policy#");
17931 -- Set new policy, but always preserve System_Location since we
17932 -- like the error message with the run time name.
17935 Locking_Policy
:= LP
;
17937 if Locking_Policy_Sloc
/= System_Location
then
17938 Locking_Policy_Sloc
:= Loc
;
17943 -------------------
17944 -- Loop_Optimize --
17945 -------------------
17947 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17949 -- OPTIMIZATION_HINT ::=
17950 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17952 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
17957 Check_At_Least_N_Arguments
(1);
17958 Check_No_Identifiers
;
17960 Hint
:= First
(Pragma_Argument_Associations
(N
));
17961 while Present
(Hint
) loop
17962 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
17970 Check_Loop_Pragma_Placement
;
17977 -- pragma Loop_Variant
17978 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17980 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17982 -- CHANGE_DIRECTION ::= Increases | Decreases
17984 when Pragma_Loop_Variant
=> Loop_Variant
: declare
17989 Check_At_Least_N_Arguments
(1);
17990 Check_Loop_Pragma_Placement
;
17992 -- Process all increasing / decreasing expressions
17994 Variant
:= First
(Pragma_Argument_Associations
(N
));
17995 while Present
(Variant
) loop
17996 if Chars
(Variant
) = No_Name
then
17997 Error_Pragma_Arg
("expect name `Increases`", Variant
);
17999 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
18003 Name
: String := Get_Name_String
(Chars
(Variant
));
18006 -- It is a common mistake to write "Increasing" for
18007 -- "Increases" or "Decreasing" for "Decreases". Recognize
18008 -- specially names starting with "incr" or "decr" to
18009 -- suggest the corresponding name.
18011 System
.Case_Util
.To_Lower
(Name
);
18013 if Name
'Length >= 4
18014 and then Name
(1 .. 4) = "incr"
18016 Error_Pragma_Arg_Ident
18017 ("expect name `Increases`", Variant
);
18019 elsif Name
'Length >= 4
18020 and then Name
(1 .. 4) = "decr"
18022 Error_Pragma_Arg_Ident
18023 ("expect name `Decreases`", Variant
);
18026 Error_Pragma_Arg_Ident
18027 ("expect name `Increases` or `Decreases`", Variant
);
18032 Preanalyze_Assert_Expression
18033 (Expression
(Variant
), Any_Discrete
);
18039 -----------------------
18040 -- Machine_Attribute --
18041 -----------------------
18043 -- pragma Machine_Attribute (
18044 -- [Entity =>] LOCAL_NAME,
18045 -- [Attribute_Name =>] static_string_EXPRESSION
18046 -- [, [Info =>] static_EXPRESSION] );
18048 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
18049 Def_Id
: Entity_Id
;
18053 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
18055 if Arg_Count
= 3 then
18056 Check_Optional_Identifier
(Arg3
, Name_Info
);
18057 Check_Arg_Is_OK_Static_Expression
(Arg3
);
18059 Check_Arg_Count
(2);
18062 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18063 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
18064 Check_Arg_Is_Local_Name
(Arg1
);
18065 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18066 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18068 if Is_Access_Type
(Def_Id
) then
18069 Def_Id
:= Designated_Type
(Def_Id
);
18072 if Rep_Item_Too_Early
(Def_Id
, N
) then
18076 Def_Id
:= Underlying_Type
(Def_Id
);
18078 -- The only processing required is to link this item on to the
18079 -- list of rep items for the given entity. This is accomplished
18080 -- by the call to Rep_Item_Too_Late (when no error is detected
18081 -- and False is returned).
18083 if Rep_Item_Too_Late
(Def_Id
, N
) then
18086 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18088 end Machine_Attribute
;
18095 -- (MAIN_OPTION [, MAIN_OPTION]);
18098 -- [STACK_SIZE =>] static_integer_EXPRESSION
18099 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
18100 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
18102 when Pragma_Main
=> Main
: declare
18103 Args
: Args_List
(1 .. 3);
18104 Names
: constant Name_List
(1 .. 3) := (
18106 Name_Task_Stack_Size_Default
,
18107 Name_Time_Slicing_Enabled
);
18113 Gather_Associations
(Names
, Args
);
18115 for J
in 1 .. 2 loop
18116 if Present
(Args
(J
)) then
18117 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18121 if Present
(Args
(3)) then
18122 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
18126 while Present
(Nod
) loop
18127 if Nkind
(Nod
) = N_Pragma
18128 and then Pragma_Name
(Nod
) = Name_Main
18130 Error_Msg_Name_1
:= Pname
;
18131 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18142 -- pragma Main_Storage
18143 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
18145 -- MAIN_STORAGE_OPTION ::=
18146 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
18147 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
18149 when Pragma_Main_Storage
=> Main_Storage
: declare
18150 Args
: Args_List
(1 .. 2);
18151 Names
: constant Name_List
(1 .. 2) := (
18152 Name_Working_Storage
,
18159 Gather_Associations
(Names
, Args
);
18161 for J
in 1 .. 2 loop
18162 if Present
(Args
(J
)) then
18163 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18167 Check_In_Main_Program
;
18170 while Present
(Nod
) loop
18171 if Nkind
(Nod
) = N_Pragma
18172 and then Pragma_Name
(Nod
) = Name_Main_Storage
18174 Error_Msg_Name_1
:= Pname
;
18175 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18182 ----------------------
18183 -- Max_Queue_Length --
18184 ----------------------
18186 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
18188 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
18190 Entry_Decl
: Node_Id
;
18191 Entry_Id
: Entity_Id
;
18196 Check_Arg_Count
(1);
18199 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
18201 -- Entry declaration
18203 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
18205 -- Entry illegally within a task
18207 if Nkind
(Parent
(N
)) = N_Task_Definition
then
18208 Error_Pragma
("pragma % cannot apply to task entries");
18212 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
18214 -- Otherwise the pragma is associated with an illegal construct
18217 Error_Pragma
("pragma % must apply to a protected entry");
18221 -- Mark the pragma as Ghost if the related subprogram is also
18222 -- Ghost. This also ensures that any expansion performed further
18223 -- below will produce Ghost nodes.
18225 Mark_Ghost_Pragma
(N
, Entry_Id
);
18227 -- Analyze the Integer expression
18229 Arg
:= Get_Pragma_Arg
(Arg1
);
18230 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
18232 Val
:= Expr_Value
(Arg
);
18236 ("argument for pragma% must be positive", Arg1
);
18238 elsif not UI_Is_In_Int_Range
(Val
) then
18240 ("argument for pragma% out of range of Integer", Arg1
);
18244 -- Manually substitute the expression value of the pragma argument
18245 -- if it's not an integer literal because this is not taken care
18246 -- of automatically elsewhere.
18248 if Nkind
(Arg
) /= N_Integer_Literal
then
18249 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
18252 Record_Rep_Item
(Entry_Id
, N
);
18253 end Max_Queue_Length
;
18259 -- pragma Memory_Size (NUMERIC_LITERAL)
18261 when Pragma_Memory_Size
=>
18264 -- Memory size is simply ignored
18266 Check_No_Identifiers
;
18267 Check_Arg_Count
(1);
18268 Check_Arg_Is_Integer_Literal
(Arg1
);
18276 -- The only correct use of this pragma is on its own in a file, in
18277 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
18278 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
18279 -- check for a file containing nothing but a No_Body pragma). If we
18280 -- attempt to process it during normal semantics processing, it means
18281 -- it was misplaced.
18283 when Pragma_No_Body
=>
18287 -----------------------------
18288 -- No_Elaboration_Code_All --
18289 -----------------------------
18291 -- pragma No_Elaboration_Code_All;
18293 when Pragma_No_Elaboration_Code_All
=>
18295 Check_Valid_Library_Unit_Pragma
;
18297 if Nkind
(N
) = N_Null_Statement
then
18301 -- Must appear for a spec or generic spec
18303 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
18304 N_Generic_Package_Declaration
,
18305 N_Generic_Subprogram_Declaration
,
18306 N_Package_Declaration
,
18307 N_Subprogram_Declaration
)
18311 ("pragma% can only occur for package "
18312 & "or subprogram spec"));
18315 -- Set flag in unit table
18317 Set_No_Elab_Code_All
(Current_Sem_Unit
);
18319 -- Set restriction No_Elaboration_Code if this is the main unit
18321 if Current_Sem_Unit
= Main_Unit
then
18322 Set_Restriction
(No_Elaboration_Code
, N
);
18325 -- If we are in the main unit or in an extended main source unit,
18326 -- then we also add it to the configuration restrictions so that
18327 -- it will apply to all units in the extended main source.
18329 if Current_Sem_Unit
= Main_Unit
18330 or else In_Extended_Main_Source_Unit
(N
)
18332 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
18335 -- If in main extended unit, activate transitive with test
18337 if In_Extended_Main_Source_Unit
(N
) then
18338 Opt
.No_Elab_Code_All_Pragma
:= N
;
18341 -----------------------------
18342 -- No_Component_Reordering --
18343 -----------------------------
18345 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
18347 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
18353 Check_At_Most_N_Arguments
(1);
18355 if Arg_Count
= 0 then
18356 Check_Valid_Configuration_Pragma
;
18357 Opt
.No_Component_Reordering
:= True;
18360 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18361 Check_Arg_Is_Local_Name
(Arg1
);
18362 E_Id
:= Get_Pragma_Arg
(Arg1
);
18364 if Etype
(E_Id
) = Any_Type
then
18368 E
:= Entity
(E_Id
);
18370 if not Is_Record_Type
(E
) then
18371 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
18374 Set_No_Reordering
(Base_Type
(E
));
18376 end No_Comp_Reordering
;
18378 --------------------------
18379 -- No_Heap_Finalization --
18380 --------------------------
18382 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18384 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
18385 Context
: constant Node_Id
:= Parent
(N
);
18386 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18392 Check_No_Identifiers
;
18394 -- The pragma appears in a configuration file
18396 if No
(Context
) then
18397 Check_Arg_Count
(0);
18398 Check_Valid_Configuration_Pragma
;
18400 -- Detect a duplicate pragma
18402 if Present
(No_Heap_Finalization_Pragma
) then
18405 Prev
=> No_Heap_Finalization_Pragma
);
18409 No_Heap_Finalization_Pragma
:= N
;
18411 -- Otherwise the pragma should be associated with a library-level
18412 -- named access-to-object type.
18415 Check_Arg_Count
(1);
18416 Check_Arg_Is_Local_Name
(Arg1
);
18418 Find_Type
(Typ_Arg
);
18419 Typ
:= Entity
(Typ_Arg
);
18421 -- The type being subjected to the pragma is erroneous
18423 if Typ
= Any_Type
then
18424 Error_Pragma
("cannot find type referenced by pragma %");
18426 -- The pragma is applied to an incomplete or generic formal
18427 -- type way too early.
18429 elsif Rep_Item_Too_Early
(Typ
, N
) then
18433 Typ
:= Underlying_Type
(Typ
);
18436 -- The pragma must apply to an access-to-object type
18438 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
18441 -- Give a detailed error message on all other access type kinds
18443 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
18445 ("pragma % cannot apply to access protected subprogram "
18448 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
18450 ("pragma % cannot apply to access subprogram type");
18452 elsif Is_Anonymous_Access_Type
(Typ
) then
18454 ("pragma % cannot apply to anonymous access type");
18456 -- Give a general error message in case the pragma applies to a
18457 -- non-access type.
18461 ("pragma % must apply to library level access type");
18464 -- At this point the argument denotes an access-to-object type.
18465 -- Ensure that the type is declared at the library level.
18467 if Is_Library_Level_Entity
(Typ
) then
18470 -- Quietly ignore an access-to-object type originally declared
18471 -- at the library level within a generic, but instantiated at
18472 -- a non-library level. As a result the access-to-object type
18473 -- "loses" its No_Heap_Finalization property.
18475 elsif In_Instance
then
18480 ("pragma % must apply to library level access type");
18483 -- Detect a duplicate pragma
18485 if Present
(No_Heap_Finalization_Pragma
) then
18488 Prev
=> No_Heap_Finalization_Pragma
);
18492 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
18494 if Present
(Prev
) then
18502 Record_Rep_Item
(Typ
, N
);
18504 end No_Heap_Finalization
;
18510 -- pragma No_Inline ( NAME {, NAME} );
18512 when Pragma_No_Inline
=>
18514 Process_Inline
(Suppressed
);
18520 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18522 when Pragma_No_Return
=> No_Return
: declare
18528 Ghost_Error_Posted
: Boolean := False;
18529 -- Flag set when an error concerning the illegal mix of Ghost and
18530 -- non-Ghost subprograms is emitted.
18532 Ghost_Id
: Entity_Id
:= Empty
;
18533 -- The entity of the first Ghost procedure encountered while
18534 -- processing the arguments of the pragma.
18538 Check_At_Least_N_Arguments
(1);
18540 -- Loop through arguments of pragma
18543 while Present
(Arg
) loop
18544 Check_Arg_Is_Local_Name
(Arg
);
18545 Id
:= Get_Pragma_Arg
(Arg
);
18548 if not Is_Entity_Name
(Id
) then
18549 Error_Pragma_Arg
("entity name required", Arg
);
18552 if Etype
(Id
) = Any_Type
then
18556 -- Loop to find matching procedures
18562 and then Scope
(E
) = Current_Scope
18564 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
18566 -- Check that the pragma is not applied to a body.
18567 -- First check the specless body case, to give a
18568 -- different error message. These checks do not apply
18569 -- if Relaxed_RM_Semantics, to accommodate other Ada
18570 -- compilers. Disable these checks under -gnatd.J.
18572 if not Debug_Flag_Dot_JJ
then
18573 if Nkind
(Parent
(Declaration_Node
(E
))) =
18575 and then not Relaxed_RM_Semantics
18578 ("pragma% requires separate spec and must come "
18582 -- Now the "specful" body case
18584 if Rep_Item_Too_Late
(E
, N
) then
18591 -- A pragma that applies to a Ghost entity becomes Ghost
18592 -- for the purposes of legality checks and removal of
18593 -- ignored Ghost code.
18595 Mark_Ghost_Pragma
(N
, E
);
18597 -- Capture the entity of the first Ghost procedure being
18598 -- processed for error detection purposes.
18600 if Is_Ghost_Entity
(E
) then
18601 if No
(Ghost_Id
) then
18605 -- Otherwise the subprogram is non-Ghost. It is illegal
18606 -- to mix references to Ghost and non-Ghost entities
18609 elsif Present
(Ghost_Id
)
18610 and then not Ghost_Error_Posted
18612 Ghost_Error_Posted
:= True;
18614 Error_Msg_Name_1
:= Pname
;
18616 ("pragma % cannot mention ghost and non-ghost "
18617 & "procedures", N
);
18619 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18620 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
18622 Error_Msg_Sloc
:= Sloc
(E
);
18623 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
18626 -- Set flag on any alias as well
18628 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
18629 Set_No_Return
(Alias
(E
));
18635 exit when From_Aspect_Specification
(N
);
18639 -- If entity in not in current scope it may be the enclosing
18640 -- suprogram body to which the aspect applies.
18643 if Entity
(Id
) = Current_Scope
18644 and then From_Aspect_Specification
(N
)
18646 Set_No_Return
(Entity
(Id
));
18648 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
18660 -- pragma No_Run_Time;
18662 -- Note: this pragma is retained for backwards compatibility. See
18663 -- body of Rtsfind for full details on its handling.
18665 when Pragma_No_Run_Time
=>
18667 Check_Valid_Configuration_Pragma
;
18668 Check_Arg_Count
(0);
18670 -- Remove backward compatibility if Build_Type is FSF or GPL and
18671 -- generate a warning.
18674 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
18677 Error_Pragma
("pragma% is ignored, has no effect??");
18679 No_Run_Time_Mode
:= True;
18680 Configurable_Run_Time_Mode
:= True;
18682 -- Set Duration to 32 bits if word size is 32
18684 if Ttypes
.System_Word_Size
= 32 then
18685 Duration_32_Bits_On_Target
:= True;
18688 -- Set appropriate restrictions
18690 Set_Restriction
(No_Finalization
, N
);
18691 Set_Restriction
(No_Exception_Handlers
, N
);
18692 Set_Restriction
(Max_Tasks
, N
, 0);
18693 Set_Restriction
(No_Tasking
, N
);
18697 -----------------------
18698 -- No_Tagged_Streams --
18699 -----------------------
18701 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18703 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
18709 Check_At_Most_N_Arguments
(1);
18711 -- One argument case
18713 if Arg_Count
= 1 then
18714 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18715 Check_Arg_Is_Local_Name
(Arg1
);
18716 E_Id
:= Get_Pragma_Arg
(Arg1
);
18718 if Etype
(E_Id
) = Any_Type
then
18722 E
:= Entity
(E_Id
);
18724 Check_Duplicate_Pragma
(E
);
18726 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
18728 ("argument for pragma% must be root tagged type", Arg1
);
18731 if Rep_Item_Too_Early
(E
, N
)
18733 Rep_Item_Too_Late
(E
, N
)
18737 Set_No_Tagged_Streams_Pragma
(E
, N
);
18740 -- Zero argument case
18743 Check_Is_In_Decl_Part_Or_Package_Spec
;
18744 No_Tagged_Streams
:= N
;
18746 end No_Tagged_Strms
;
18748 ------------------------
18749 -- No_Strict_Aliasing --
18750 ------------------------
18752 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18754 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
18760 Check_At_Most_N_Arguments
(1);
18762 if Arg_Count
= 0 then
18763 Check_Valid_Configuration_Pragma
;
18764 Opt
.No_Strict_Aliasing
:= True;
18767 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18768 Check_Arg_Is_Local_Name
(Arg1
);
18769 E_Id
:= Get_Pragma_Arg
(Arg1
);
18771 if Etype
(E_Id
) = Any_Type
then
18775 E
:= Entity
(E_Id
);
18777 if not Is_Access_Type
(E
) then
18778 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
18781 Set_No_Strict_Aliasing
(Base_Type
(E
));
18783 end No_Strict_Aliasing
;
18785 -----------------------
18786 -- Normalize_Scalars --
18787 -----------------------
18789 -- pragma Normalize_Scalars;
18791 when Pragma_Normalize_Scalars
=>
18792 Check_Ada_83_Warning
;
18793 Check_Arg_Count
(0);
18794 Check_Valid_Configuration_Pragma
;
18796 -- Normalize_Scalars creates false positives in CodePeer, and
18797 -- incorrect negative results in GNATprove mode, so ignore this
18798 -- pragma in these modes.
18800 if not (CodePeer_Mode
or GNATprove_Mode
) then
18801 Normalize_Scalars
:= True;
18802 Init_Or_Norm_Scalars
:= True;
18809 -- pragma Obsolescent;
18811 -- pragma Obsolescent (
18812 -- [Message =>] static_string_EXPRESSION
18813 -- [,[Version =>] Ada_05]]);
18815 -- pragma Obsolescent (
18816 -- [Entity =>] NAME
18817 -- [,[Message =>] static_string_EXPRESSION
18818 -- [,[Version =>] Ada_05]] );
18820 when Pragma_Obsolescent
=> Obsolescent
: declare
18824 procedure Set_Obsolescent
(E
: Entity_Id
);
18825 -- Given an entity Ent, mark it as obsolescent if appropriate
18827 ---------------------
18828 -- Set_Obsolescent --
18829 ---------------------
18831 procedure Set_Obsolescent
(E
: Entity_Id
) is
18840 -- A pragma that applies to a Ghost entity becomes Ghost for
18841 -- the purposes of legality checks and removal of ignored Ghost
18844 Mark_Ghost_Pragma
(N
, E
);
18846 -- Entity name was given
18848 if Present
(Ename
) then
18850 -- If entity name matches, we are fine. Save entity in
18851 -- pragma argument, for ASIS use.
18853 if Chars
(Ename
) = Chars
(Ent
) then
18854 Set_Entity
(Ename
, Ent
);
18855 Generate_Reference
(Ent
, Ename
);
18857 -- If entity name does not match, only possibility is an
18858 -- enumeration literal from an enumeration type declaration.
18860 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
18862 ("pragma % entity name does not match declaration");
18865 Ent
:= First_Literal
(E
);
18869 ("pragma % entity name does not match any "
18870 & "enumeration literal");
18872 elsif Chars
(Ent
) = Chars
(Ename
) then
18873 Set_Entity
(Ename
, Ent
);
18874 Generate_Reference
(Ent
, Ename
);
18878 Ent
:= Next_Literal
(Ent
);
18884 -- Ent points to entity to be marked
18886 if Arg_Count
>= 1 then
18888 -- Deal with static string argument
18890 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18891 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
18893 for J
in 1 .. String_Length
(S
) loop
18894 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
18896 ("pragma% argument does not allow wide characters",
18901 Obsolescent_Warnings
.Append
18902 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
18904 -- Check for Ada_05 parameter
18906 if Arg_Count
/= 1 then
18907 Check_Arg_Count
(2);
18910 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
18913 Check_Arg_Is_Identifier
(Argx
);
18915 if Chars
(Argx
) /= Name_Ada_05
then
18916 Error_Msg_Name_2
:= Name_Ada_05
;
18918 ("only allowed argument for pragma% is %", Argx
);
18921 if Ada_Version_Explicit
< Ada_2005
18922 or else not Warn_On_Ada_2005_Compatibility
18930 -- Set flag if pragma active
18933 Set_Is_Obsolescent
(Ent
);
18937 end Set_Obsolescent
;
18939 -- Start of processing for pragma Obsolescent
18944 Check_At_Most_N_Arguments
(3);
18946 -- See if first argument specifies an entity name
18950 (Chars
(Arg1
) = Name_Entity
18952 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
18954 N_Operator_Symbol
))
18956 Ename
:= Get_Pragma_Arg
(Arg1
);
18958 -- Eliminate first argument, so we can share processing
18962 Arg_Count
:= Arg_Count
- 1;
18964 -- No Entity name argument given
18970 if Arg_Count
>= 1 then
18971 Check_Optional_Identifier
(Arg1
, Name_Message
);
18973 if Arg_Count
= 2 then
18974 Check_Optional_Identifier
(Arg2
, Name_Version
);
18978 -- Get immediately preceding declaration
18981 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
18985 -- Cases where we do not follow anything other than another pragma
18989 -- First case: library level compilation unit declaration with
18990 -- the pragma immediately following the declaration.
18992 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
18994 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
18997 -- Case 2: library unit placement for package
19001 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
19003 if Is_Package_Or_Generic_Package
(Ent
) then
19004 Set_Obsolescent
(Ent
);
19010 -- Cases where we must follow a declaration, including an
19011 -- abstract subprogram declaration, which is not in the
19012 -- other node subtypes.
19015 if Nkind
(Decl
) not in N_Declaration
19016 and then Nkind
(Decl
) not in N_Later_Decl_Item
19017 and then Nkind
(Decl
) not in N_Generic_Declaration
19018 and then Nkind
(Decl
) not in N_Renaming_Declaration
19019 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
19022 ("pragma% misplaced, "
19023 & "must immediately follow a declaration");
19026 Set_Obsolescent
(Defining_Entity
(Decl
));
19036 -- pragma Optimize (Time | Space | Off);
19038 -- The actual check for optimize is done in Gigi. Note that this
19039 -- pragma does not actually change the optimization setting, it
19040 -- simply checks that it is consistent with the pragma.
19042 when Pragma_Optimize
=>
19043 Check_No_Identifiers
;
19044 Check_Arg_Count
(1);
19045 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
19047 ------------------------
19048 -- Optimize_Alignment --
19049 ------------------------
19051 -- pragma Optimize_Alignment (Time | Space | Off);
19053 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
19055 Check_No_Identifiers
;
19056 Check_Arg_Count
(1);
19057 Check_Valid_Configuration_Pragma
;
19060 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
19063 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
19064 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
19065 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
19068 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
19072 -- Set indication that mode is set locally. If we are in fact in a
19073 -- configuration pragma file, this setting is harmless since the
19074 -- switch will get reset anyway at the start of each unit.
19076 Optimize_Alignment_Local
:= True;
19077 end Optimize_Alignment
;
19083 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
19085 when Pragma_Ordered
=> Ordered
: declare
19086 Assoc
: constant Node_Id
:= Arg1
;
19092 Check_No_Identifiers
;
19093 Check_Arg_Count
(1);
19094 Check_Arg_Is_Local_Name
(Arg1
);
19096 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19097 Find_Type
(Type_Id
);
19098 Typ
:= Entity
(Type_Id
);
19100 if Typ
= Any_Type
then
19103 Typ
:= Underlying_Type
(Typ
);
19106 if not Is_Enumeration_Type
(Typ
) then
19107 Error_Pragma
("pragma% must specify enumeration type");
19110 Check_First_Subtype
(Arg1
);
19111 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
19114 -------------------
19115 -- Overflow_Mode --
19116 -------------------
19118 -- pragma Overflow_Mode
19119 -- ([General => ] MODE [, [Assertions => ] MODE]);
19121 -- MODE := STRICT | MINIMIZED | ELIMINATED
19123 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
19124 -- since System.Bignums makes this assumption. This is true of nearly
19125 -- all (all?) targets.
19127 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
19128 function Get_Overflow_Mode
19130 Arg
: Node_Id
) return Overflow_Mode_Type
;
19131 -- Function to process one pragma argument, Arg. If an identifier
19132 -- is present, it must be Name. Mode type is returned if a valid
19133 -- argument exists, otherwise an error is signalled.
19135 -----------------------
19136 -- Get_Overflow_Mode --
19137 -----------------------
19139 function Get_Overflow_Mode
19141 Arg
: Node_Id
) return Overflow_Mode_Type
19143 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
19146 Check_Optional_Identifier
(Arg
, Name
);
19147 Check_Arg_Is_Identifier
(Argx
);
19149 if Chars
(Argx
) = Name_Strict
then
19152 elsif Chars
(Argx
) = Name_Minimized
then
19155 elsif Chars
(Argx
) = Name_Eliminated
then
19156 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
19158 ("Eliminated not implemented on this target", Argx
);
19164 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
19166 end Get_Overflow_Mode
;
19168 -- Start of processing for Overflow_Mode
19172 Check_At_Least_N_Arguments
(1);
19173 Check_At_Most_N_Arguments
(2);
19175 -- Process first argument
19177 Scope_Suppress
.Overflow_Mode_General
:=
19178 Get_Overflow_Mode
(Name_General
, Arg1
);
19180 -- Case of only one argument
19182 if Arg_Count
= 1 then
19183 Scope_Suppress
.Overflow_Mode_Assertions
:=
19184 Scope_Suppress
.Overflow_Mode_General
;
19186 -- Case of two arguments present
19189 Scope_Suppress
.Overflow_Mode_Assertions
:=
19190 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
19194 --------------------------
19195 -- Overriding Renamings --
19196 --------------------------
19198 -- pragma Overriding_Renamings;
19200 when Pragma_Overriding_Renamings
=>
19202 Check_Arg_Count
(0);
19203 Check_Valid_Configuration_Pragma
;
19204 Overriding_Renamings
:= True;
19210 -- pragma Pack (first_subtype_LOCAL_NAME);
19212 when Pragma_Pack
=> Pack
: declare
19213 Assoc
: constant Node_Id
:= Arg1
;
19215 Ignore
: Boolean := False;
19220 Check_No_Identifiers
;
19221 Check_Arg_Count
(1);
19222 Check_Arg_Is_Local_Name
(Arg1
);
19223 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19225 if not Is_Entity_Name
(Type_Id
)
19226 or else not Is_Type
(Entity
(Type_Id
))
19229 ("argument for pragma% must be type or subtype", Arg1
);
19232 Find_Type
(Type_Id
);
19233 Typ
:= Entity
(Type_Id
);
19236 or else Rep_Item_Too_Early
(Typ
, N
)
19240 Typ
:= Underlying_Type
(Typ
);
19243 -- A pragma that applies to a Ghost entity becomes Ghost for the
19244 -- purposes of legality checks and removal of ignored Ghost code.
19246 Mark_Ghost_Pragma
(N
, Typ
);
19248 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
19249 Error_Pragma
("pragma% must specify array or record type");
19252 Check_First_Subtype
(Arg1
);
19253 Check_Duplicate_Pragma
(Typ
);
19257 if Is_Array_Type
(Typ
) then
19258 Ctyp
:= Component_Type
(Typ
);
19260 -- Ignore pack that does nothing
19262 if Known_Static_Esize
(Ctyp
)
19263 and then Known_Static_RM_Size
(Ctyp
)
19264 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
19265 and then Addressable
(Esize
(Ctyp
))
19270 -- Process OK pragma Pack. Note that if there is a separate
19271 -- component clause present, the Pack will be cancelled. This
19272 -- processing is in Freeze.
19274 if not Rep_Item_Too_Late
(Typ
, N
) then
19276 -- In CodePeer mode, we do not need complex front-end
19277 -- expansions related to pragma Pack, so disable handling
19280 if CodePeer_Mode
then
19283 -- Normal case where we do the pack action
19287 Set_Is_Packed
(Base_Type
(Typ
));
19288 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19291 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19295 -- For record types, the pack is always effective
19297 else pragma Assert
(Is_Record_Type
(Typ
));
19298 if not Rep_Item_Too_Late
(Typ
, N
) then
19299 Set_Is_Packed
(Base_Type
(Typ
));
19300 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19301 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19312 -- There is nothing to do here, since we did all the processing for
19313 -- this pragma in Par.Prag (so that it works properly even in syntax
19316 when Pragma_Page
=>
19323 -- pragma Part_Of (ABSTRACT_STATE);
19325 -- ABSTRACT_STATE ::= NAME
19327 when Pragma_Part_Of
=> Part_Of
: declare
19328 procedure Propagate_Part_Of
19329 (Pack_Id
: Entity_Id
;
19330 State_Id
: Entity_Id
;
19331 Instance
: Node_Id
);
19332 -- Propagate the Part_Of indicator to all abstract states and
19333 -- objects declared in the visible state space of a package
19334 -- denoted by Pack_Id. State_Id is the encapsulating state.
19335 -- Instance is the package instantiation node.
19337 -----------------------
19338 -- Propagate_Part_Of --
19339 -----------------------
19341 procedure Propagate_Part_Of
19342 (Pack_Id
: Entity_Id
;
19343 State_Id
: Entity_Id
;
19344 Instance
: Node_Id
)
19346 Has_Item
: Boolean := False;
19347 -- Flag set when the visible state space contains at least one
19348 -- abstract state or variable.
19350 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
19351 -- Propagate the Part_Of indicator to all abstract states and
19352 -- objects declared in the visible state space of a package
19353 -- denoted by Pack_Id.
19355 -----------------------
19356 -- Propagate_Part_Of --
19357 -----------------------
19359 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
19360 Constits
: Elist_Id
;
19361 Item_Id
: Entity_Id
;
19364 -- Traverse the entity chain of the package and set relevant
19365 -- attributes of abstract states and objects declared in the
19366 -- visible state space of the package.
19368 Item_Id
:= First_Entity
(Pack_Id
);
19369 while Present
(Item_Id
)
19370 and then not In_Private_Part
(Item_Id
)
19372 -- Do not consider internally generated items
19374 if not Comes_From_Source
(Item_Id
) then
19377 -- The Part_Of indicator turns an abstract state or an
19378 -- object into a constituent of the encapsulating state.
19380 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
19385 Constits
:= Part_Of_Constituents
(State_Id
);
19387 if No
(Constits
) then
19388 Constits
:= New_Elmt_List
;
19389 Set_Part_Of_Constituents
(State_Id
, Constits
);
19392 Append_Elmt
(Item_Id
, Constits
);
19393 Set_Encapsulating_State
(Item_Id
, State_Id
);
19395 -- Recursively handle nested packages and instantiations
19397 elsif Ekind
(Item_Id
) = E_Package
then
19398 Propagate_Part_Of
(Item_Id
);
19401 Next_Entity
(Item_Id
);
19403 end Propagate_Part_Of
;
19405 -- Start of processing for Propagate_Part_Of
19408 Propagate_Part_Of
(Pack_Id
);
19410 -- Detect a package instantiation that is subject to a Part_Of
19411 -- indicator, but has no visible state.
19413 if not Has_Item
then
19415 ("package instantiation & has Part_Of indicator but "
19416 & "lacks visible state", Instance
, Pack_Id
);
19418 end Propagate_Part_Of
;
19422 Constits
: Elist_Id
;
19424 Encap_Id
: Entity_Id
;
19425 Item_Id
: Entity_Id
;
19429 -- Start of processing for Part_Of
19433 Check_No_Identifiers
;
19434 Check_Arg_Count
(1);
19436 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
19438 -- Object declaration
19440 if Nkind
(Stmt
) = N_Object_Declaration
then
19443 -- Package instantiation
19445 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
19448 -- Single concurrent type declaration
19450 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
19453 -- Otherwise the pragma is associated with an illegal construct
19460 -- Extract the entity of the related object declaration or package
19461 -- instantiation. In the case of the instantiation, use the entity
19462 -- of the instance spec.
19464 if Nkind
(Stmt
) = N_Package_Instantiation
then
19465 Stmt
:= Instance_Spec
(Stmt
);
19468 Item_Id
:= Defining_Entity
(Stmt
);
19470 -- A pragma that applies to a Ghost entity becomes Ghost for the
19471 -- purposes of legality checks and removal of ignored Ghost code.
19473 Mark_Ghost_Pragma
(N
, Item_Id
);
19475 -- Chain the pragma on the contract for further processing by
19476 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19478 Add_Contract_Item
(N
, Item_Id
);
19480 -- A variable may act as constituent of a single concurrent type
19481 -- which in turn could be declared after the variable. Due to this
19482 -- discrepancy, the full analysis of indicator Part_Of is delayed
19483 -- until the end of the enclosing declarative region (see routine
19484 -- Analyze_Part_Of_In_Decl_Part).
19486 if Ekind
(Item_Id
) = E_Variable
then
19489 -- Otherwise indicator Part_Of applies to a constant or a package
19493 Encap
:= Get_Pragma_Arg
(Arg1
);
19495 -- Detect any discrepancies between the placement of the
19496 -- constant or package instantiation with respect to state
19497 -- space and the encapsulating state.
19501 Item_Id
=> Item_Id
,
19503 Encap_Id
=> Encap_Id
,
19507 pragma Assert
(Present
(Encap_Id
));
19509 if Ekind
(Item_Id
) = E_Constant
then
19510 Constits
:= Part_Of_Constituents
(Encap_Id
);
19512 if No
(Constits
) then
19513 Constits
:= New_Elmt_List
;
19514 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
19517 Append_Elmt
(Item_Id
, Constits
);
19518 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
19520 -- Propagate the Part_Of indicator to the visible state
19521 -- space of the package instantiation.
19525 (Pack_Id
=> Item_Id
,
19526 State_Id
=> Encap_Id
,
19533 ----------------------------------
19534 -- Partition_Elaboration_Policy --
19535 ----------------------------------
19537 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19539 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
19540 subtype PEP_Range
is Name_Id
19541 range First_Partition_Elaboration_Policy_Name
19542 .. Last_Partition_Elaboration_Policy_Name
;
19543 PEP_Val
: PEP_Range
;
19548 Check_Arg_Count
(1);
19549 Check_No_Identifiers
;
19550 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
19551 Check_Valid_Configuration_Pragma
;
19552 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19555 when Name_Concurrent
=> PEP
:= 'C';
19556 when Name_Sequential
=> PEP
:= 'S';
19559 if Partition_Elaboration_Policy
/= ' '
19560 and then Partition_Elaboration_Policy
/= PEP
19562 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
19564 ("partition elaboration policy incompatible with policy#");
19566 -- Set new policy, but always preserve System_Location since we
19567 -- like the error message with the run time name.
19570 Partition_Elaboration_Policy
:= PEP
;
19572 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
19573 Partition_Elaboration_Policy_Sloc
:= Loc
;
19582 -- pragma Passive [(PASSIVE_FORM)];
19584 -- PASSIVE_FORM ::= Semaphore | No
19586 when Pragma_Passive
=>
19589 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
19590 Error_Pragma
("pragma% must be within task definition");
19593 if Arg_Count
/= 0 then
19594 Check_Arg_Count
(1);
19595 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
19598 ----------------------------------
19599 -- Preelaborable_Initialization --
19600 ----------------------------------
19602 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19604 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
19609 Check_Arg_Count
(1);
19610 Check_No_Identifiers
;
19611 Check_Arg_Is_Identifier
(Arg1
);
19612 Check_Arg_Is_Local_Name
(Arg1
);
19613 Check_First_Subtype
(Arg1
);
19614 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19616 -- A pragma that applies to a Ghost entity becomes Ghost for the
19617 -- purposes of legality checks and removal of ignored Ghost code.
19619 Mark_Ghost_Pragma
(N
, Ent
);
19621 -- The pragma may come from an aspect on a private declaration,
19622 -- even if the freeze point at which this is analyzed in the
19623 -- private part after the full view.
19625 if Has_Private_Declaration
(Ent
)
19626 and then From_Aspect_Specification
(N
)
19630 -- Check appropriate type argument
19632 elsif Is_Private_Type
(Ent
)
19633 or else Is_Protected_Type
(Ent
)
19634 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
19636 -- AI05-0028: The pragma applies to all composite types. Note
19637 -- that we apply this binding interpretation to earlier versions
19638 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19639 -- choice since there are other compilers that do the same.
19641 or else Is_Composite_Type
(Ent
)
19647 ("pragma % can only be applied to private, formal derived, "
19648 & "protected, or composite type", Arg1
);
19651 -- Give an error if the pragma is applied to a protected type that
19652 -- does not qualify (due to having entries, or due to components
19653 -- that do not qualify).
19655 if Is_Protected_Type
(Ent
)
19656 and then not Has_Preelaborable_Initialization
(Ent
)
19659 ("protected type & does not have preelaborable "
19660 & "initialization", Ent
);
19662 -- Otherwise mark the type as definitely having preelaborable
19666 Set_Known_To_Have_Preelab_Init
(Ent
);
19669 if Has_Pragma_Preelab_Init
(Ent
)
19670 and then Warn_On_Redundant_Constructs
19672 Error_Pragma
("?r?duplicate pragma%!");
19674 Set_Has_Pragma_Preelab_Init
(Ent
);
19678 --------------------
19679 -- Persistent_BSS --
19680 --------------------
19682 -- pragma Persistent_BSS [(object_NAME)];
19684 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
19691 Check_At_Most_N_Arguments
(1);
19693 -- Case of application to specific object (one argument)
19695 if Arg_Count
= 1 then
19696 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19698 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
19700 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
19703 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
19706 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19708 -- A pragma that applies to a Ghost entity becomes Ghost for
19709 -- the purposes of legality checks and removal of ignored Ghost
19712 Mark_Ghost_Pragma
(N
, Ent
);
19714 -- Check for duplication before inserting in list of
19715 -- representation items.
19717 Check_Duplicate_Pragma
(Ent
);
19719 if Rep_Item_Too_Late
(Ent
, N
) then
19723 Decl
:= Parent
(Ent
);
19725 if Present
(Expression
(Decl
)) then
19727 ("object for pragma% cannot have initialization", Arg1
);
19730 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
19732 ("object type for pragma% is not potentially persistent",
19737 Make_Linker_Section_Pragma
19738 (Ent
, Sloc
(N
), ".persistent.bss");
19739 Insert_After
(N
, Prag
);
19742 -- Case of use as configuration pragma with no arguments
19745 Check_Valid_Configuration_Pragma
;
19746 Persistent_BSS_Mode
:= True;
19748 end Persistent_BSS
;
19750 --------------------
19751 -- Rename_Pragma --
19752 --------------------
19754 -- pragma Rename_Pragma (
19755 -- [New_Name =>] IDENTIFIER,
19756 -- [Renamed =>] pragma_IDENTIFIER);
19758 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
19759 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19760 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19764 Check_Valid_Configuration_Pragma
;
19765 Check_Arg_Count
(2);
19766 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
19767 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
19769 if Nkind
(New_Name
) /= N_Identifier
then
19770 Error_Pragma_Arg
("identifier expected", Arg1
);
19773 if Nkind
(Old_Name
) /= N_Identifier
then
19774 Error_Pragma_Arg
("identifier expected", Arg2
);
19777 -- The New_Name arg should not be an existing pragma (but we allow
19778 -- it; it's just a warning). The Old_Name arg must be an existing
19781 if Is_Pragma_Name
(Chars
(New_Name
)) then
19782 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
19785 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
19786 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
19789 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
19796 -- pragma Polling (ON | OFF);
19798 when Pragma_Polling
=>
19800 Check_Arg_Count
(1);
19801 Check_No_Identifiers
;
19802 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19803 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
19805 -----------------------------------
19806 -- Post/Post_Class/Postcondition --
19807 -----------------------------------
19809 -- pragma Post (Boolean_EXPRESSION);
19810 -- pragma Post_Class (Boolean_EXPRESSION);
19811 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19812 -- [,[Message =>] String_EXPRESSION]);
19814 -- Characteristics:
19816 -- * Analysis - The annotation undergoes initial checks to verify
19817 -- the legal placement and context. Secondary checks preanalyze the
19820 -- Analyze_Pre_Post_Condition_In_Decl_Part
19822 -- * Expansion - The annotation is expanded during the expansion of
19823 -- the related subprogram [body] contract as performed in:
19825 -- Expand_Subprogram_Contract
19827 -- * Template - The annotation utilizes the generic template of the
19828 -- related subprogram [body] when it is:
19830 -- aspect on subprogram declaration
19831 -- aspect on stand alone subprogram body
19832 -- pragma on stand alone subprogram body
19834 -- The annotation must prepare its own template when it is:
19836 -- pragma on subprogram declaration
19838 -- * Globals - Capture of global references must occur after full
19841 -- * Instance - The annotation is instantiated automatically when
19842 -- the related generic subprogram [body] is instantiated except for
19843 -- the "pragma on subprogram declaration" case. In that scenario
19844 -- the annotation must instantiate itself.
19847 | Pragma_Post_Class
19848 | Pragma_Postcondition
19850 Analyze_Pre_Post_Condition
;
19852 --------------------------------
19853 -- Pre/Pre_Class/Precondition --
19854 --------------------------------
19856 -- pragma Pre (Boolean_EXPRESSION);
19857 -- pragma Pre_Class (Boolean_EXPRESSION);
19858 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19859 -- [,[Message =>] String_EXPRESSION]);
19861 -- Characteristics:
19863 -- * Analysis - The annotation undergoes initial checks to verify
19864 -- the legal placement and context. Secondary checks preanalyze the
19867 -- Analyze_Pre_Post_Condition_In_Decl_Part
19869 -- * Expansion - The annotation is expanded during the expansion of
19870 -- the related subprogram [body] contract as performed in:
19872 -- Expand_Subprogram_Contract
19874 -- * Template - The annotation utilizes the generic template of the
19875 -- related subprogram [body] when it is:
19877 -- aspect on subprogram declaration
19878 -- aspect on stand alone subprogram body
19879 -- pragma on stand alone subprogram body
19881 -- The annotation must prepare its own template when it is:
19883 -- pragma on subprogram declaration
19885 -- * Globals - Capture of global references must occur after full
19888 -- * Instance - The annotation is instantiated automatically when
19889 -- the related generic subprogram [body] is instantiated except for
19890 -- the "pragma on subprogram declaration" case. In that scenario
19891 -- the annotation must instantiate itself.
19895 | Pragma_Precondition
19897 Analyze_Pre_Post_Condition
;
19903 -- pragma Predicate
19904 -- ([Entity =>] type_LOCAL_NAME,
19905 -- [Check =>] boolean_EXPRESSION);
19907 when Pragma_Predicate
=> Predicate
: declare
19914 Check_Arg_Count
(2);
19915 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19916 Check_Optional_Identifier
(Arg2
, Name_Check
);
19918 Check_Arg_Is_Local_Name
(Arg1
);
19920 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19921 Find_Type
(Type_Id
);
19922 Typ
:= Entity
(Type_Id
);
19924 if Typ
= Any_Type
then
19928 -- A pragma that applies to a Ghost entity becomes Ghost for the
19929 -- purposes of legality checks and removal of ignored Ghost code.
19931 Mark_Ghost_Pragma
(N
, Typ
);
19933 -- The remaining processing is simply to link the pragma on to
19934 -- the rep item chain, for processing when the type is frozen.
19935 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19936 -- mark the type as having predicates.
19938 -- If the current policy for predicate checking is Ignore mark the
19939 -- subtype accordingly. In the case of predicates we consider them
19940 -- enabled unless Ignore is specified (either directly or with a
19941 -- general Assertion_Policy pragma) to preserve existing warnings.
19943 Set_Has_Predicates
(Typ
);
19944 Set_Predicates_Ignored
(Typ
,
19945 Present
(Check_Policy_List
)
19947 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
19948 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19951 -----------------------
19952 -- Predicate_Failure --
19953 -----------------------
19955 -- pragma Predicate_Failure
19956 -- ([Entity =>] type_LOCAL_NAME,
19957 -- [Message =>] string_EXPRESSION);
19959 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
19966 Check_Arg_Count
(2);
19967 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19968 Check_Optional_Identifier
(Arg2
, Name_Message
);
19970 Check_Arg_Is_Local_Name
(Arg1
);
19972 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19973 Find_Type
(Type_Id
);
19974 Typ
:= Entity
(Type_Id
);
19976 if Typ
= Any_Type
then
19980 -- A pragma that applies to a Ghost entity becomes Ghost for the
19981 -- purposes of legality checks and removal of ignored Ghost code.
19983 Mark_Ghost_Pragma
(N
, Typ
);
19985 -- The remaining processing is simply to link the pragma on to
19986 -- the rep item chain, for processing when the type is frozen.
19987 -- This is accomplished by a call to Rep_Item_Too_Late.
19989 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19990 end Predicate_Failure
;
19996 -- pragma Preelaborate [(library_unit_NAME)];
19998 -- Set the flag Is_Preelaborated of program unit name entity
20000 when Pragma_Preelaborate
=> Preelaborate
: declare
20001 Pa
: constant Node_Id
:= Parent
(N
);
20002 Pk
: constant Node_Kind
:= Nkind
(Pa
);
20006 Check_Ada_83_Warning
;
20007 Check_Valid_Library_Unit_Pragma
;
20009 if Nkind
(N
) = N_Null_Statement
then
20013 Ent
:= Find_Lib_Unit_Name
;
20015 -- A pragma that applies to a Ghost entity becomes Ghost for the
20016 -- purposes of legality checks and removal of ignored Ghost code.
20018 Mark_Ghost_Pragma
(N
, Ent
);
20019 Check_Duplicate_Pragma
(Ent
);
20021 -- This filters out pragmas inside generic parents that show up
20022 -- inside instantiations. Pragmas that come from aspects in the
20023 -- unit are not ignored.
20025 if Present
(Ent
) then
20026 if Pk
= N_Package_Specification
20027 and then Present
(Generic_Parent
(Pa
))
20028 and then not From_Aspect_Specification
(N
)
20033 if not Debug_Flag_U
then
20034 Set_Is_Preelaborated
(Ent
);
20035 Set_Suppress_Elaboration_Warnings
(Ent
);
20041 -------------------------------
20042 -- Prefix_Exception_Messages --
20043 -------------------------------
20045 -- pragma Prefix_Exception_Messages;
20047 when Pragma_Prefix_Exception_Messages
=>
20049 Check_Valid_Configuration_Pragma
;
20050 Check_Arg_Count
(0);
20051 Prefix_Exception_Messages
:= True;
20057 -- pragma Priority (EXPRESSION);
20059 when Pragma_Priority
=> Priority
: declare
20060 P
: constant Node_Id
:= Parent
(N
);
20065 Check_No_Identifiers
;
20066 Check_Arg_Count
(1);
20070 if Nkind
(P
) = N_Subprogram_Body
then
20071 Check_In_Main_Program
;
20073 Ent
:= Defining_Unit_Name
(Specification
(P
));
20075 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
20076 Ent
:= Defining_Identifier
(Ent
);
20079 Arg
:= Get_Pragma_Arg
(Arg1
);
20080 Analyze_And_Resolve
(Arg
, Standard_Integer
);
20084 if not Is_OK_Static_Expression
(Arg
) then
20085 Flag_Non_Static_Expr
20086 ("main subprogram priority is not static!", Arg
);
20089 -- If constraint error, then we already signalled an error
20091 elsif Raises_Constraint_Error
(Arg
) then
20094 -- Otherwise check in range except if Relaxed_RM_Semantics
20095 -- where we ignore the value if out of range.
20098 if not Relaxed_RM_Semantics
20099 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
20102 ("main subprogram priority is out of range", Arg1
);
20105 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
20109 -- Load an arbitrary entity from System.Tasking.Stages or
20110 -- System.Tasking.Restricted.Stages (depending on the
20111 -- supported profile) to make sure that one of these packages
20112 -- is implicitly with'ed, since we need to have the tasking
20113 -- run time active for the pragma Priority to have any effect.
20114 -- Previously we with'ed the package System.Tasking, but this
20115 -- package does not trigger the required initialization of the
20116 -- run-time library.
20119 Discard
: Entity_Id
;
20120 pragma Warnings
(Off
, Discard
);
20122 if Restricted_Profile
then
20123 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
20125 Discard
:= RTE
(RE_Activate_Tasks
);
20129 -- Task or Protected, must be of type Integer
20131 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
20132 Arg
:= Get_Pragma_Arg
(Arg1
);
20133 Ent
:= Defining_Identifier
(Parent
(P
));
20135 -- The expression must be analyzed in the special manner
20136 -- described in "Handling of Default and Per-Object
20137 -- Expressions" in sem.ads.
20139 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
20141 if not Is_OK_Static_Expression
(Arg
) then
20142 Check_Restriction
(Static_Priorities
, Arg
);
20145 -- Anything else is incorrect
20151 -- Check duplicate pragma before we chain the pragma in the Rep
20152 -- Item chain of Ent.
20154 Check_Duplicate_Pragma
(Ent
);
20155 Record_Rep_Item
(Ent
, N
);
20158 -----------------------------------
20159 -- Priority_Specific_Dispatching --
20160 -----------------------------------
20162 -- pragma Priority_Specific_Dispatching (
20163 -- policy_IDENTIFIER,
20164 -- first_priority_EXPRESSION,
20165 -- last_priority_EXPRESSION);
20167 when Pragma_Priority_Specific_Dispatching
=>
20168 Priority_Specific_Dispatching
: declare
20169 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
20170 -- This is the entity System.Any_Priority;
20173 Lower_Bound
: Node_Id
;
20174 Upper_Bound
: Node_Id
;
20180 Check_Arg_Count
(3);
20181 Check_No_Identifiers
;
20182 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20183 Check_Valid_Configuration_Pragma
;
20184 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20185 DP
:= Fold_Upper
(Name_Buffer
(1));
20187 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
20188 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
20189 Lower_Val
:= Expr_Value
(Lower_Bound
);
20191 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
20192 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
20193 Upper_Val
:= Expr_Value
(Upper_Bound
);
20195 -- It is not allowed to use Task_Dispatching_Policy and
20196 -- Priority_Specific_Dispatching in the same partition.
20198 if Task_Dispatching_Policy
/= ' ' then
20199 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20201 ("pragma% incompatible with Task_Dispatching_Policy#");
20203 -- Check lower bound in range
20205 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20207 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20210 ("first_priority is out of range", Arg2
);
20212 -- Check upper bound in range
20214 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20216 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20219 ("last_priority is out of range", Arg3
);
20221 -- Check that the priority range is valid
20223 elsif Lower_Val
> Upper_Val
then
20225 ("last_priority_expression must be greater than or equal to "
20226 & "first_priority_expression");
20228 -- Store the new policy, but always preserve System_Location since
20229 -- we like the error message with the run-time name.
20232 -- Check overlapping in the priority ranges specified in other
20233 -- Priority_Specific_Dispatching pragmas within the same
20234 -- partition. We can only check those we know about.
20237 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
20239 if Specific_Dispatching
.Table
(J
).First_Priority
in
20240 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20241 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
20242 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20245 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
20247 ("priority range overlaps with "
20248 & "Priority_Specific_Dispatching#");
20252 -- The use of Priority_Specific_Dispatching is incompatible
20253 -- with Task_Dispatching_Policy.
20255 if Task_Dispatching_Policy
/= ' ' then
20256 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20258 ("Priority_Specific_Dispatching incompatible "
20259 & "with Task_Dispatching_Policy#");
20262 -- The use of Priority_Specific_Dispatching forces ceiling
20265 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
20266 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20268 ("Priority_Specific_Dispatching incompatible "
20269 & "with Locking_Policy#");
20271 -- Set the Ceiling_Locking policy, but preserve System_Location
20272 -- since we like the error message with the run time name.
20275 Locking_Policy
:= 'C';
20277 if Locking_Policy_Sloc
/= System_Location
then
20278 Locking_Policy_Sloc
:= Loc
;
20282 -- Add entry in the table
20284 Specific_Dispatching
.Append
20285 ((Dispatching_Policy
=> DP
,
20286 First_Priority
=> UI_To_Int
(Lower_Val
),
20287 Last_Priority
=> UI_To_Int
(Upper_Val
),
20288 Pragma_Loc
=> Loc
));
20290 end Priority_Specific_Dispatching
;
20296 -- pragma Profile (profile_IDENTIFIER);
20298 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
20300 when Pragma_Profile
=>
20302 Check_Arg_Count
(1);
20303 Check_Valid_Configuration_Pragma
;
20304 Check_No_Identifiers
;
20307 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20310 if Chars
(Argx
) = Name_Ravenscar
then
20311 Set_Ravenscar_Profile
(Ravenscar
, N
);
20313 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
20314 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
20316 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
20317 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
20319 elsif Chars
(Argx
) = Name_Restricted
then
20320 Set_Profile_Restrictions
20322 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20324 elsif Chars
(Argx
) = Name_Rational
then
20325 Set_Rational_Profile
;
20327 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20328 Set_Profile_Restrictions
20329 (No_Implementation_Extensions
,
20330 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20333 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20337 ----------------------
20338 -- Profile_Warnings --
20339 ----------------------
20341 -- pragma Profile_Warnings (profile_IDENTIFIER);
20343 -- profile_IDENTIFIER => Restricted | Ravenscar
20345 when Pragma_Profile_Warnings
=>
20347 Check_Arg_Count
(1);
20348 Check_Valid_Configuration_Pragma
;
20349 Check_No_Identifiers
;
20352 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20355 if Chars
(Argx
) = Name_Ravenscar
then
20356 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
20358 elsif Chars
(Argx
) = Name_Restricted
then
20359 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
20361 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20362 Set_Profile_Restrictions
20363 (No_Implementation_Extensions
, N
, Warn
=> True);
20366 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20370 --------------------------
20371 -- Propagate_Exceptions --
20372 --------------------------
20374 -- pragma Propagate_Exceptions;
20376 -- Note: this pragma is obsolete and has no effect
20378 when Pragma_Propagate_Exceptions
=>
20380 Check_Arg_Count
(0);
20382 if Warn_On_Obsolescent_Feature
then
20384 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20385 "and has no effect?j?", N
);
20388 -----------------------------
20389 -- Provide_Shift_Operators --
20390 -----------------------------
20392 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20394 when Pragma_Provide_Shift_Operators
=>
20395 Provide_Shift_Operators
: declare
20398 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
20399 -- Insert declaration and pragma Instrinsic for named shift op
20401 ----------------------------
20402 -- Declare_Shift_Operator --
20403 ----------------------------
20405 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
20411 Make_Subprogram_Declaration
(Loc
,
20412 Make_Function_Specification
(Loc
,
20413 Defining_Unit_Name
=>
20414 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
20416 Result_Definition
=>
20417 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
20419 Parameter_Specifications
=> New_List
(
20420 Make_Parameter_Specification
(Loc
,
20421 Defining_Identifier
=>
20422 Make_Defining_Identifier
(Loc
, Name_Value
),
20424 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
20426 Make_Parameter_Specification
(Loc
,
20427 Defining_Identifier
=>
20428 Make_Defining_Identifier
(Loc
, Name_Amount
),
20430 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
20434 Chars
=> Name_Import
,
20435 Pragma_Argument_Associations
=> New_List
(
20436 Make_Pragma_Argument_Association
(Loc
,
20437 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
20438 Make_Pragma_Argument_Association
(Loc
,
20439 Expression
=> Make_Identifier
(Loc
, Nam
))));
20441 Insert_After
(N
, Import
);
20442 Insert_After
(N
, Func
);
20443 end Declare_Shift_Operator
;
20445 -- Start of processing for Provide_Shift_Operators
20449 Check_Arg_Count
(1);
20450 Check_Arg_Is_Local_Name
(Arg1
);
20452 Arg1
:= Get_Pragma_Arg
(Arg1
);
20454 -- We must have an entity name
20456 if not Is_Entity_Name
(Arg1
) then
20458 ("pragma % must apply to integer first subtype", Arg1
);
20461 -- If no Entity, means there was a prior error so ignore
20463 if Present
(Entity
(Arg1
)) then
20464 Ent
:= Entity
(Arg1
);
20466 -- Apply error checks
20468 if not Is_First_Subtype
(Ent
) then
20470 ("cannot apply pragma %",
20471 "\& is not a first subtype",
20474 elsif not Is_Integer_Type
(Ent
) then
20476 ("cannot apply pragma %",
20477 "\& is not an integer type",
20480 elsif Has_Shift_Operator
(Ent
) then
20482 ("cannot apply pragma %",
20483 "\& already has declared shift operators",
20486 elsif Is_Frozen
(Ent
) then
20488 ("pragma % appears too late",
20489 "\& is already frozen",
20493 -- Now declare the operators. We do this during analysis rather
20494 -- than expansion, since we want the operators available if we
20495 -- are operating in -gnatc or ASIS mode.
20497 Declare_Shift_Operator
(Name_Rotate_Left
);
20498 Declare_Shift_Operator
(Name_Rotate_Right
);
20499 Declare_Shift_Operator
(Name_Shift_Left
);
20500 Declare_Shift_Operator
(Name_Shift_Right
);
20501 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
20503 end Provide_Shift_Operators
;
20509 -- pragma Psect_Object (
20510 -- [Internal =>] LOCAL_NAME,
20511 -- [, [External =>] EXTERNAL_SYMBOL]
20512 -- [, [Size =>] EXTERNAL_SYMBOL]);
20514 when Pragma_Common_Object
20515 | Pragma_Psect_Object
20517 Psect_Object
: declare
20518 Args
: Args_List
(1 .. 3);
20519 Names
: constant Name_List
(1 .. 3) := (
20524 Internal
: Node_Id
renames Args
(1);
20525 External
: Node_Id
renames Args
(2);
20526 Size
: Node_Id
renames Args
(3);
20528 Def_Id
: Entity_Id
;
20530 procedure Check_Arg
(Arg
: Node_Id
);
20531 -- Checks that argument is either a string literal or an
20532 -- identifier, and posts error message if not.
20538 procedure Check_Arg
(Arg
: Node_Id
) is
20540 if not Nkind_In
(Original_Node
(Arg
),
20545 ("inappropriate argument for pragma %", Arg
);
20549 -- Start of processing for Common_Object/Psect_Object
20553 Gather_Associations
(Names
, Args
);
20554 Process_Extended_Import_Export_Internal_Arg
(Internal
);
20556 Def_Id
:= Entity
(Internal
);
20558 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
20560 ("pragma% must designate an object", Internal
);
20563 Check_Arg
(Internal
);
20565 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
20567 ("cannot use pragma% for imported/exported object",
20571 if Is_Concurrent_Type
(Etype
(Internal
)) then
20573 ("cannot specify pragma % for task/protected object",
20577 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
20579 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
20581 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
20584 if Ekind
(Def_Id
) = E_Constant
then
20586 ("cannot specify pragma % for a constant", Internal
);
20589 if Is_Record_Type
(Etype
(Internal
)) then
20595 Ent
:= First_Entity
(Etype
(Internal
));
20596 while Present
(Ent
) loop
20597 Decl
:= Declaration_Node
(Ent
);
20599 if Ekind
(Ent
) = E_Component
20600 and then Nkind
(Decl
) = N_Component_Declaration
20601 and then Present
(Expression
(Decl
))
20602 and then Warn_On_Export_Import
20605 ("?x?object for pragma % has defaults", Internal
);
20615 if Present
(Size
) then
20619 if Present
(External
) then
20620 Check_Arg_Is_External_Name
(External
);
20623 -- If all error tests pass, link pragma on to the rep item chain
20625 Record_Rep_Item
(Def_Id
, N
);
20632 -- pragma Pure [(library_unit_NAME)];
20634 when Pragma_Pure
=> Pure
: declare
20638 Check_Ada_83_Warning
;
20640 -- If the pragma comes from a subprogram instantiation, nothing to
20641 -- check, this can happen at any level of nesting.
20643 if Is_Wrapper_Package
(Current_Scope
) then
20646 Check_Valid_Library_Unit_Pragma
;
20649 if Nkind
(N
) = N_Null_Statement
then
20653 Ent
:= Find_Lib_Unit_Name
;
20655 -- A pragma that applies to a Ghost entity becomes Ghost for the
20656 -- purposes of legality checks and removal of ignored Ghost code.
20658 Mark_Ghost_Pragma
(N
, Ent
);
20660 if not Debug_Flag_U
then
20662 Set_Has_Pragma_Pure
(Ent
);
20663 Set_Suppress_Elaboration_Warnings
(Ent
);
20667 -------------------
20668 -- Pure_Function --
20669 -------------------
20671 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20673 when Pragma_Pure_Function
=> Pure_Function
: declare
20674 Def_Id
: Entity_Id
;
20677 Effective
: Boolean := False;
20681 Check_Arg_Count
(1);
20682 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20683 Check_Arg_Is_Local_Name
(Arg1
);
20684 E_Id
:= Get_Pragma_Arg
(Arg1
);
20686 if Etype
(E_Id
) = Any_Type
then
20690 -- Loop through homonyms (overloadings) of referenced entity
20692 E
:= Entity
(E_Id
);
20694 -- A pragma that applies to a Ghost entity becomes Ghost for the
20695 -- purposes of legality checks and removal of ignored Ghost code.
20697 Mark_Ghost_Pragma
(N
, E
);
20699 if Present
(E
) then
20701 Def_Id
:= Get_Base_Subprogram
(E
);
20703 if not Ekind_In
(Def_Id
, E_Function
,
20704 E_Generic_Function
,
20708 ("pragma% requires a function name", Arg1
);
20711 Set_Is_Pure
(Def_Id
);
20713 if not Has_Pragma_Pure_Function
(Def_Id
) then
20714 Set_Has_Pragma_Pure_Function
(Def_Id
);
20718 exit when From_Aspect_Specification
(N
);
20720 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
20724 and then Warn_On_Redundant_Constructs
20727 ("pragma Pure_Function on& is redundant?r?",
20733 --------------------
20734 -- Queuing_Policy --
20735 --------------------
20737 -- pragma Queuing_Policy (policy_IDENTIFIER);
20739 when Pragma_Queuing_Policy
=> declare
20743 Check_Ada_83_Warning
;
20744 Check_Arg_Count
(1);
20745 Check_No_Identifiers
;
20746 Check_Arg_Is_Queuing_Policy
(Arg1
);
20747 Check_Valid_Configuration_Pragma
;
20748 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20749 QP
:= Fold_Upper
(Name_Buffer
(1));
20751 if Queuing_Policy
/= ' '
20752 and then Queuing_Policy
/= QP
20754 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
20755 Error_Pragma
("queuing policy incompatible with policy#");
20757 -- Set new policy, but always preserve System_Location since we
20758 -- like the error message with the run time name.
20761 Queuing_Policy
:= QP
;
20763 if Queuing_Policy_Sloc
/= System_Location
then
20764 Queuing_Policy_Sloc
:= Loc
;
20773 -- pragma Rational, for compatibility with foreign compiler
20775 when Pragma_Rational
=>
20776 Set_Rational_Profile
;
20778 ---------------------
20779 -- Refined_Depends --
20780 ---------------------
20782 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20784 -- DEPENDENCY_RELATION ::=
20786 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20788 -- DEPENDENCY_CLAUSE ::=
20789 -- OUTPUT_LIST =>[+] INPUT_LIST
20790 -- | NULL_DEPENDENCY_CLAUSE
20792 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20794 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20796 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20798 -- OUTPUT ::= NAME | FUNCTION_RESULT
20801 -- where FUNCTION_RESULT is a function Result attribute_reference
20803 -- Characteristics:
20805 -- * Analysis - The annotation undergoes initial checks to verify
20806 -- the legal placement and context. Secondary checks fully analyze
20807 -- the dependency clauses/global list in:
20809 -- Analyze_Refined_Depends_In_Decl_Part
20811 -- * Expansion - None.
20813 -- * Template - The annotation utilizes the generic template of the
20814 -- related subprogram body.
20816 -- * Globals - Capture of global references must occur after full
20819 -- * Instance - The annotation is instantiated automatically when
20820 -- the related generic subprogram body is instantiated.
20822 when Pragma_Refined_Depends
=> Refined_Depends
: declare
20823 Body_Id
: Entity_Id
;
20825 Spec_Id
: Entity_Id
;
20828 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20832 -- Chain the pragma on the contract for further processing by
20833 -- Analyze_Refined_Depends_In_Decl_Part.
20835 Add_Contract_Item
(N
, Body_Id
);
20837 -- The legality checks of pragmas Refined_Depends and
20838 -- Refined_Global are affected by the SPARK mode in effect and
20839 -- the volatility of the context. In addition these two pragmas
20840 -- are subject to an inherent order:
20842 -- 1) Refined_Global
20843 -- 2) Refined_Depends
20845 -- Analyze all these pragmas in the order outlined above
20847 Analyze_If_Present
(Pragma_SPARK_Mode
);
20848 Analyze_If_Present
(Pragma_Volatile_Function
);
20849 Analyze_If_Present
(Pragma_Refined_Global
);
20850 Analyze_Refined_Depends_In_Decl_Part
(N
);
20852 end Refined_Depends
;
20854 --------------------
20855 -- Refined_Global --
20856 --------------------
20858 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20860 -- GLOBAL_SPECIFICATION ::=
20863 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20865 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20867 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20868 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20869 -- GLOBAL_ITEM ::= NAME
20871 -- Characteristics:
20873 -- * Analysis - The annotation undergoes initial checks to verify
20874 -- the legal placement and context. Secondary checks fully analyze
20875 -- the dependency clauses/global list in:
20877 -- Analyze_Refined_Global_In_Decl_Part
20879 -- * Expansion - None.
20881 -- * Template - The annotation utilizes the generic template of the
20882 -- related subprogram body.
20884 -- * Globals - Capture of global references must occur after full
20887 -- * Instance - The annotation is instantiated automatically when
20888 -- the related generic subprogram body is instantiated.
20890 when Pragma_Refined_Global
=> Refined_Global
: declare
20891 Body_Id
: Entity_Id
;
20893 Spec_Id
: Entity_Id
;
20896 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20900 -- Chain the pragma on the contract for further processing by
20901 -- Analyze_Refined_Global_In_Decl_Part.
20903 Add_Contract_Item
(N
, Body_Id
);
20905 -- The legality checks of pragmas Refined_Depends and
20906 -- Refined_Global are affected by the SPARK mode in effect and
20907 -- the volatility of the context. In addition these two pragmas
20908 -- are subject to an inherent order:
20910 -- 1) Refined_Global
20911 -- 2) Refined_Depends
20913 -- Analyze all these pragmas in the order outlined above
20915 Analyze_If_Present
(Pragma_SPARK_Mode
);
20916 Analyze_If_Present
(Pragma_Volatile_Function
);
20917 Analyze_Refined_Global_In_Decl_Part
(N
);
20918 Analyze_If_Present
(Pragma_Refined_Depends
);
20920 end Refined_Global
;
20926 -- pragma Refined_Post (boolean_EXPRESSION);
20928 -- Characteristics:
20930 -- * Analysis - The annotation is fully analyzed immediately upon
20931 -- elaboration as it cannot forward reference entities.
20933 -- * Expansion - The annotation is expanded during the expansion of
20934 -- the related subprogram body contract as performed in:
20936 -- Expand_Subprogram_Contract
20938 -- * Template - The annotation utilizes the generic template of the
20939 -- related subprogram body.
20941 -- * Globals - Capture of global references must occur after full
20944 -- * Instance - The annotation is instantiated automatically when
20945 -- the related generic subprogram body is instantiated.
20947 when Pragma_Refined_Post
=> Refined_Post
: declare
20948 Body_Id
: Entity_Id
;
20950 Spec_Id
: Entity_Id
;
20953 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20955 -- Fully analyze the pragma when it appears inside a subprogram
20956 -- body because it cannot benefit from forward references.
20960 -- Chain the pragma on the contract for completeness
20962 Add_Contract_Item
(N
, Body_Id
);
20964 -- The legality checks of pragma Refined_Post are affected by
20965 -- the SPARK mode in effect and the volatility of the context.
20966 -- Analyze all pragmas in a specific order.
20968 Analyze_If_Present
(Pragma_SPARK_Mode
);
20969 Analyze_If_Present
(Pragma_Volatile_Function
);
20970 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
20972 -- Currently it is not possible to inline pre/postconditions on
20973 -- a subprogram subject to pragma Inline_Always.
20975 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
20979 -------------------
20980 -- Refined_State --
20981 -------------------
20983 -- pragma Refined_State (REFINEMENT_LIST);
20985 -- REFINEMENT_LIST ::=
20986 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20988 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20990 -- CONSTITUENT_LIST ::=
20993 -- | (CONSTITUENT {, CONSTITUENT})
20995 -- CONSTITUENT ::= object_NAME | state_NAME
20997 -- Characteristics:
20999 -- * Analysis - The annotation undergoes initial checks to verify
21000 -- the legal placement and context. Secondary checks preanalyze the
21001 -- refinement clauses in:
21003 -- Analyze_Refined_State_In_Decl_Part
21005 -- * Expansion - None.
21007 -- * Template - The annotation utilizes the template of the related
21010 -- * Globals - Capture of global references must occur after full
21013 -- * Instance - The annotation is instantiated automatically when
21014 -- the related generic package body is instantiated.
21016 when Pragma_Refined_State
=> Refined_State
: declare
21017 Pack_Decl
: Node_Id
;
21018 Spec_Id
: Entity_Id
;
21022 Check_No_Identifiers
;
21023 Check_Arg_Count
(1);
21025 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
21027 -- Ensure the proper placement of the pragma. Refined states must
21028 -- be associated with a package body.
21030 if Nkind
(Pack_Decl
) = N_Package_Body
then
21033 -- Otherwise the pragma is associated with an illegal construct
21040 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
21042 -- A pragma that applies to a Ghost entity becomes Ghost for the
21043 -- purposes of legality checks and removal of ignored Ghost code.
21045 Mark_Ghost_Pragma
(N
, Spec_Id
);
21047 -- Chain the pragma on the contract for further processing by
21048 -- Analyze_Refined_State_In_Decl_Part.
21050 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
21052 -- The legality checks of pragma Refined_State are affected by the
21053 -- SPARK mode in effect. Analyze all pragmas in a specific order.
21055 Analyze_If_Present
(Pragma_SPARK_Mode
);
21057 -- State refinement is allowed only when the corresponding package
21058 -- declaration has non-null pragma Abstract_State. Refinement not
21059 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
21061 if SPARK_Mode
/= Off
21063 (No
(Abstract_States
(Spec_Id
))
21064 or else Has_Null_Abstract_State
(Spec_Id
))
21067 ("useless refinement, package & does not define abstract "
21068 & "states", N
, Spec_Id
);
21073 -----------------------
21074 -- Relative_Deadline --
21075 -----------------------
21077 -- pragma Relative_Deadline (time_span_EXPRESSION);
21079 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
21080 P
: constant Node_Id
:= Parent
(N
);
21085 Check_No_Identifiers
;
21086 Check_Arg_Count
(1);
21088 Arg
:= Get_Pragma_Arg
(Arg1
);
21090 -- The expression must be analyzed in the special manner described
21091 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
21093 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
21097 if Nkind
(P
) = N_Subprogram_Body
then
21098 Check_In_Main_Program
;
21100 -- Only Task and subprogram cases allowed
21102 elsif Nkind
(P
) /= N_Task_Definition
then
21106 -- Check duplicate pragma before we set the corresponding flag
21108 if Has_Relative_Deadline_Pragma
(P
) then
21109 Error_Pragma
("duplicate pragma% not allowed");
21112 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
21113 -- Relative_Deadline pragma node cannot be inserted in the Rep
21114 -- Item chain of Ent since it is rewritten by the expander as a
21115 -- procedure call statement that will break the chain.
21117 Set_Has_Relative_Deadline_Pragma
(P
);
21118 end Relative_Deadline
;
21120 ------------------------
21121 -- Remote_Access_Type --
21122 ------------------------
21124 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
21126 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
21131 Check_Arg_Count
(1);
21132 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21133 Check_Arg_Is_Local_Name
(Arg1
);
21135 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
21137 -- A pragma that applies to a Ghost entity becomes Ghost for the
21138 -- purposes of legality checks and removal of ignored Ghost code.
21140 Mark_Ghost_Pragma
(N
, E
);
21142 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
21143 and then Ekind
(E
) = E_General_Access_Type
21144 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
21145 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
21147 and then Is_Valid_Remote_Object_Type
21148 (Root_Type
(Directly_Designated_Type
(E
)))
21150 Set_Is_Remote_Types
(E
);
21154 ("pragma% applies only to formal access-to-class-wide types",
21157 end Remote_Access_Type
;
21159 ---------------------------
21160 -- Remote_Call_Interface --
21161 ---------------------------
21163 -- pragma Remote_Call_Interface [(library_unit_NAME)];
21165 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
21166 Cunit_Node
: Node_Id
;
21167 Cunit_Ent
: Entity_Id
;
21171 Check_Ada_83_Warning
;
21172 Check_Valid_Library_Unit_Pragma
;
21174 if Nkind
(N
) = N_Null_Statement
then
21178 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21179 K
:= Nkind
(Unit
(Cunit_Node
));
21180 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21182 -- A pragma that applies to a Ghost entity becomes Ghost for the
21183 -- purposes of legality checks and removal of ignored Ghost code.
21185 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21187 if K
= N_Package_Declaration
21188 or else K
= N_Generic_Package_Declaration
21189 or else K
= N_Subprogram_Declaration
21190 or else K
= N_Generic_Subprogram_Declaration
21191 or else (K
= N_Subprogram_Body
21192 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
21197 "pragma% must apply to package or subprogram declaration");
21200 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
21201 end Remote_Call_Interface
;
21207 -- pragma Remote_Types [(library_unit_NAME)];
21209 when Pragma_Remote_Types
=> Remote_Types
: declare
21210 Cunit_Node
: Node_Id
;
21211 Cunit_Ent
: Entity_Id
;
21214 Check_Ada_83_Warning
;
21215 Check_Valid_Library_Unit_Pragma
;
21217 if Nkind
(N
) = N_Null_Statement
then
21221 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21222 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21224 -- A pragma that applies to a Ghost entity becomes Ghost for the
21225 -- purposes of legality checks and removal of ignored Ghost code.
21227 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21229 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21230 N_Generic_Package_Declaration
)
21233 ("pragma% can only apply to a package declaration");
21236 Set_Is_Remote_Types
(Cunit_Ent
);
21243 -- pragma Ravenscar;
21245 when Pragma_Ravenscar
=>
21247 Check_Arg_Count
(0);
21248 Check_Valid_Configuration_Pragma
;
21249 Set_Ravenscar_Profile
(Ravenscar
, N
);
21251 if Warn_On_Obsolescent_Feature
then
21253 ("pragma Ravenscar is an obsolescent feature?j?", N
);
21255 ("|use pragma Profile (Ravenscar) instead?j?", N
);
21258 -------------------------
21259 -- Restricted_Run_Time --
21260 -------------------------
21262 -- pragma Restricted_Run_Time;
21264 when Pragma_Restricted_Run_Time
=>
21266 Check_Arg_Count
(0);
21267 Check_Valid_Configuration_Pragma
;
21268 Set_Profile_Restrictions
21269 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
21271 if Warn_On_Obsolescent_Feature
then
21273 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
21276 ("|use pragma Profile (Restricted) instead?j?", N
);
21283 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
21286 -- restriction_IDENTIFIER
21287 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21289 when Pragma_Restrictions
=>
21290 Process_Restrictions_Or_Restriction_Warnings
21291 (Warn
=> Treat_Restrictions_As_Warnings
);
21293 --------------------------
21294 -- Restriction_Warnings --
21295 --------------------------
21297 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
21300 -- restriction_IDENTIFIER
21301 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21303 when Pragma_Restriction_Warnings
=>
21305 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
21311 -- pragma Reviewable;
21313 when Pragma_Reviewable
=>
21314 Check_Ada_83_Warning
;
21315 Check_Arg_Count
(0);
21317 -- Call dummy debugging function rv. This is done to assist front
21318 -- end debugging. By placing a Reviewable pragma in the source
21319 -- program, a breakpoint on rv catches this place in the source,
21320 -- allowing convenient stepping to the point of interest.
21324 --------------------------
21325 -- Secondary_Stack_Size --
21326 --------------------------
21328 -- pragma Secondary_Stack_Size (EXPRESSION);
21330 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
21331 P
: constant Node_Id
:= Parent
(N
);
21337 Check_No_Identifiers
;
21338 Check_Arg_Count
(1);
21340 if Nkind
(P
) = N_Task_Definition
then
21341 Arg
:= Get_Pragma_Arg
(Arg1
);
21342 Ent
:= Defining_Identifier
(Parent
(P
));
21344 -- The expression must be analyzed in the special manner
21345 -- described in "Handling of Default Expressions" in sem.ads.
21347 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21349 -- The pragma cannot appear if the No_Secondary_Stack
21350 -- restriction is in effect.
21352 Check_Restriction
(No_Secondary_Stack
, Arg
);
21354 -- Anything else is incorrect
21360 -- Check duplicate pragma before we chain the pragma in the Rep
21361 -- Item chain of Ent.
21363 Check_Duplicate_Pragma
(Ent
);
21364 Record_Rep_Item
(Ent
, N
);
21365 end Secondary_Stack_Size
;
21367 --------------------------
21368 -- Short_Circuit_And_Or --
21369 --------------------------
21371 -- pragma Short_Circuit_And_Or;
21373 when Pragma_Short_Circuit_And_Or
=>
21375 Check_Arg_Count
(0);
21376 Check_Valid_Configuration_Pragma
;
21377 Short_Circuit_And_Or
:= True;
21379 -------------------
21380 -- Share_Generic --
21381 -------------------
21383 -- pragma Share_Generic (GNAME {, GNAME});
21385 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21387 when Pragma_Share_Generic
=>
21389 Process_Generic_List
;
21395 -- pragma Shared (LOCAL_NAME);
21397 when Pragma_Shared
=>
21399 Process_Atomic_Independent_Shared_Volatile
;
21401 --------------------
21402 -- Shared_Passive --
21403 --------------------
21405 -- pragma Shared_Passive [(library_unit_NAME)];
21407 -- Set the flag Is_Shared_Passive of program unit name entity
21409 when Pragma_Shared_Passive
=> Shared_Passive
: declare
21410 Cunit_Node
: Node_Id
;
21411 Cunit_Ent
: Entity_Id
;
21414 Check_Ada_83_Warning
;
21415 Check_Valid_Library_Unit_Pragma
;
21417 if Nkind
(N
) = N_Null_Statement
then
21421 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21422 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21424 -- A pragma that applies to a Ghost entity becomes Ghost for the
21425 -- purposes of legality checks and removal of ignored Ghost code.
21427 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21429 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21430 N_Generic_Package_Declaration
)
21433 ("pragma% can only apply to a package declaration");
21436 Set_Is_Shared_Passive
(Cunit_Ent
);
21437 end Shared_Passive
;
21439 -----------------------
21440 -- Short_Descriptors --
21441 -----------------------
21443 -- pragma Short_Descriptors;
21445 -- Recognize and validate, but otherwise ignore
21447 when Pragma_Short_Descriptors
=>
21449 Check_Arg_Count
(0);
21450 Check_Valid_Configuration_Pragma
;
21452 ------------------------------
21453 -- Simple_Storage_Pool_Type --
21454 ------------------------------
21456 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21458 when Pragma_Simple_Storage_Pool_Type
=>
21459 Simple_Storage_Pool_Type
: declare
21465 Check_Arg_Count
(1);
21466 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21468 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21469 Find_Type
(Type_Id
);
21470 Typ
:= Entity
(Type_Id
);
21472 if Typ
= Any_Type
then
21476 -- A pragma that applies to a Ghost entity becomes Ghost for the
21477 -- purposes of legality checks and removal of ignored Ghost code.
21479 Mark_Ghost_Pragma
(N
, Typ
);
21481 -- We require the pragma to apply to a type declared in a package
21482 -- declaration, but not (immediately) within a package body.
21484 if Ekind
(Current_Scope
) /= E_Package
21485 or else In_Package_Body
(Current_Scope
)
21488 ("pragma% can only apply to type declared immediately "
21489 & "within a package declaration");
21492 -- A simple storage pool type must be an immutably limited record
21493 -- or private type. If the pragma is given for a private type,
21494 -- the full type is similarly restricted (which is checked later
21495 -- in Freeze_Entity).
21497 if Is_Record_Type
(Typ
)
21498 and then not Is_Limited_View
(Typ
)
21501 ("pragma% can only apply to explicitly limited record type");
21503 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
21505 ("pragma% can only apply to a private type that is limited");
21507 elsif not Is_Record_Type
(Typ
)
21508 and then not Is_Private_Type
(Typ
)
21511 ("pragma% can only apply to limited record or private type");
21514 Record_Rep_Item
(Typ
, N
);
21515 end Simple_Storage_Pool_Type
;
21517 ----------------------
21518 -- Source_File_Name --
21519 ----------------------
21521 -- There are five forms for this pragma:
21523 -- pragma Source_File_Name (
21524 -- [UNIT_NAME =>] unit_NAME,
21525 -- BODY_FILE_NAME => STRING_LITERAL
21526 -- [, [INDEX =>] INTEGER_LITERAL]);
21528 -- pragma Source_File_Name (
21529 -- [UNIT_NAME =>] unit_NAME,
21530 -- SPEC_FILE_NAME => STRING_LITERAL
21531 -- [, [INDEX =>] INTEGER_LITERAL]);
21533 -- pragma Source_File_Name (
21534 -- BODY_FILE_NAME => STRING_LITERAL
21535 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21536 -- [, CASING => CASING_SPEC]);
21538 -- pragma Source_File_Name (
21539 -- SPEC_FILE_NAME => STRING_LITERAL
21540 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21541 -- [, CASING => CASING_SPEC]);
21543 -- pragma Source_File_Name (
21544 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21545 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21546 -- [, CASING => CASING_SPEC]);
21548 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21550 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21551 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21552 -- only be used when no project file is used, while SFNP can only be
21553 -- used when a project file is used.
21555 -- No processing here. Processing was completed during parsing, since
21556 -- we need to have file names set as early as possible. Units are
21557 -- loaded well before semantic processing starts.
21559 -- The only processing we defer to this point is the check for
21560 -- correct placement.
21562 when Pragma_Source_File_Name
=>
21564 Check_Valid_Configuration_Pragma
;
21566 ------------------------------
21567 -- Source_File_Name_Project --
21568 ------------------------------
21570 -- See Source_File_Name for syntax
21572 -- No processing here. Processing was completed during parsing, since
21573 -- we need to have file names set as early as possible. Units are
21574 -- loaded well before semantic processing starts.
21576 -- The only processing we defer to this point is the check for
21577 -- correct placement.
21579 when Pragma_Source_File_Name_Project
=>
21581 Check_Valid_Configuration_Pragma
;
21583 -- Check that a pragma Source_File_Name_Project is used only in a
21584 -- configuration pragmas file.
21586 -- Pragmas Source_File_Name_Project should only be generated by
21587 -- the Project Manager in configuration pragmas files.
21589 -- This is really an ugly test. It seems to depend on some
21590 -- accidental and undocumented property. At the very least it
21591 -- needs to be documented, but it would be better to have a
21592 -- clean way of testing if we are in a configuration file???
21594 if Present
(Parent
(N
)) then
21596 ("pragma% can only appear in a configuration pragmas file");
21599 ----------------------
21600 -- Source_Reference --
21601 ----------------------
21603 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21605 -- Nothing to do, all processing completed in Par.Prag, since we need
21606 -- the information for possible parser messages that are output.
21608 when Pragma_Source_Reference
=>
21615 -- pragma SPARK_Mode [(On | Off)];
21617 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
21618 Mode_Id
: SPARK_Mode_Type
;
21620 procedure Check_Pragma_Conformance
21621 (Context_Pragma
: Node_Id
;
21622 Entity
: Entity_Id
;
21623 Entity_Pragma
: Node_Id
);
21624 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21625 -- conformance of pragma N depending the following scenarios:
21627 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21628 -- compatible with the pragma Context_Pragma that was inherited
21629 -- from the context:
21630 -- * If the mode of Context_Pragma is ON, then the new mode can
21632 -- * If the mode of Context_Pragma is OFF, then the only allowed
21633 -- new mode is also OFF. Emit error if this is not the case.
21635 -- If Entity is not Empty, verify that pragma N is compatible with
21636 -- pragma Entity_Pragma that belongs to Entity.
21637 -- * If Entity_Pragma is Empty, always issue an error as this
21638 -- corresponds to the case where a previous section of Entity
21639 -- has no SPARK_Mode set.
21640 -- * If the mode of Entity_Pragma is ON, then the new mode can
21642 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21643 -- new mode is also OFF. Emit error if this is not the case.
21645 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
21646 -- Subsidiary to routines Process_xxx. Verify that the related
21647 -- entity E subject to pragma SPARK_Mode is library-level.
21649 procedure Process_Body
(Decl
: Node_Id
);
21650 -- Verify the legality of pragma SPARK_Mode when it appears as the
21651 -- top of the body declarations of entry, package, protected unit,
21652 -- subprogram or task unit body denoted by Decl.
21654 procedure Process_Overloadable
(Decl
: Node_Id
);
21655 -- Verify the legality of pragma SPARK_Mode when it applies to an
21656 -- entry or [generic] subprogram declaration denoted by Decl.
21658 procedure Process_Private_Part
(Decl
: Node_Id
);
21659 -- Verify the legality of pragma SPARK_Mode when it appears at the
21660 -- top of the private declarations of a package spec, protected or
21661 -- task unit declaration denoted by Decl.
21663 procedure Process_Statement_Part
(Decl
: Node_Id
);
21664 -- Verify the legality of pragma SPARK_Mode when it appears at the
21665 -- top of the statement sequence of a package body denoted by node
21668 procedure Process_Visible_Part
(Decl
: Node_Id
);
21669 -- Verify the legality of pragma SPARK_Mode when it appears at the
21670 -- top of the visible declarations of a package spec, protected or
21671 -- task unit declaration denoted by Decl. The routine is also used
21672 -- on protected or task units declared without a definition.
21674 procedure Set_SPARK_Context
;
21675 -- Subsidiary to routines Process_xxx. Set the global variables
21676 -- which represent the mode of the context from pragma N. Ensure
21677 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21679 ------------------------------
21680 -- Check_Pragma_Conformance --
21681 ------------------------------
21683 procedure Check_Pragma_Conformance
21684 (Context_Pragma
: Node_Id
;
21685 Entity
: Entity_Id
;
21686 Entity_Pragma
: Node_Id
)
21688 Err_Id
: Entity_Id
;
21692 -- The current pragma may appear without an argument. If this
21693 -- is the case, associate all error messages with the pragma
21696 if Present
(Arg1
) then
21702 -- The mode of the current pragma is compared against that of
21703 -- an enclosing context.
21705 if Present
(Context_Pragma
) then
21706 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
21708 -- Issue an error if the new mode is less restrictive than
21709 -- that of the context.
21711 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
21712 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21715 ("cannot change SPARK_Mode from Off to On", Err_N
);
21716 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21717 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
21722 -- The mode of the current pragma is compared against that of
21723 -- an initial package, protected type, subprogram or task type
21726 if Present
(Entity
) then
21728 -- A simple protected or task type is transformed into an
21729 -- anonymous type whose name cannot be used to issue error
21730 -- messages. Recover the original entity of the type.
21732 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
21735 (Original_Node
(Unit_Declaration_Node
(Entity
)));
21740 -- Both the initial declaration and the completion carry
21741 -- SPARK_Mode pragmas.
21743 if Present
(Entity_Pragma
) then
21744 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
21746 -- Issue an error if the new mode is less restrictive
21747 -- than that of the initial declaration.
21749 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
21750 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21752 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21753 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
21755 ("\value Off was set for SPARK_Mode on&#",
21760 -- Otherwise the initial declaration lacks a SPARK_Mode
21761 -- pragma in which case the current pragma is illegal as
21762 -- it cannot "complete".
21765 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21766 Error_Msg_Sloc
:= Sloc
(Err_Id
);
21768 ("\no value was set for SPARK_Mode on&#",
21773 end Check_Pragma_Conformance
;
21775 --------------------------------
21776 -- Check_Library_Level_Entity --
21777 --------------------------------
21779 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
21780 procedure Add_Entity_To_Name_Buffer
;
21781 -- Add the E_Kind of entity E to the name buffer
21783 -------------------------------
21784 -- Add_Entity_To_Name_Buffer --
21785 -------------------------------
21787 procedure Add_Entity_To_Name_Buffer
is
21789 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
21790 Add_Str_To_Name_Buffer
("entry");
21792 elsif Ekind_In
(E
, E_Generic_Package
,
21796 Add_Str_To_Name_Buffer
("package");
21798 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
21799 Add_Str_To_Name_Buffer
("protected type");
21801 elsif Ekind_In
(E
, E_Function
,
21802 E_Generic_Function
,
21803 E_Generic_Procedure
,
21807 Add_Str_To_Name_Buffer
("subprogram");
21810 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
21811 Add_Str_To_Name_Buffer
("task type");
21813 end Add_Entity_To_Name_Buffer
;
21817 Msg_1
: constant String := "incorrect placement of pragma%";
21820 -- Start of processing for Check_Library_Level_Entity
21823 if not Is_Library_Level_Entity
(E
) then
21824 Error_Msg_Name_1
:= Pname
;
21825 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
21828 Add_Str_To_Name_Buffer
("\& is not a library-level ");
21829 Add_Entity_To_Name_Buffer
;
21831 Msg_2
:= Name_Find
;
21832 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
21836 end Check_Library_Level_Entity
;
21842 procedure Process_Body
(Decl
: Node_Id
) is
21843 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21844 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
21847 -- Ignore pragma when applied to the special body created for
21848 -- inlining, recognized by its internal name _Parent.
21850 if Chars
(Body_Id
) = Name_uParent
then
21854 Check_Library_Level_Entity
(Body_Id
);
21856 -- For entry bodies, verify the legality against:
21857 -- * The mode of the context
21858 -- * The mode of the spec (if any)
21860 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
21862 -- A stand alone subprogram body
21864 if Body_Id
= Spec_Id
then
21865 Check_Pragma_Conformance
21866 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21868 Entity_Pragma
=> Empty
);
21870 -- An entry or subprogram body that completes a previous
21874 Check_Pragma_Conformance
21875 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21877 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21881 Set_SPARK_Pragma
(Body_Id
, N
);
21882 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21884 -- For package bodies, verify the legality against:
21885 -- * The mode of the context
21886 -- * The mode of the private part
21888 -- This case is separated from protected and task bodies
21889 -- because the statement part of the package body inherits
21890 -- the mode of the body declarations.
21892 elsif Nkind
(Decl
) = N_Package_Body
then
21893 Check_Pragma_Conformance
21894 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21896 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21899 Set_SPARK_Pragma
(Body_Id
, N
);
21900 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21901 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21902 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
21904 -- For protected and task bodies, verify the legality against:
21905 -- * The mode of the context
21906 -- * The mode of the private part
21910 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
21912 Check_Pragma_Conformance
21913 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21915 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21918 Set_SPARK_Pragma
(Body_Id
, N
);
21919 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21923 --------------------------
21924 -- Process_Overloadable --
21925 --------------------------
21927 procedure Process_Overloadable
(Decl
: Node_Id
) is
21928 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21929 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
21932 Check_Library_Level_Entity
(Spec_Id
);
21934 -- Verify the legality against:
21935 -- * The mode of the context
21937 Check_Pragma_Conformance
21938 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21940 Entity_Pragma
=> Empty
);
21942 Set_SPARK_Pragma
(Spec_Id
, N
);
21943 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21945 -- When the pragma applies to the anonymous object created for
21946 -- a single task type, decorate the type as well. This scenario
21947 -- arises when the single task type lacks a task definition,
21948 -- therefore there is no issue with respect to a potential
21949 -- pragma SPARK_Mode in the private part.
21951 -- task type Anon_Task_Typ;
21952 -- Obj : Anon_Task_Typ;
21953 -- pragma SPARK_Mode ...;
21955 if Is_Single_Task_Object
(Spec_Id
) then
21956 Set_SPARK_Pragma
(Spec_Typ
, N
);
21957 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
21958 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
21959 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
21961 end Process_Overloadable
;
21963 --------------------------
21964 -- Process_Private_Part --
21965 --------------------------
21967 procedure Process_Private_Part
(Decl
: Node_Id
) is
21968 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21971 Check_Library_Level_Entity
(Spec_Id
);
21973 -- Verify the legality against:
21974 -- * The mode of the visible declarations
21976 Check_Pragma_Conformance
21977 (Context_Pragma
=> Empty
,
21979 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21982 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21983 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
21984 end Process_Private_Part
;
21986 ----------------------------
21987 -- Process_Statement_Part --
21988 ----------------------------
21990 procedure Process_Statement_Part
(Decl
: Node_Id
) is
21991 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21994 Check_Library_Level_Entity
(Body_Id
);
21996 -- Verify the legality against:
21997 -- * The mode of the body declarations
21999 Check_Pragma_Conformance
22000 (Context_Pragma
=> Empty
,
22002 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
22005 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22006 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
22007 end Process_Statement_Part
;
22009 --------------------------
22010 -- Process_Visible_Part --
22011 --------------------------
22013 procedure Process_Visible_Part
(Decl
: Node_Id
) is
22014 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22015 Obj_Id
: Entity_Id
;
22018 Check_Library_Level_Entity
(Spec_Id
);
22020 -- Verify the legality against:
22021 -- * The mode of the context
22023 Check_Pragma_Conformance
22024 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22026 Entity_Pragma
=> Empty
);
22028 -- A task unit declared without a definition does not set the
22029 -- SPARK_Mode of the context because the task does not have any
22030 -- entries that could inherit the mode.
22032 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
22033 N_Task_Type_Declaration
)
22038 Set_SPARK_Pragma
(Spec_Id
, N
);
22039 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22040 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22041 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
22043 -- When the pragma applies to a single protected or task type,
22044 -- decorate the corresponding anonymous object as well.
22046 -- protected Anon_Prot_Typ is
22047 -- pragma SPARK_Mode ...;
22049 -- end Anon_Prot_Typ;
22051 -- Obj : Anon_Prot_Typ;
22053 if Is_Single_Concurrent_Type
(Spec_Id
) then
22054 Obj_Id
:= Anonymous_Object
(Spec_Id
);
22056 Set_SPARK_Pragma
(Obj_Id
, N
);
22057 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
22059 end Process_Visible_Part
;
22061 -----------------------
22062 -- Set_SPARK_Context --
22063 -----------------------
22065 procedure Set_SPARK_Context
is
22067 SPARK_Mode
:= Mode_Id
;
22068 SPARK_Mode_Pragma
:= N
;
22069 end Set_SPARK_Context
;
22077 -- Start of processing for Do_SPARK_Mode
22080 -- When a SPARK_Mode pragma appears inside an instantiation whose
22081 -- enclosing context has SPARK_Mode set to "off", the pragma has
22082 -- no semantic effect.
22084 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
22085 Rewrite
(N
, Make_Null_Statement
(Loc
));
22091 Check_No_Identifiers
;
22092 Check_At_Most_N_Arguments
(1);
22094 -- Check the legality of the mode (no argument = ON)
22096 if Arg_Count
= 1 then
22097 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22098 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
22103 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
22104 Context
:= Parent
(N
);
22106 -- The pragma appears in a configuration file
22108 if No
(Context
) then
22109 Check_Valid_Configuration_Pragma
;
22111 if Present
(SPARK_Mode_Pragma
) then
22114 Prev
=> SPARK_Mode_Pragma
);
22120 -- The pragma acts as a configuration pragma in a compilation unit
22122 -- pragma SPARK_Mode ...;
22123 -- package Pack is ...;
22125 elsif Nkind
(Context
) = N_Compilation_Unit
22126 and then List_Containing
(N
) = Context_Items
(Context
)
22128 Check_Valid_Configuration_Pragma
;
22131 -- Otherwise the placement of the pragma within the tree dictates
22132 -- its associated construct. Inspect the declarative list where
22133 -- the pragma resides to find a potential construct.
22137 while Present
(Stmt
) loop
22139 -- Skip prior pragmas, but check for duplicates. Note that
22140 -- this also takes care of pragmas generated for aspects.
22142 if Nkind
(Stmt
) = N_Pragma
then
22143 if Pragma_Name
(Stmt
) = Pname
then
22150 -- The pragma applies to an expression function that has
22151 -- already been rewritten into a subprogram declaration.
22153 -- function Expr_Func return ... is (...);
22154 -- pragma SPARK_Mode ...;
22156 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
22157 and then Nkind
(Original_Node
(Stmt
)) =
22158 N_Expression_Function
22160 Process_Overloadable
(Stmt
);
22163 -- The pragma applies to the anonymous object created for a
22164 -- single concurrent type.
22166 -- protected type Anon_Prot_Typ ...;
22167 -- Obj : Anon_Prot_Typ;
22168 -- pragma SPARK_Mode ...;
22170 elsif Nkind
(Stmt
) = N_Object_Declaration
22171 and then Is_Single_Concurrent_Object
22172 (Defining_Entity
(Stmt
))
22174 Process_Overloadable
(Stmt
);
22177 -- Skip internally generated code
22179 elsif not Comes_From_Source
(Stmt
) then
22182 -- The pragma applies to an entry or [generic] subprogram
22186 -- pragma SPARK_Mode ...;
22189 -- procedure Proc ...;
22190 -- pragma SPARK_Mode ...;
22192 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
22193 N_Subprogram_Declaration
)
22194 or else (Nkind
(Stmt
) = N_Entry_Declaration
22195 and then Is_Protected_Type
22196 (Scope
(Defining_Entity
(Stmt
))))
22198 Process_Overloadable
(Stmt
);
22201 -- Otherwise the pragma does not apply to a legal construct
22202 -- or it does not appear at the top of a declarative or a
22203 -- statement list. Issue an error and stop the analysis.
22213 -- The pragma applies to a package or a subprogram that acts as
22214 -- a compilation unit.
22216 -- procedure Proc ...;
22217 -- pragma SPARK_Mode ...;
22219 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
22220 Context
:= Unit
(Parent
(Context
));
22223 -- The pragma appears at the top of entry, package, protected
22224 -- unit, subprogram or task unit body declarations.
22226 -- entry Ent when ... is
22227 -- pragma SPARK_Mode ...;
22229 -- package body Pack is
22230 -- pragma SPARK_Mode ...;
22232 -- procedure Proc ... is
22233 -- pragma SPARK_Mode;
22235 -- protected body Prot is
22236 -- pragma SPARK_Mode ...;
22238 if Nkind_In
(Context
, N_Entry_Body
,
22244 Process_Body
(Context
);
22246 -- The pragma appears at the top of the visible or private
22247 -- declaration of a package spec, protected or task unit.
22250 -- pragma SPARK_Mode ...;
22252 -- pragma SPARK_Mode ...;
22254 -- protected [type] Prot is
22255 -- pragma SPARK_Mode ...;
22257 -- pragma SPARK_Mode ...;
22259 elsif Nkind_In
(Context
, N_Package_Specification
,
22260 N_Protected_Definition
,
22263 if List_Containing
(N
) = Visible_Declarations
(Context
) then
22264 Process_Visible_Part
(Parent
(Context
));
22266 Process_Private_Part
(Parent
(Context
));
22269 -- The pragma appears at the top of package body statements
22271 -- package body Pack is
22273 -- pragma SPARK_Mode;
22275 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
22276 and then Nkind
(Parent
(Context
)) = N_Package_Body
22278 Process_Statement_Part
(Parent
(Context
));
22280 -- The pragma appeared as an aspect of a [generic] subprogram
22281 -- declaration that acts as a compilation unit.
22284 -- procedure Proc ...;
22285 -- pragma SPARK_Mode ...;
22287 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
22288 N_Subprogram_Declaration
)
22290 Process_Overloadable
(Context
);
22292 -- The pragma does not apply to a legal construct, issue error
22300 --------------------------------
22301 -- Static_Elaboration_Desired --
22302 --------------------------------
22304 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
22306 when Pragma_Static_Elaboration_Desired
=>
22308 Check_At_Most_N_Arguments
(1);
22310 if Is_Compilation_Unit
(Current_Scope
)
22311 and then Ekind
(Current_Scope
) = E_Package
22313 Set_Static_Elaboration_Desired
(Current_Scope
, True);
22315 Error_Pragma
("pragma% must apply to a library-level package");
22322 -- pragma Storage_Size (EXPRESSION);
22324 when Pragma_Storage_Size
=> Storage_Size
: declare
22325 P
: constant Node_Id
:= Parent
(N
);
22329 Check_No_Identifiers
;
22330 Check_Arg_Count
(1);
22332 -- The expression must be analyzed in the special manner described
22333 -- in "Handling of Default Expressions" in sem.ads.
22335 Arg
:= Get_Pragma_Arg
(Arg1
);
22336 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22338 if not Is_OK_Static_Expression
(Arg
) then
22339 Check_Restriction
(Static_Storage_Size
, Arg
);
22342 if Nkind
(P
) /= N_Task_Definition
then
22347 if Has_Storage_Size_Pragma
(P
) then
22348 Error_Pragma
("duplicate pragma% not allowed");
22350 Set_Has_Storage_Size_Pragma
(P
, True);
22353 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
22361 -- pragma Storage_Unit (NUMERIC_LITERAL);
22363 -- Only permitted argument is System'Storage_Unit value
22365 when Pragma_Storage_Unit
=>
22366 Check_No_Identifiers
;
22367 Check_Arg_Count
(1);
22368 Check_Arg_Is_Integer_Literal
(Arg1
);
22370 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
22371 UI_From_Int
(Ttypes
.System_Storage_Unit
)
22373 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
22375 ("the only allowed argument for pragma% is ^", Arg1
);
22378 --------------------
22379 -- Stream_Convert --
22380 --------------------
22382 -- pragma Stream_Convert (
22383 -- [Entity =>] type_LOCAL_NAME,
22384 -- [Read =>] function_NAME,
22385 -- [Write =>] function NAME);
22387 when Pragma_Stream_Convert
=> Stream_Convert
: declare
22388 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
22389 -- Check that the given argument is the name of a local function
22390 -- of one argument that is not overloaded earlier in the current
22391 -- local scope. A check is also made that the argument is a
22392 -- function with one parameter.
22394 --------------------------------------
22395 -- Check_OK_Stream_Convert_Function --
22396 --------------------------------------
22398 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
22402 Check_Arg_Is_Local_Name
(Arg
);
22403 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
22405 if Has_Homonym
(Ent
) then
22407 ("argument for pragma% may not be overloaded", Arg
);
22410 if Ekind
(Ent
) /= E_Function
22411 or else No
(First_Formal
(Ent
))
22412 or else Present
(Next_Formal
(First_Formal
(Ent
)))
22415 ("argument for pragma% must be function of one argument",
22418 end Check_OK_Stream_Convert_Function
;
22420 -- Start of processing for Stream_Convert
22424 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
22425 Check_Arg_Count
(3);
22426 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22427 Check_Optional_Identifier
(Arg2
, Name_Read
);
22428 Check_Optional_Identifier
(Arg3
, Name_Write
);
22429 Check_Arg_Is_Local_Name
(Arg1
);
22430 Check_OK_Stream_Convert_Function
(Arg2
);
22431 Check_OK_Stream_Convert_Function
(Arg3
);
22434 Typ
: constant Entity_Id
:=
22435 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
22436 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
22437 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
22440 Check_First_Subtype
(Arg1
);
22442 -- Check for too early or too late. Note that we don't enforce
22443 -- the rule about primitive operations in this case, since, as
22444 -- is the case for explicit stream attributes themselves, these
22445 -- restrictions are not appropriate. Note that the chaining of
22446 -- the pragma by Rep_Item_Too_Late is actually the critical
22447 -- processing done for this pragma.
22449 if Rep_Item_Too_Early
(Typ
, N
)
22451 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
22456 -- Return if previous error
22458 if Etype
(Typ
) = Any_Type
22460 Etype
(Read
) = Any_Type
22462 Etype
(Write
) = Any_Type
22469 if Underlying_Type
(Etype
(Read
)) /= Typ
then
22471 ("incorrect return type for function&", Arg2
);
22474 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
22476 ("incorrect parameter type for function&", Arg3
);
22479 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
22480 Underlying_Type
(Etype
(Write
))
22483 ("result type of & does not match Read parameter type",
22487 end Stream_Convert
;
22493 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22495 -- This is processed by the parser since some of the style checks
22496 -- take place during source scanning and parsing. This means that
22497 -- we don't need to issue error messages here.
22499 when Pragma_Style_Checks
=> Style_Checks
: declare
22500 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22506 Check_No_Identifiers
;
22508 -- Two argument form
22510 if Arg_Count
= 2 then
22511 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22518 E_Id
:= Get_Pragma_Arg
(Arg2
);
22521 if not Is_Entity_Name
(E_Id
) then
22523 ("second argument of pragma% must be entity name",
22527 E
:= Entity
(E_Id
);
22529 if not Ignore_Style_Checks_Pragmas
then
22534 Set_Suppress_Style_Checks
22535 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
22536 exit when No
(Homonym
(E
));
22543 -- One argument form
22546 Check_Arg_Count
(1);
22548 if Nkind
(A
) = N_String_Literal
then
22552 Slen
: constant Natural := Natural (String_Length
(S
));
22553 Options
: String (1 .. Slen
);
22559 C
:= Get_String_Char
(S
, Pos
(J
));
22560 exit when not In_Character_Range
(C
);
22561 Options
(J
) := Get_Character
(C
);
22563 -- If at end of string, set options. As per discussion
22564 -- above, no need to check for errors, since we issued
22565 -- them in the parser.
22568 if not Ignore_Style_Checks_Pragmas
then
22569 Set_Style_Check_Options
(Options
);
22579 elsif Nkind
(A
) = N_Identifier
then
22580 if Chars
(A
) = Name_All_Checks
then
22581 if not Ignore_Style_Checks_Pragmas
then
22583 Set_GNAT_Style_Check_Options
;
22585 Set_Default_Style_Check_Options
;
22589 elsif Chars
(A
) = Name_On
then
22590 if not Ignore_Style_Checks_Pragmas
then
22591 Style_Check
:= True;
22594 elsif Chars
(A
) = Name_Off
then
22595 if not Ignore_Style_Checks_Pragmas
then
22596 Style_Check
:= False;
22607 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22609 when Pragma_Subtitle
=>
22611 Check_Arg_Count
(1);
22612 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
22613 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22620 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22622 when Pragma_Suppress
=>
22623 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
22629 -- pragma Suppress_All;
22631 -- The only check made here is that the pragma has no arguments.
22632 -- There are no placement rules, and the processing required (setting
22633 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22634 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22635 -- then creates and inserts a pragma Suppress (All_Checks).
22637 when Pragma_Suppress_All
=>
22639 Check_Arg_Count
(0);
22641 -------------------------
22642 -- Suppress_Debug_Info --
22643 -------------------------
22645 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22647 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
22648 Nam_Id
: Entity_Id
;
22652 Check_Arg_Count
(1);
22653 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22654 Check_Arg_Is_Local_Name
(Arg1
);
22656 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22658 -- A pragma that applies to a Ghost entity becomes Ghost for the
22659 -- purposes of legality checks and removal of ignored Ghost code.
22661 Mark_Ghost_Pragma
(N
, Nam_Id
);
22662 Set_Debug_Info_Off
(Nam_Id
);
22663 end Suppress_Debug_Info
;
22665 ----------------------------------
22666 -- Suppress_Exception_Locations --
22667 ----------------------------------
22669 -- pragma Suppress_Exception_Locations;
22671 when Pragma_Suppress_Exception_Locations
=>
22673 Check_Arg_Count
(0);
22674 Check_Valid_Configuration_Pragma
;
22675 Exception_Locations_Suppressed
:= True;
22677 -----------------------------
22678 -- Suppress_Initialization --
22679 -----------------------------
22681 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22683 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
22689 Check_Arg_Count
(1);
22690 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22691 Check_Arg_Is_Local_Name
(Arg1
);
22693 E_Id
:= Get_Pragma_Arg
(Arg1
);
22695 if Etype
(E_Id
) = Any_Type
then
22699 E
:= Entity
(E_Id
);
22701 -- A pragma that applies to a Ghost entity becomes Ghost for the
22702 -- purposes of legality checks and removal of ignored Ghost code.
22704 Mark_Ghost_Pragma
(N
, E
);
22706 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
22708 ("pragma% requires variable, type or subtype", Arg1
);
22711 if Rep_Item_Too_Early
(E
, N
)
22713 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
22718 -- For incomplete/private type, set flag on full view
22720 if Is_Incomplete_Or_Private_Type
(E
) then
22721 if No
(Full_View
(Base_Type
(E
))) then
22723 ("argument of pragma% cannot be an incomplete type", Arg1
);
22725 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
22728 -- For first subtype, set flag on base type
22730 elsif Is_First_Subtype
(E
) then
22731 Set_Suppress_Initialization
(Base_Type
(E
));
22733 -- For other than first subtype, set flag on subtype or variable
22736 Set_Suppress_Initialization
(E
);
22744 -- pragma System_Name (DIRECT_NAME);
22746 -- Syntax check: one argument, which must be the identifier GNAT or
22747 -- the identifier GCC, no other identifiers are acceptable.
22749 when Pragma_System_Name
=>
22751 Check_No_Identifiers
;
22752 Check_Arg_Count
(1);
22753 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
22755 -----------------------------
22756 -- Task_Dispatching_Policy --
22757 -----------------------------
22759 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22761 when Pragma_Task_Dispatching_Policy
=> declare
22765 Check_Ada_83_Warning
;
22766 Check_Arg_Count
(1);
22767 Check_No_Identifiers
;
22768 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22769 Check_Valid_Configuration_Pragma
;
22770 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22771 DP
:= Fold_Upper
(Name_Buffer
(1));
22773 if Task_Dispatching_Policy
/= ' '
22774 and then Task_Dispatching_Policy
/= DP
22776 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22778 ("task dispatching policy incompatible with policy#");
22780 -- Set new policy, but always preserve System_Location since we
22781 -- like the error message with the run time name.
22784 Task_Dispatching_Policy
:= DP
;
22786 if Task_Dispatching_Policy_Sloc
/= System_Location
then
22787 Task_Dispatching_Policy_Sloc
:= Loc
;
22796 -- pragma Task_Info (EXPRESSION);
22798 when Pragma_Task_Info
=> Task_Info
: declare
22799 P
: constant Node_Id
:= Parent
(N
);
22805 if Warn_On_Obsolescent_Feature
then
22807 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22808 & "instead?j?", N
);
22811 if Nkind
(P
) /= N_Task_Definition
then
22812 Error_Pragma
("pragma% must appear in task definition");
22815 Check_No_Identifiers
;
22816 Check_Arg_Count
(1);
22818 Analyze_And_Resolve
22819 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
22821 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
22825 Ent
:= Defining_Identifier
(Parent
(P
));
22827 -- Check duplicate pragma before we chain the pragma in the Rep
22828 -- Item chain of Ent.
22831 (Ent
, Name_Task_Info
, Check_Parents
=> False)
22833 Error_Pragma
("duplicate pragma% not allowed");
22836 Record_Rep_Item
(Ent
, N
);
22843 -- pragma Task_Name (string_EXPRESSION);
22845 when Pragma_Task_Name
=> Task_Name
: declare
22846 P
: constant Node_Id
:= Parent
(N
);
22851 Check_No_Identifiers
;
22852 Check_Arg_Count
(1);
22854 Arg
:= Get_Pragma_Arg
(Arg1
);
22856 -- The expression is used in the call to Create_Task, and must be
22857 -- expanded there, not in the context of the current spec. It must
22858 -- however be analyzed to capture global references, in case it
22859 -- appears in a generic context.
22861 Preanalyze_And_Resolve
(Arg
, Standard_String
);
22863 if Nkind
(P
) /= N_Task_Definition
then
22867 Ent
:= Defining_Identifier
(Parent
(P
));
22869 -- Check duplicate pragma before we chain the pragma in the Rep
22870 -- Item chain of Ent.
22873 (Ent
, Name_Task_Name
, Check_Parents
=> False)
22875 Error_Pragma
("duplicate pragma% not allowed");
22878 Record_Rep_Item
(Ent
, N
);
22885 -- pragma Task_Storage (
22886 -- [Task_Type =>] LOCAL_NAME,
22887 -- [Top_Guard =>] static_integer_EXPRESSION);
22889 when Pragma_Task_Storage
=> Task_Storage
: declare
22890 Args
: Args_List
(1 .. 2);
22891 Names
: constant Name_List
(1 .. 2) := (
22895 Task_Type
: Node_Id
renames Args
(1);
22896 Top_Guard
: Node_Id
renames Args
(2);
22902 Gather_Associations
(Names
, Args
);
22904 if No
(Task_Type
) then
22906 ("missing task_type argument for pragma%");
22909 Check_Arg_Is_Local_Name
(Task_Type
);
22911 Ent
:= Entity
(Task_Type
);
22913 if not Is_Task_Type
(Ent
) then
22915 ("argument for pragma% must be task type", Task_Type
);
22918 if No
(Top_Guard
) then
22920 ("pragma% takes two arguments", Task_Type
);
22922 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
22925 Check_First_Subtype
(Task_Type
);
22927 if Rep_Item_Too_Late
(Ent
, N
) then
22936 -- pragma Test_Case
22937 -- ([Name =>] Static_String_EXPRESSION
22938 -- ,[Mode =>] MODE_TYPE
22939 -- [, Requires => Boolean_EXPRESSION]
22940 -- [, Ensures => Boolean_EXPRESSION]);
22942 -- MODE_TYPE ::= Nominal | Robustness
22944 -- Characteristics:
22946 -- * Analysis - The annotation undergoes initial checks to verify
22947 -- the legal placement and context. Secondary checks preanalyze the
22950 -- Analyze_Test_Case_In_Decl_Part
22952 -- * Expansion - None.
22954 -- * Template - The annotation utilizes the generic template of the
22955 -- related subprogram when it is:
22957 -- aspect on subprogram declaration
22959 -- The annotation must prepare its own template when it is:
22961 -- pragma on subprogram declaration
22963 -- * Globals - Capture of global references must occur after full
22966 -- * Instance - The annotation is instantiated automatically when
22967 -- the related generic subprogram is instantiated except for the
22968 -- "pragma on subprogram declaration" case. In that scenario the
22969 -- annotation must instantiate itself.
22971 when Pragma_Test_Case
=> Test_Case
: declare
22972 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
22973 -- Ensure that the contract of subprogram Subp_Id does not contain
22974 -- another Test_Case pragma with the same Name as the current one.
22976 -------------------------
22977 -- Check_Distinct_Name --
22978 -------------------------
22980 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
22981 Items
: constant Node_Id
:= Contract
(Subp_Id
);
22982 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
22986 -- Inspect all Test_Case pragma of the related subprogram
22987 -- looking for one with a duplicate "Name" argument.
22989 if Present
(Items
) then
22990 Prag
:= Contract_Test_Cases
(Items
);
22991 while Present
(Prag
) loop
22992 if Pragma_Name
(Prag
) = Name_Test_Case
22994 and then String_Equal
22995 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
22997 Error_Msg_Sloc
:= Sloc
(Prag
);
22998 Error_Pragma
("name for pragma % is already used #");
23001 Prag
:= Next_Pragma
(Prag
);
23004 end Check_Distinct_Name
;
23008 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
23011 Subp_Decl
: Node_Id
;
23012 Subp_Id
: Entity_Id
;
23014 -- Start of processing for Test_Case
23018 Check_At_Least_N_Arguments
(2);
23019 Check_At_Most_N_Arguments
(4);
23021 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
23025 Check_Optional_Identifier
(Arg1
, Name_Name
);
23026 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23030 Check_Optional_Identifier
(Arg2
, Name_Mode
);
23031 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
23033 -- Arguments "Requires" and "Ensures"
23035 if Present
(Arg3
) then
23036 if Present
(Arg4
) then
23037 Check_Identifier
(Arg3
, Name_Requires
);
23038 Check_Identifier
(Arg4
, Name_Ensures
);
23040 Check_Identifier_Is_One_Of
23041 (Arg3
, Name_Requires
, Name_Ensures
);
23045 -- Pragma Test_Case must be associated with a subprogram declared
23046 -- in a library-level package. First determine whether the current
23047 -- compilation unit is a legal context.
23049 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
23050 N_Generic_Package_Declaration
)
23054 -- Otherwise the placement is illegal
23058 ("pragma % must be specified within a package declaration");
23062 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
23064 -- Find the enclosing context
23066 Context
:= Parent
(Subp_Decl
);
23068 if Present
(Context
) then
23069 Context
:= Parent
(Context
);
23072 -- Verify the placement of the pragma
23074 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23076 ("pragma % cannot be applied to abstract subprogram");
23079 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
23080 Error_Pragma
("pragma % cannot be applied to entry");
23083 -- The context is a [generic] subprogram declared at the top level
23084 -- of the [generic] package unit.
23086 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
23087 N_Subprogram_Declaration
)
23088 and then Present
(Context
)
23089 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
23090 N_Package_Declaration
)
23094 -- Otherwise the placement is illegal
23098 ("pragma % must be applied to a library-level subprogram "
23103 Subp_Id
:= Defining_Entity
(Subp_Decl
);
23105 -- A pragma that applies to a Ghost entity becomes Ghost for the
23106 -- purposes of legality checks and removal of ignored Ghost code.
23108 Mark_Ghost_Pragma
(N
, Subp_Id
);
23110 -- Chain the pragma on the contract for further processing by
23111 -- Analyze_Test_Case_In_Decl_Part.
23113 Add_Contract_Item
(N
, Subp_Id
);
23115 -- Preanalyze the original aspect argument "Name" for ASIS or for
23116 -- a generic subprogram to properly capture global references.
23118 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
23119 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
23121 if Present
(Asp_Arg
) then
23123 -- The argument appears with an identifier in association
23126 if Nkind
(Asp_Arg
) = N_Component_Association
then
23127 Asp_Arg
:= Expression
(Asp_Arg
);
23130 Check_Expr_Is_OK_Static_Expression
23131 (Asp_Arg
, Standard_String
);
23135 -- Ensure that the all Test_Case pragmas of the related subprogram
23136 -- have distinct names.
23138 Check_Distinct_Name
(Subp_Id
);
23140 -- Fully analyze the pragma when it appears inside an entry
23141 -- or subprogram body because it cannot benefit from forward
23144 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
23146 N_Subprogram_Body_Stub
)
23148 -- The legality checks of pragma Test_Case are affected by the
23149 -- SPARK mode in effect and the volatility of the context.
23150 -- Analyze all pragmas in a specific order.
23152 Analyze_If_Present
(Pragma_SPARK_Mode
);
23153 Analyze_If_Present
(Pragma_Volatile_Function
);
23154 Analyze_Test_Case_In_Decl_Part
(N
);
23158 --------------------------
23159 -- Thread_Local_Storage --
23160 --------------------------
23162 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
23164 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
23170 Check_Arg_Count
(1);
23171 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23172 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23174 Id
:= Get_Pragma_Arg
(Arg1
);
23177 if not Is_Entity_Name
(Id
)
23178 or else Ekind
(Entity
(Id
)) /= E_Variable
23180 Error_Pragma_Arg
("local variable name required", Arg1
);
23185 -- A pragma that applies to a Ghost entity becomes Ghost for the
23186 -- purposes of legality checks and removal of ignored Ghost code.
23188 Mark_Ghost_Pragma
(N
, E
);
23190 if Rep_Item_Too_Early
(E
, N
)
23192 Rep_Item_Too_Late
(E
, N
)
23197 Set_Has_Pragma_Thread_Local_Storage
(E
);
23198 Set_Has_Gigi_Rep_Item
(E
);
23199 end Thread_Local_Storage
;
23205 -- pragma Time_Slice (static_duration_EXPRESSION);
23207 when Pragma_Time_Slice
=> Time_Slice
: declare
23213 Check_Arg_Count
(1);
23214 Check_No_Identifiers
;
23215 Check_In_Main_Program
;
23216 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
23218 if not Error_Posted
(Arg1
) then
23220 while Present
(Nod
) loop
23221 if Nkind
(Nod
) = N_Pragma
23222 and then Pragma_Name
(Nod
) = Name_Time_Slice
23224 Error_Msg_Name_1
:= Pname
;
23225 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
23232 -- Process only if in main unit
23234 if Get_Source_Unit
(Loc
) = Main_Unit
then
23235 Opt
.Time_Slice_Set
:= True;
23236 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
23238 if Val
<= Ureal_0
then
23239 Opt
.Time_Slice_Value
:= 0;
23241 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
23242 Opt
.Time_Slice_Value
:= 1_000_000_000
;
23245 Opt
.Time_Slice_Value
:=
23246 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
23255 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
23257 -- TITLING_OPTION ::=
23258 -- [Title =>] STRING_LITERAL
23259 -- | [Subtitle =>] STRING_LITERAL
23261 when Pragma_Title
=> Title
: declare
23262 Args
: Args_List
(1 .. 2);
23263 Names
: constant Name_List
(1 .. 2) := (
23269 Gather_Associations
(Names
, Args
);
23272 for J
in 1 .. 2 loop
23273 if Present
(Args
(J
)) then
23274 Check_Arg_Is_OK_Static_Expression
23275 (Args
(J
), Standard_String
);
23280 ----------------------------
23281 -- Type_Invariant[_Class] --
23282 ----------------------------
23284 -- pragma Type_Invariant[_Class]
23285 -- ([Entity =>] type_LOCAL_NAME,
23286 -- [Check =>] EXPRESSION);
23288 when Pragma_Type_Invariant
23289 | Pragma_Type_Invariant_Class
23291 Type_Invariant
: declare
23292 I_Pragma
: Node_Id
;
23295 Check_Arg_Count
(2);
23297 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
23298 -- setting Class_Present for the Type_Invariant_Class case.
23300 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
23301 I_Pragma
:= New_Copy
(N
);
23302 Set_Pragma_Identifier
23303 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
23304 Rewrite
(N
, I_Pragma
);
23305 Set_Analyzed
(N
, False);
23307 end Type_Invariant
;
23309 ---------------------
23310 -- Unchecked_Union --
23311 ---------------------
23313 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
23315 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
23316 Assoc
: constant Node_Id
:= Arg1
;
23317 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
23327 Check_No_Identifiers
;
23328 Check_Arg_Count
(1);
23329 Check_Arg_Is_Local_Name
(Arg1
);
23331 Find_Type
(Type_Id
);
23333 Typ
:= Entity
(Type_Id
);
23335 -- A pragma that applies to a Ghost entity becomes Ghost for the
23336 -- purposes of legality checks and removal of ignored Ghost code.
23338 Mark_Ghost_Pragma
(N
, Typ
);
23341 or else Rep_Item_Too_Early
(Typ
, N
)
23345 Typ
:= Underlying_Type
(Typ
);
23348 if Rep_Item_Too_Late
(Typ
, N
) then
23352 Check_First_Subtype
(Arg1
);
23354 -- Note remaining cases are references to a type in the current
23355 -- declarative part. If we find an error, we post the error on
23356 -- the relevant type declaration at an appropriate point.
23358 if not Is_Record_Type
(Typ
) then
23359 Error_Msg_N
("unchecked union must be record type", Typ
);
23362 elsif Is_Tagged_Type
(Typ
) then
23363 Error_Msg_N
("unchecked union must not be tagged", Typ
);
23366 elsif not Has_Discriminants
(Typ
) then
23368 ("unchecked union must have one discriminant", Typ
);
23371 -- Note: in previous versions of GNAT we used to check for limited
23372 -- types and give an error, but in fact the standard does allow
23373 -- Unchecked_Union on limited types, so this check was removed.
23375 -- Similarly, GNAT used to require that all discriminants have
23376 -- default values, but this is not mandated by the RM.
23378 -- Proceed with basic error checks completed
23381 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
23382 Clist
:= Component_List
(Tdef
);
23384 -- Check presence of component list and variant part
23386 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
23388 ("unchecked union must have variant part", Tdef
);
23392 -- Check components
23394 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
23395 while Present
(Comp
) loop
23396 Check_Component
(Comp
, Typ
);
23397 Next_Non_Pragma
(Comp
);
23400 -- Check variant part
23402 Vpart
:= Variant_Part
(Clist
);
23404 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
23405 while Present
(Variant
) loop
23406 Check_Variant
(Variant
, Typ
);
23407 Next_Non_Pragma
(Variant
);
23411 Set_Is_Unchecked_Union
(Typ
);
23412 Set_Convention
(Typ
, Convention_C
);
23413 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
23414 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
23415 end Unchecked_Union
;
23417 ----------------------------
23418 -- Unevaluated_Use_Of_Old --
23419 ----------------------------
23421 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23423 when Pragma_Unevaluated_Use_Of_Old
=>
23425 Check_Arg_Count
(1);
23426 Check_No_Identifiers
;
23427 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
23429 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23430 -- a declarative part or a package spec.
23432 if not Is_Configuration_Pragma
then
23433 Check_Is_In_Decl_Part_Or_Package_Spec
;
23436 -- Store proper setting of Uneval_Old
23438 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23439 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
23441 ------------------------
23442 -- Unimplemented_Unit --
23443 ------------------------
23445 -- pragma Unimplemented_Unit;
23447 -- Note: this only gives an error if we are generating code, or if
23448 -- we are in a generic library unit (where the pragma appears in the
23449 -- body, not in the spec).
23451 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
23452 Cunitent
: constant Entity_Id
:=
23453 Cunit_Entity
(Get_Source_Unit
(Loc
));
23454 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
23458 Check_Arg_Count
(0);
23460 if Operating_Mode
= Generate_Code
23461 or else Ent_Kind
= E_Generic_Function
23462 or else Ent_Kind
= E_Generic_Procedure
23463 or else Ent_Kind
= E_Generic_Package
23465 Get_Name_String
(Chars
(Cunitent
));
23466 Set_Casing
(Mixed_Case
);
23467 Write_Str
(Name_Buffer
(1 .. Name_Len
));
23468 Write_Str
(" is not supported in this configuration");
23470 raise Unrecoverable_Error
;
23472 end Unimplemented_Unit
;
23474 ------------------------
23475 -- Universal_Aliasing --
23476 ------------------------
23478 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23480 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
23486 Check_Arg_Count
(1);
23487 Check_Optional_Identifier
(Arg2
, Name_Entity
);
23488 Check_Arg_Is_Local_Name
(Arg1
);
23489 E_Id
:= Get_Pragma_Arg
(Arg1
);
23491 if Etype
(E_Id
) = Any_Type
then
23495 E
:= Entity
(E_Id
);
23497 if not Is_Type
(E
) then
23498 Error_Pragma_Arg
("pragma% requires type", Arg1
);
23501 -- A pragma that applies to a Ghost entity becomes Ghost for the
23502 -- purposes of legality checks and removal of ignored Ghost code.
23504 Mark_Ghost_Pragma
(N
, E
);
23505 Set_Universal_Aliasing
(Base_Type
(E
));
23506 Record_Rep_Item
(E
, N
);
23507 end Universal_Alias
;
23509 --------------------
23510 -- Universal_Data --
23511 --------------------
23513 -- pragma Universal_Data [(library_unit_NAME)];
23515 when Pragma_Universal_Data
=>
23517 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
23523 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23525 when Pragma_Unmodified
=>
23526 Analyze_Unmodified_Or_Unused
;
23532 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23534 -- or when used in a context clause:
23536 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23538 when Pragma_Unreferenced
=>
23539 Analyze_Unreferenced_Or_Unused
;
23541 --------------------------
23542 -- Unreferenced_Objects --
23543 --------------------------
23545 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23547 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
23549 Arg_Expr
: Node_Id
;
23550 Arg_Id
: Entity_Id
;
23552 Ghost_Error_Posted
: Boolean := False;
23553 -- Flag set when an error concerning the illegal mix of Ghost and
23554 -- non-Ghost types is emitted.
23556 Ghost_Id
: Entity_Id
:= Empty
;
23557 -- The entity of the first Ghost type encountered while processing
23558 -- the arguments of the pragma.
23562 Check_At_Least_N_Arguments
(1);
23565 while Present
(Arg
) loop
23566 Check_No_Identifier
(Arg
);
23567 Check_Arg_Is_Local_Name
(Arg
);
23568 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
23570 if Is_Entity_Name
(Arg_Expr
) then
23571 Arg_Id
:= Entity
(Arg_Expr
);
23573 if Is_Type
(Arg_Id
) then
23574 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
23576 -- A pragma that applies to a Ghost entity becomes Ghost
23577 -- for the purposes of legality checks and removal of
23578 -- ignored Ghost code.
23580 Mark_Ghost_Pragma
(N
, Arg_Id
);
23582 -- Capture the entity of the first Ghost type being
23583 -- processed for error detection purposes.
23585 if Is_Ghost_Entity
(Arg_Id
) then
23586 if No
(Ghost_Id
) then
23587 Ghost_Id
:= Arg_Id
;
23590 -- Otherwise the type is non-Ghost. It is illegal to mix
23591 -- references to Ghost and non-Ghost entities
23594 elsif Present
(Ghost_Id
)
23595 and then not Ghost_Error_Posted
23597 Ghost_Error_Posted
:= True;
23599 Error_Msg_Name_1
:= Pname
;
23601 ("pragma % cannot mention ghost and non-ghost types",
23604 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
23605 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
23607 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
23608 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
23612 ("argument for pragma% must be type or subtype", Arg
);
23616 ("argument for pragma% must be type or subtype", Arg
);
23621 end Unreferenced_Objects
;
23623 ------------------------------
23624 -- Unreserve_All_Interrupts --
23625 ------------------------------
23627 -- pragma Unreserve_All_Interrupts;
23629 when Pragma_Unreserve_All_Interrupts
=>
23631 Check_Arg_Count
(0);
23633 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
23634 Unreserve_All_Interrupts
:= True;
23641 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23643 when Pragma_Unsuppress
=>
23645 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
23651 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23653 when Pragma_Unused
=>
23654 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
23655 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
23657 -------------------
23658 -- Use_VADS_Size --
23659 -------------------
23661 -- pragma Use_VADS_Size;
23663 when Pragma_Use_VADS_Size
=>
23665 Check_Arg_Count
(0);
23666 Check_Valid_Configuration_Pragma
;
23667 Use_VADS_Size
:= True;
23669 ---------------------
23670 -- Validity_Checks --
23671 ---------------------
23673 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23675 when Pragma_Validity_Checks
=> Validity_Checks
: declare
23676 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23682 Check_Arg_Count
(1);
23683 Check_No_Identifiers
;
23685 -- Pragma always active unless in CodePeer or GNATprove modes,
23686 -- which use a fixed configuration of validity checks.
23688 if not (CodePeer_Mode
or GNATprove_Mode
) then
23689 if Nkind
(A
) = N_String_Literal
then
23693 Slen
: constant Natural := Natural (String_Length
(S
));
23694 Options
: String (1 .. Slen
);
23698 -- Couldn't we use a for loop here over Options'Range???
23702 C
:= Get_String_Char
(S
, Pos
(J
));
23704 -- This is a weird test, it skips setting validity
23705 -- checks entirely if any element of S is out of
23706 -- range of Character, what is that about ???
23708 exit when not In_Character_Range
(C
);
23709 Options
(J
) := Get_Character
(C
);
23712 Set_Validity_Check_Options
(Options
);
23720 elsif Nkind
(A
) = N_Identifier
then
23721 if Chars
(A
) = Name_All_Checks
then
23722 Set_Validity_Check_Options
("a");
23723 elsif Chars
(A
) = Name_On
then
23724 Validity_Checks_On
:= True;
23725 elsif Chars
(A
) = Name_Off
then
23726 Validity_Checks_On
:= False;
23730 end Validity_Checks
;
23736 -- pragma Volatile (LOCAL_NAME);
23738 when Pragma_Volatile
=>
23739 Process_Atomic_Independent_Shared_Volatile
;
23741 -------------------------
23742 -- Volatile_Components --
23743 -------------------------
23745 -- pragma Volatile_Components (array_LOCAL_NAME);
23747 -- Volatile is handled by the same circuit as Atomic_Components
23749 --------------------------
23750 -- Volatile_Full_Access --
23751 --------------------------
23753 -- pragma Volatile_Full_Access (LOCAL_NAME);
23755 when Pragma_Volatile_Full_Access
=>
23757 Process_Atomic_Independent_Shared_Volatile
;
23759 -----------------------
23760 -- Volatile_Function --
23761 -----------------------
23763 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23765 when Pragma_Volatile_Function
=> Volatile_Function
: declare
23766 Over_Id
: Entity_Id
;
23767 Spec_Id
: Entity_Id
;
23768 Subp_Decl
: Node_Id
;
23772 Check_No_Identifiers
;
23773 Check_At_Most_N_Arguments
(1);
23776 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23778 -- Generic subprogram
23780 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23783 -- Body acts as spec
23785 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23786 and then No
(Corresponding_Spec
(Subp_Decl
))
23790 -- Body stub acts as spec
23792 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23793 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23799 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23807 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23809 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
23814 -- A pragma that applies to a Ghost entity becomes Ghost for the
23815 -- purposes of legality checks and removal of ignored Ghost code.
23817 Mark_Ghost_Pragma
(N
, Spec_Id
);
23819 -- Chain the pragma on the contract for completeness
23821 Add_Contract_Item
(N
, Spec_Id
);
23823 -- The legality checks of pragma Volatile_Function are affected by
23824 -- the SPARK mode in effect. Analyze all pragmas in a specific
23827 Analyze_If_Present
(Pragma_SPARK_Mode
);
23829 -- A volatile function cannot override a non-volatile function
23830 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23831 -- in New_Overloaded_Entity, however at that point the pragma has
23832 -- not been processed yet.
23834 Over_Id
:= Overridden_Operation
(Spec_Id
);
23836 if Present
(Over_Id
)
23837 and then not Is_Volatile_Function
(Over_Id
)
23840 ("incompatible volatile function values in effect", Spec_Id
);
23842 Error_Msg_Sloc
:= Sloc
(Over_Id
);
23844 ("\& declared # with Volatile_Function value False",
23847 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
23849 ("\overridden # with Volatile_Function value True",
23853 -- Analyze the Boolean expression (if any)
23855 if Present
(Arg1
) then
23856 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
23858 end Volatile_Function
;
23860 ----------------------
23861 -- Warning_As_Error --
23862 ----------------------
23864 -- pragma Warning_As_Error (static_string_EXPRESSION);
23866 when Pragma_Warning_As_Error
=>
23868 Check_Arg_Count
(1);
23869 Check_No_Identifiers
;
23870 Check_Valid_Configuration_Pragma
;
23872 if not Is_Static_String_Expression
(Arg1
) then
23874 ("argument of pragma% must be static string expression",
23877 -- OK static string expression
23880 Acquire_Warning_Match_String
(Arg1
);
23881 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
23882 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
23883 new String'(Name_Buffer (1 .. Name_Len));
23890 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23892 -- DETAILS ::= On | Off
23893 -- DETAILS ::= On | Off, local_NAME
23894 -- DETAILS ::= static_string_EXPRESSION
23895 -- DETAILS ::= On | Off, static_string_EXPRESSION
23897 -- TOOL_NAME ::= GNAT | GNATProve
23899 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23901 -- Note: If the first argument matches an allowed tool name, it is
23902 -- always considered to be a tool name, even if there is a string
23903 -- variable of that name.
23905 -- Note if the second argument of DETAILS is a local_NAME then the
23906 -- second form is always understood. If the intention is to use
23907 -- the fourth form, then you can write NAME & "" to force the
23908 -- intepretation as a static_string_EXPRESSION.
23910 when Pragma_Warnings => Warnings : declare
23911 Reason : String_Id;
23915 Check_At_Least_N_Arguments (1);
23917 -- See if last argument is labeled Reason. If so, make sure we
23918 -- have a string literal or a concatenation of string literals,
23919 -- and acquire the REASON string. Then remove the REASON argument
23920 -- by decreasing Num_Args by one; Remaining processing looks only
23921 -- at first Num_Args arguments).
23924 Last_Arg : constant Node_Id :=
23925 Last (Pragma_Argument_Associations (N));
23928 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23929 and then Chars (Last_Arg) = Name_Reason
23932 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23933 Reason := End_String;
23934 Arg_Count := Arg_Count - 1;
23936 -- Not allowed in compiler units (bootstrap issues)
23938 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23940 -- No REASON string, set null string as reason
23943 Reason := Null_String_Id;
23947 -- Now proceed with REASON taken care of and eliminated
23949 Check_No_Identifiers;
23951 -- If debug flag -gnatd.i is set, pragma is ignored
23953 if Debug_Flag_Dot_I then
23957 -- Process various forms of the pragma
23960 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23961 Shifted_Args : List_Id;
23964 -- See if first argument is a tool name, currently either
23965 -- GNAT or GNATprove. If so, either ignore the pragma if the
23966 -- tool used does not match, or continue as if no tool name
23967 -- was given otherwise, by shifting the arguments.
23969 if Nkind (Argx) = N_Identifier
23970 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23972 if Chars (Argx) = Name_Gnat then
23973 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23974 Rewrite (N, Make_Null_Statement (Loc));
23979 elsif Chars (Argx) = Name_Gnatprove then
23980 if not GNATprove_Mode then
23981 Rewrite (N, Make_Null_Statement (Loc));
23987 raise Program_Error;
23990 -- At this point, the pragma Warnings applies to the tool,
23991 -- so continue with shifted arguments.
23993 Arg_Count := Arg_Count - 1;
23995 if Arg_Count = 1 then
23996 Shifted_Args := New_List (New_Copy (Arg2));
23997 elsif Arg_Count = 2 then
23998 Shifted_Args := New_List (New_Copy (Arg2),
24000 elsif Arg_Count = 3 then
24001 Shifted_Args := New_List (New_Copy (Arg2),
24005 raise Program_Error;
24010 Chars => Name_Warnings,
24011 Pragma_Argument_Associations => Shifted_Args));
24016 -- One argument case
24018 if Arg_Count = 1 then
24020 -- On/Off one argument case was processed by parser
24022 if Nkind (Argx) = N_Identifier
24023 and then Nam_In (Chars (Argx), Name_On, Name_Off)
24027 -- One argument case must be ON/OFF or static string expr
24029 elsif not Is_Static_String_Expression (Arg1) then
24031 ("argument of pragma% must be On/Off or static string "
24032 & "expression", Arg1);
24034 -- One argument string expression case
24038 Lit : constant Node_Id := Expr_Value_S (Argx);
24039 Str : constant String_Id := Strval (Lit);
24040 Len : constant Nat := String_Length (Str);
24048 while J <= Len loop
24049 C := Get_String_Char (Str, J);
24050 OK := In_Character_Range (C);
24053 Chr := Get_Character (C);
24055 -- Dash case: only -Wxxx is accepted
24062 C := Get_String_Char (Str, J);
24063 Chr := Get_Character (C);
24064 exit when Chr = 'W
';
24069 elsif J < Len and then Chr = '.' then
24071 C := Get_String_Char (Str, J);
24072 Chr := Get_Character (C);
24074 if not Set_Dot_Warning_Switch (Chr) then
24076 ("invalid warning switch character "
24077 & '.' & Chr, Arg1);
24083 OK := Set_Warning_Switch (Chr);
24089 ("invalid warning switch character " & Chr,
24098 -- Two or more arguments (must be two)
24101 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24102 Check_Arg_Count (2);
24110 E_Id := Get_Pragma_Arg (Arg2);
24113 -- In the expansion of an inlined body, a reference to
24114 -- the formal may be wrapped in a conversion if the
24115 -- actual is a conversion. Retrieve the real entity name.
24117 if (In_Instance_Body or In_Inlined_Body)
24118 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
24120 E_Id := Expression (E_Id);
24123 -- Entity name case
24125 if Is_Entity_Name (E_Id) then
24126 E := Entity (E_Id);
24133 (E, (Chars (Get_Pragma_Arg (Arg1)) =
24136 -- For OFF case, make entry in warnings off
24137 -- pragma table for later processing. But we do
24138 -- not do that within an instance, since these
24139 -- warnings are about what is needed in the
24140 -- template, not an instance of it.
24142 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
24143 and then Warn_On_Warnings_Off
24144 and then not In_Instance
24146 Warnings_Off_Pragmas.Append ((N, E, Reason));
24149 if Is_Enumeration_Type (E) then
24153 Lit := First_Literal (E);
24154 while Present (Lit) loop
24155 Set_Warnings_Off (Lit);
24156 Next_Literal (Lit);
24161 exit when No (Homonym (E));
24166 -- Error if not entity or static string expression case
24168 elsif not Is_Static_String_Expression (Arg2) then
24170 ("second argument of pragma% must be entity name "
24171 & "or static string expression", Arg2);
24173 -- Static string expression case
24176 Acquire_Warning_Match_String (Arg2);
24178 -- Note on configuration pragma case: If this is a
24179 -- configuration pragma, then for an OFF pragma, we
24180 -- just set Config True in the call, which is all
24181 -- that needs to be done. For the case of ON, this
24182 -- is normally an error, unless it is canceling the
24183 -- effect of a previous OFF pragma in the same file.
24184 -- In any other case, an error will be signalled (ON
24185 -- with no matching OFF).
24187 -- Note: We set Used if we are inside a generic to
24188 -- disable the test that the non-config case actually
24189 -- cancels a warning. That's because we can't be sure
24190 -- there isn't an instantiation in some other unit
24191 -- where a warning is suppressed.
24193 -- We could do a little better here by checking if the
24194 -- generic unit we are inside is public, but for now
24195 -- we don't bother with that refinement.
24197 if Chars (Argx) = Name_Off then
24198 Set_Specific_Warning_Off
24199 (Loc, Name_Buffer (1 .. Name_Len), Reason,
24200 Config => Is_Configuration_Pragma,
24201 Used => Inside_A_Generic or else In_Instance);
24203 elsif Chars (Argx) = Name_On then
24204 Set_Specific_Warning_On
24205 (Loc, Name_Buffer (1 .. Name_Len), Err);
24209 ("??pragma Warnings On with no matching "
24210 & "Warnings Off", Loc);
24219 -------------------
24220 -- Weak_External --
24221 -------------------
24223 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
24225 when Pragma_Weak_External => Weak_External : declare
24230 Check_Arg_Count (1);
24231 Check_Optional_Identifier (Arg1, Name_Entity);
24232 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24233 Ent := Entity (Get_Pragma_Arg (Arg1));
24235 if Rep_Item_Too_Early (Ent, N) then
24238 Ent := Underlying_Type (Ent);
24241 -- The only processing required is to link this item on to the
24242 -- list of rep items for the given entity. This is accomplished
24243 -- by the call to Rep_Item_Too_Late (when no error is detected
24244 -- and False is returned).
24246 if Rep_Item_Too_Late (Ent, N) then
24249 Set_Has_Gigi_Rep_Item (Ent);
24253 -----------------------------
24254 -- Wide_Character_Encoding --
24255 -----------------------------
24257 -- pragma Wide_Character_Encoding (IDENTIFIER);
24259 when Pragma_Wide_Character_Encoding =>
24262 -- Nothing to do, handled in parser. Note that we do not enforce
24263 -- configuration pragma placement, this pragma can appear at any
24264 -- place in the source, allowing mixed encodings within a single
24269 --------------------
24270 -- Unknown_Pragma --
24271 --------------------
24273 -- Should be impossible, since the case of an unknown pragma is
24274 -- separately processed before the case statement is entered.
24276 when Unknown_Pragma =>
24277 raise Program_Error;
24280 -- AI05-0144: detect dangerous order dependence. Disabled for now,
24281 -- until AI is formally approved.
24283 -- Check_Order_Dependence;
24286 when Pragma_Exit => null;
24287 end Analyze_Pragma;
24289 ---------------------------------------------
24290 -- Analyze_Pre_Post_Condition_In_Decl_Part --
24291 ---------------------------------------------
24293 -- WARNING: This routine manages Ghost regions. Return statements must be
24294 -- replaced by gotos which jump to the end of the routine and restore the
24297 procedure Analyze_Pre_Post_Condition_In_Decl_Part
24299 Freeze_Id : Entity_Id := Empty)
24301 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24302 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24304 Disp_Typ : Entity_Id;
24305 -- The dispatching type of the subprogram subject to the pre- or
24308 function Check_References (Nod : Node_Id) return Traverse_Result;
24309 -- Check that expression Nod does not mention non-primitives of the
24310 -- type, global objects of the type, or other illegalities described
24311 -- and implied by AI12-0113.
24313 ----------------------
24314 -- Check_References --
24315 ----------------------
24317 function Check_References (Nod : Node_Id) return Traverse_Result is
24319 if Nkind (Nod) = N_Function_Call
24320 and then Is_Entity_Name (Name (Nod))
24323 Func : constant Entity_Id := Entity (Name (Nod));
24327 -- An operation of the type must be a primitive
24329 if No (Find_Dispatching_Type (Func)) then
24330 Form := First_Formal (Func);
24331 while Present (Form) loop
24332 if Etype (Form) = Disp_Typ then
24334 ("operation in class-wide condition must be "
24335 & "primitive of &", Nod, Disp_Typ);
24338 Next_Formal (Form);
24341 -- A return object of the type is illegal as well
24343 if Etype (Func) = Disp_Typ
24344 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24347 ("operation in class-wide condition must be primitive "
24348 & "of &", Nod, Disp_Typ);
24351 -- Otherwise we have a call to an overridden primitive, and we
24352 -- will create a common class-wide clone for the body of
24353 -- original operation and its eventual inherited versions. If
24354 -- the original operation dispatches on result it is never
24355 -- inherited and there is no need for a clone. There is not
24356 -- need for a clone either in GNATprove mode, as cases that
24357 -- would require it are rejected (when an inherited primitive
24358 -- calls an overridden operation in a class-wide contract), and
24359 -- the clone would make proof impossible in some cases.
24361 elsif not Is_Abstract_Subprogram (Spec_Id)
24362 and then No (Class_Wide_Clone (Spec_Id))
24363 and then not Has_Controlling_Result (Spec_Id)
24364 and then not GNATprove_Mode
24366 Build_Class_Wide_Clone_Decl (Spec_Id);
24370 elsif Is_Entity_Name (Nod)
24372 (Etype (Nod) = Disp_Typ
24373 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24374 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24377 ("object in class-wide condition must be formal of type &",
24380 elsif Nkind (Nod) = N_Explicit_Dereference
24381 and then (Etype (Nod) = Disp_Typ
24382 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24383 and then (not Is_Entity_Name (Prefix (Nod))
24384 or else not Is_Formal (Entity (Prefix (Nod))))
24387 ("operation in class-wide condition must be primitive of &",
24392 end Check_References;
24394 procedure Check_Class_Wide_Condition is
24395 new Traverse_Proc (Check_References);
24399 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24400 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24401 -- Save the Ghost mode to restore on exit
24404 Restore_Scope : Boolean := False;
24406 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24409 -- Do not analyze the pragma multiple times
24411 if Is_Analyzed_Pragma (N) then
24415 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24416 -- analysis of the pragma, the Ghost mode at point of declaration and
24417 -- point of analysis may not necessarily be the same. Use the mode in
24418 -- effect at the point of declaration.
24420 Set_Ghost_Mode (N);
24422 -- Ensure that the subprogram and its formals are visible when analyzing
24423 -- the expression of the pragma.
24425 if not In_Open_Scopes (Spec_Id) then
24426 Restore_Scope := True;
24427 Push_Scope (Spec_Id);
24429 if Is_Generic_Subprogram (Spec_Id) then
24430 Install_Generic_Formals (Spec_Id);
24432 Install_Formals (Spec_Id);
24436 Errors := Serious_Errors_Detected;
24437 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24439 -- Emit a clarification message when the expression contains at least
24440 -- one undefined reference, possibly due to contract "freezing".
24442 if Errors /= Serious_Errors_Detected
24443 and then Present (Freeze_Id)
24444 and then Has_Undefined_Reference (Expr)
24446 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24449 if Class_Present (N) then
24451 -- Verify that a class-wide condition is legal, i.e. the operation is
24452 -- a primitive of a tagged type. Note that a generic subprogram is
24453 -- not a primitive operation.
24455 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24457 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24458 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24460 if From_Aspect_Specification (N) then
24462 ("aspect % can only be specified for a primitive operation "
24463 & "of a tagged type", Corresponding_Aspect (N));
24465 -- The pragma is a source construct
24469 ("pragma % can only be specified for a primitive operation "
24470 & "of a tagged type", N);
24473 -- Remaining semantic checks require a full tree traversal
24476 Check_Class_Wide_Condition (Expr);
24481 if Restore_Scope then
24485 -- If analysis of the condition indicates that a class-wide clone
24486 -- has been created, build and analyze its declaration.
24488 if Is_Subprogram (Spec_Id)
24489 and then Present (Class_Wide_Clone (Spec_Id))
24491 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
24494 -- Currently it is not possible to inline pre/postconditions on a
24495 -- subprogram subject to pragma Inline_Always.
24497 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24498 Set_Is_Analyzed_Pragma (N);
24500 Restore_Ghost_Mode (Saved_GM);
24501 end Analyze_Pre_Post_Condition_In_Decl_Part;
24503 ------------------------------------------
24504 -- Analyze_Refined_Depends_In_Decl_Part --
24505 ------------------------------------------
24507 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24508 procedure Check_Dependency_Clause
24509 (Spec_Id : Entity_Id;
24510 Dep_Clause : Node_Id;
24511 Dep_States : Elist_Id;
24512 Refinements : List_Id;
24513 Matched_Items : in out Elist_Id);
24514 -- Try to match a single dependency clause Dep_Clause against one or
24515 -- more refinement clauses found in list Refinements. Each successful
24516 -- match eliminates at least one refinement clause from Refinements.
24517 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24518 -- denotes the entities of all abstract states which appear in pragma
24519 -- Depends. Matched_Items contains the entities of all successfully
24520 -- matched items found in pragma Depends.
24522 procedure Check_Output_States
24523 (Spec_Id : Entity_Id;
24524 Spec_Inputs : Elist_Id;
24525 Spec_Outputs : Elist_Id;
24526 Body_Inputs : Elist_Id;
24527 Body_Outputs : Elist_Id);
24528 -- Determine whether pragma Depends contains an output state with a
24529 -- visible refinement and if so, ensure that pragma Refined_Depends
24530 -- mentions all its constituents as outputs. Spec_Id is the entity of
24531 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24532 -- inputs and outputs of the subprogram spec synthesized from pragma
24533 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24534 -- of the subprogram body synthesized from pragma Refined_Depends.
24536 function Collect_States (Clauses : List_Id) return Elist_Id;
24537 -- Given a normalized list of dependencies obtained from calling
24538 -- Normalize_Clauses, return a list containing the entities of all
24539 -- states appearing in dependencies. It helps in checking refinements
24540 -- involving a state and a corresponding constituent which is not a
24541 -- direct constituent of the state.
24543 procedure Normalize_Clauses (Clauses : List_Id);
24544 -- Given a list of dependence or refinement clauses Clauses, normalize
24545 -- each clause by creating multiple dependencies with exactly one input
24548 procedure Remove_Extra_Clauses
24549 (Clauses : List_Id;
24550 Matched_Items : Elist_Id);
24551 -- Given a list of refinement clauses Clauses, remove all clauses whose
24552 -- inputs and/or outputs have been previously matched. See the body for
24553 -- all special cases. Matched_Items contains the entities of all matched
24554 -- items found in pragma Depends.
24556 procedure Report_Extra_Clauses
24557 (Spec_Id : Entity_Id;
24558 Clauses : List_Id);
24559 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24560 -- denotes the entity of the related subprogram.
24562 -----------------------------
24563 -- Check_Dependency_Clause --
24564 -----------------------------
24566 procedure Check_Dependency_Clause
24567 (Spec_Id : Entity_Id;
24568 Dep_Clause : Node_Id;
24569 Dep_States : Elist_Id;
24570 Refinements : List_Id;
24571 Matched_Items : in out Elist_Id)
24573 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24574 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24576 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24577 -- Determine whether dependency item Dep_Item has been matched in a
24578 -- previous clause.
24580 function Is_In_Out_State_Clause return Boolean;
24581 -- Determine whether dependence clause Dep_Clause denotes an abstract
24582 -- state that depends on itself (State => State).
24584 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24585 -- Determine whether item Item denotes an abstract state with visible
24586 -- null refinement.
24588 procedure Match_Items
24589 (Dep_Item : Node_Id;
24590 Ref_Item : Node_Id;
24591 Matched : out Boolean);
24592 -- Try to match dependence item Dep_Item against refinement item
24593 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24594 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24595 -- the following conformance scenarios is in effect:
24596 -- 1) Both items denote null
24597 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24598 -- 3) Both items denote attribute 'Result
24599 -- 4) Both items denote the same object
24600 -- 5) Both items denote the same formal parameter
24601 -- 6) Both items denote the same current instance of a type
24602 -- 7) Both items denote the same discriminant
24603 -- 8) Dep_Item is an abstract state with visible null refinement
24604 -- and Ref_Item denotes null.
24605 -- 9) Dep_Item is an abstract state with visible null refinement
24606 -- and Ref_Item is Empty (special case).
24607 -- 10) Dep_Item is an abstract state with full or partial visible
24608 -- non-null refinement and Ref_Item denotes one of its
24610 -- 11) Dep_Item is an abstract state without a full visible
24611 -- refinement and Ref_Item denotes the same state.
24612 -- When scenario 10 is in effect, the entity of the abstract state
24613 -- denoted by Dep_Item is added to list Refined_States.
24615 procedure Record_Item
(Item_Id
: Entity_Id
);
24616 -- Store the entity of an item denoted by Item_Id in Matched_Items
24618 ------------------------
24619 -- Is_Already_Matched --
24620 ------------------------
24622 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
24623 Item_Id
: Entity_Id
:= Empty
;
24626 -- When the dependency item denotes attribute 'Result, check for
24627 -- the entity of the related subprogram.
24629 if Is_Attribute_Result
(Dep_Item
) then
24630 Item_Id
:= Spec_Id
;
24632 elsif Is_Entity_Name
(Dep_Item
) then
24633 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24637 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
24638 end Is_Already_Matched
;
24640 ----------------------------
24641 -- Is_In_Out_State_Clause --
24642 ----------------------------
24644 function Is_In_Out_State_Clause
return Boolean is
24645 Dep_Input_Id
: Entity_Id
;
24646 Dep_Output_Id
: Entity_Id
;
24649 -- Detect the following clause:
24652 if Is_Entity_Name
(Dep_Input
)
24653 and then Is_Entity_Name
(Dep_Output
)
24655 -- Handle abstract views generated for limited with clauses
24657 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
24658 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
24661 Ekind
(Dep_Input_Id
) = E_Abstract_State
24662 and then Dep_Input_Id
= Dep_Output_Id
;
24666 end Is_In_Out_State_Clause
;
24668 ---------------------------
24669 -- Is_Null_Refined_State --
24670 ---------------------------
24672 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
24673 Item_Id
: Entity_Id
;
24676 if Is_Entity_Name
(Item
) then
24678 -- Handle abstract views generated for limited with clauses
24680 Item_Id
:= Available_View
(Entity_Of
(Item
));
24683 Ekind
(Item_Id
) = E_Abstract_State
24684 and then Has_Null_Visible_Refinement
(Item_Id
);
24688 end Is_Null_Refined_State
;
24694 procedure Match_Items
24695 (Dep_Item
: Node_Id
;
24696 Ref_Item
: Node_Id
;
24697 Matched
: out Boolean)
24699 Dep_Item_Id
: Entity_Id
;
24700 Ref_Item_Id
: Entity_Id
;
24703 -- Assume that the two items do not match
24707 -- A null matches null or Empty (special case)
24709 if Nkind
(Dep_Item
) = N_Null
24710 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24714 -- Attribute 'Result matches attribute 'Result
24716 elsif Is_Attribute_Result
(Dep_Item
)
24717 and then Is_Attribute_Result
(Ref_Item
)
24719 -- Put the entity of the related function on the list of
24720 -- matched items because attribute 'Result does not carry
24721 -- an entity similar to states and constituents.
24723 Record_Item
(Spec_Id
);
24726 -- Abstract states, current instances of concurrent types,
24727 -- discriminants, formal parameters and objects.
24729 elsif Is_Entity_Name
(Dep_Item
) then
24731 -- Handle abstract views generated for limited with clauses
24733 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24735 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
24737 -- An abstract state with visible null refinement matches
24738 -- null or Empty (special case).
24740 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
24741 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24743 Record_Item
(Dep_Item_Id
);
24746 -- An abstract state with visible non-null refinement
24747 -- matches one of its constituents, or itself for an
24748 -- abstract state with partial visible refinement.
24750 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
24751 if Is_Entity_Name
(Ref_Item
) then
24752 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
24754 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
24757 and then Present
(Encapsulating_State
(Ref_Item_Id
))
24758 and then Find_Encapsulating_State
24759 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
24761 Record_Item
(Dep_Item_Id
);
24764 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
24765 and then Ref_Item_Id
= Dep_Item_Id
24767 Record_Item
(Dep_Item_Id
);
24772 -- An abstract state without a visible refinement matches
24775 elsif Is_Entity_Name
(Ref_Item
)
24776 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24778 Record_Item
(Dep_Item_Id
);
24782 -- A current instance of a concurrent type, discriminant,
24783 -- formal parameter or an object matches itself.
24785 elsif Is_Entity_Name
(Ref_Item
)
24786 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24788 Record_Item
(Dep_Item_Id
);
24798 procedure Record_Item
(Item_Id
: Entity_Id
) is
24800 if No
(Matched_Items
) then
24801 Matched_Items
:= New_Elmt_List
;
24804 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
24809 Clause_Matched
: Boolean := False;
24810 Dummy
: Boolean := False;
24811 Inputs_Match
: Boolean;
24812 Next_Ref_Clause
: Node_Id
;
24813 Outputs_Match
: Boolean;
24814 Ref_Clause
: Node_Id
;
24815 Ref_Input
: Node_Id
;
24816 Ref_Output
: Node_Id
;
24818 -- Start of processing for Check_Dependency_Clause
24821 -- Do not perform this check in an instance because it was already
24822 -- performed successfully in the generic template.
24824 if Is_Generic_Instance
(Spec_Id
) then
24828 -- Examine all refinement clauses and compare them against the
24829 -- dependence clause.
24831 Ref_Clause
:= First
(Refinements
);
24832 while Present
(Ref_Clause
) loop
24833 Next_Ref_Clause
:= Next
(Ref_Clause
);
24835 -- Obtain the attributes of the current refinement clause
24837 Ref_Input
:= Expression
(Ref_Clause
);
24838 Ref_Output
:= First
(Choices
(Ref_Clause
));
24840 -- The current refinement clause matches the dependence clause
24841 -- when both outputs match and both inputs match. See routine
24842 -- Match_Items for all possible conformance scenarios.
24844 -- Depends Dep_Output => Dep_Input
24848 -- Refined_Depends Ref_Output => Ref_Input
24851 (Dep_Item
=> Dep_Input
,
24852 Ref_Item
=> Ref_Input
,
24853 Matched
=> Inputs_Match
);
24856 (Dep_Item
=> Dep_Output
,
24857 Ref_Item
=> Ref_Output
,
24858 Matched
=> Outputs_Match
);
24860 -- An In_Out state clause may be matched against a refinement with
24861 -- a null input or null output as long as the non-null side of the
24862 -- relation contains a valid constituent of the In_Out_State.
24864 if Is_In_Out_State_Clause
then
24866 -- Depends => (State => State)
24867 -- Refined_Depends => (null => Constit) -- OK
24870 and then not Outputs_Match
24871 and then Nkind
(Ref_Output
) = N_Null
24873 Outputs_Match
:= True;
24876 -- Depends => (State => State)
24877 -- Refined_Depends => (Constit => null) -- OK
24879 if not Inputs_Match
24880 and then Outputs_Match
24881 and then Nkind
(Ref_Input
) = N_Null
24883 Inputs_Match
:= True;
24887 -- The current refinement clause is legally constructed following
24888 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24889 -- the pool of candidates. The seach continues because a single
24890 -- dependence clause may have multiple matching refinements.
24892 if Inputs_Match
and Outputs_Match
then
24893 Clause_Matched
:= True;
24894 Remove
(Ref_Clause
);
24897 Ref_Clause
:= Next_Ref_Clause
;
24900 -- Depending on the order or composition of refinement clauses, an
24901 -- In_Out state clause may not be directly refinable.
24903 -- Refined_State => (State => (Constit_1, Constit_2))
24904 -- Depends => ((Output, State) => (Input, State))
24905 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24907 -- Matching normalized clause (State => State) fails because there is
24908 -- no direct refinement capable of satisfying this relation. Another
24909 -- similar case arises when clauses (Constit_1 => Input) and (Output
24910 -- => Constit_2) are matched first, leaving no candidates for clause
24911 -- (State => State). Both scenarios are legal as long as one of the
24912 -- previous clauses mentioned a valid constituent of State.
24914 if not Clause_Matched
24915 and then Is_In_Out_State_Clause
24916 and then Is_Already_Matched
(Dep_Input
)
24918 Clause_Matched
:= True;
24921 -- A clause where the input is an abstract state with visible null
24922 -- refinement or a 'Result attribute is implicitly matched when the
24923 -- output has already been matched in a previous clause.
24925 -- Refined_State => (State => null)
24926 -- Depends => (Output => State) -- implicitly OK
24927 -- Refined_Depends => (Output => ...)
24928 -- Depends => (...'Result => State) -- implicitly OK
24929 -- Refined_Depends => (...'Result => ...)
24931 if not Clause_Matched
24932 and then Is_Null_Refined_State
(Dep_Input
)
24933 and then Is_Already_Matched
(Dep_Output
)
24935 Clause_Matched
:= True;
24938 -- A clause where the output is an abstract state with visible null
24939 -- refinement is implicitly matched when the input has already been
24940 -- matched in a previous clause.
24942 -- Refined_State => (State => null)
24943 -- Depends => (State => Input) -- implicitly OK
24944 -- Refined_Depends => (... => Input)
24946 if not Clause_Matched
24947 and then Is_Null_Refined_State
(Dep_Output
)
24948 and then Is_Already_Matched
(Dep_Input
)
24950 Clause_Matched
:= True;
24953 -- At this point either all refinement clauses have been examined or
24954 -- pragma Refined_Depends contains a solitary null. Only an abstract
24955 -- state with null refinement can possibly match these cases.
24957 -- Refined_State => (State => null)
24958 -- Depends => (State => null)
24959 -- Refined_Depends => null -- OK
24961 if not Clause_Matched
then
24963 (Dep_Item
=> Dep_Input
,
24965 Matched
=> Inputs_Match
);
24968 (Dep_Item
=> Dep_Output
,
24970 Matched
=> Outputs_Match
);
24972 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
24975 -- If the contents of Refined_Depends are legal, then the current
24976 -- dependence clause should be satisfied either by an explicit match
24977 -- or by one of the special cases.
24979 if not Clause_Matched
then
24981 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
24982 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
24984 end Check_Dependency_Clause
;
24986 -------------------------
24987 -- Check_Output_States --
24988 -------------------------
24990 procedure Check_Output_States
24991 (Spec_Id
: Entity_Id
;
24992 Spec_Inputs
: Elist_Id
;
24993 Spec_Outputs
: Elist_Id
;
24994 Body_Inputs
: Elist_Id
;
24995 Body_Outputs
: Elist_Id
)
24997 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24998 -- Determine whether all constituents of state State_Id with full
24999 -- visible refinement are used as outputs in pragma Refined_Depends.
25000 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
25002 -----------------------------
25003 -- Check_Constituent_Usage --
25004 -----------------------------
25006 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25007 Constits
: constant Elist_Id
:=
25008 Partial_Refinement_Constituents
(State_Id
);
25009 Constit_Elmt
: Elmt_Id
;
25010 Constit_Id
: Entity_Id
;
25011 Only_Partial
: constant Boolean :=
25012 not Has_Visible_Refinement
(State_Id
);
25013 Posted
: Boolean := False;
25016 if Present
(Constits
) then
25017 Constit_Elmt
:= First_Elmt
(Constits
);
25018 while Present
(Constit_Elmt
) loop
25019 Constit_Id
:= Node
(Constit_Elmt
);
25021 -- Issue an error when a constituent of State_Id is used,
25022 -- and State_Id has only partial visible refinement
25023 -- (SPARK RM 7.2.4(3d)).
25025 if Only_Partial
then
25026 if (Present
(Body_Inputs
)
25027 and then Appears_In
(Body_Inputs
, Constit_Id
))
25029 (Present
(Body_Outputs
)
25030 and then Appears_In
(Body_Outputs
, Constit_Id
))
25032 Error_Msg_Name_1
:= Chars
(State_Id
);
25034 ("constituent & of state % cannot be used in "
25035 & "dependence refinement", N
, Constit_Id
);
25036 Error_Msg_Name_1
:= Chars
(State_Id
);
25037 SPARK_Msg_N
("\use state % instead", N
);
25040 -- The constituent acts as an input (SPARK RM 7.2.5(3))
25042 elsif Present
(Body_Inputs
)
25043 and then Appears_In
(Body_Inputs
, Constit_Id
)
25045 Error_Msg_Name_1
:= Chars
(State_Id
);
25047 ("constituent & of state % must act as output in "
25048 & "dependence refinement", N
, Constit_Id
);
25050 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25052 elsif No
(Body_Outputs
)
25053 or else not Appears_In
(Body_Outputs
, Constit_Id
)
25058 ("output state & must be replaced by all its "
25059 & "constituents in dependence refinement",
25064 ("\constituent & is missing in output list",
25068 Next_Elmt
(Constit_Elmt
);
25071 end Check_Constituent_Usage
;
25076 Item_Elmt
: Elmt_Id
;
25077 Item_Id
: Entity_Id
;
25079 -- Start of processing for Check_Output_States
25082 -- Do not perform this check in an instance because it was already
25083 -- performed successfully in the generic template.
25085 if Is_Generic_Instance
(Spec_Id
) then
25088 -- Inspect the outputs of pragma Depends looking for a state with a
25089 -- visible refinement.
25091 elsif Present
(Spec_Outputs
) then
25092 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
25093 while Present
(Item_Elmt
) loop
25094 Item
:= Node
(Item_Elmt
);
25096 -- Deal with the mixed nature of the input and output lists
25098 if Nkind
(Item
) = N_Defining_Identifier
then
25101 Item_Id
:= Available_View
(Entity_Of
(Item
));
25104 if Ekind
(Item_Id
) = E_Abstract_State
then
25106 -- The state acts as an input-output, skip it
25108 if Present
(Spec_Inputs
)
25109 and then Appears_In
(Spec_Inputs
, Item_Id
)
25113 -- Ensure that all of the constituents are utilized as
25114 -- outputs in pragma Refined_Depends.
25116 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25117 Check_Constituent_Usage
(Item_Id
);
25121 Next_Elmt
(Item_Elmt
);
25124 end Check_Output_States
;
25126 --------------------
25127 -- Collect_States --
25128 --------------------
25130 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
25131 procedure Collect_State
25133 States
: in out Elist_Id
);
25134 -- Add the entity of Item to list States when it denotes to a state
25136 -------------------
25137 -- Collect_State --
25138 -------------------
25140 procedure Collect_State
25142 States
: in out Elist_Id
)
25147 if Is_Entity_Name
(Item
) then
25148 Id
:= Entity_Of
(Item
);
25150 if Ekind
(Id
) = E_Abstract_State
then
25151 if No
(States
) then
25152 States
:= New_Elmt_List
;
25155 Append_Unique_Elmt
(Id
, States
);
25165 States
: Elist_Id
:= No_Elist
;
25167 -- Start of processing for Collect_States
25170 Clause
:= First
(Clauses
);
25171 while Present
(Clause
) loop
25172 Input
:= Expression
(Clause
);
25173 Output
:= First
(Choices
(Clause
));
25175 Collect_State
(Input
, States
);
25176 Collect_State
(Output
, States
);
25182 end Collect_States
;
25184 -----------------------
25185 -- Normalize_Clauses --
25186 -----------------------
25188 procedure Normalize_Clauses
(Clauses
: List_Id
) is
25189 procedure Normalize_Inputs
(Clause
: Node_Id
);
25190 -- Normalize clause Clause by creating multiple clauses for each
25191 -- input item of Clause. It is assumed that Clause has exactly one
25192 -- output. The transformation is as follows:
25194 -- Output => (Input_1, Input_2) -- original
25196 -- Output => Input_1 -- normalizations
25197 -- Output => Input_2
25199 procedure Normalize_Outputs
(Clause
: Node_Id
);
25200 -- Normalize clause Clause by creating multiple clause for each
25201 -- output item of Clause. The transformation is as follows:
25203 -- (Output_1, Output_2) => Input -- original
25205 -- Output_1 => Input -- normalization
25206 -- Output_2 => Input
25208 ----------------------
25209 -- Normalize_Inputs --
25210 ----------------------
25212 procedure Normalize_Inputs
(Clause
: Node_Id
) is
25213 Inputs
: constant Node_Id
:= Expression
(Clause
);
25214 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25215 Output
: constant List_Id
:= Choices
(Clause
);
25216 Last_Input
: Node_Id
;
25218 New_Clause
: Node_Id
;
25219 Next_Input
: Node_Id
;
25222 -- Normalization is performed only when the original clause has
25223 -- more than one input. Multiple inputs appear as an aggregate.
25225 if Nkind
(Inputs
) = N_Aggregate
then
25226 Last_Input
:= Last
(Expressions
(Inputs
));
25228 -- Create a new clause for each input
25230 Input
:= First
(Expressions
(Inputs
));
25231 while Present
(Input
) loop
25232 Next_Input
:= Next
(Input
);
25234 -- Unhook the current input from the original input list
25235 -- because it will be relocated to a new clause.
25239 -- Special processing for the last input. At this point the
25240 -- original aggregate has been stripped down to one element.
25241 -- Replace the aggregate by the element itself.
25243 if Input
= Last_Input
then
25244 Rewrite
(Inputs
, Input
);
25246 -- Generate a clause of the form:
25251 Make_Component_Association
(Loc
,
25252 Choices
=> New_Copy_List_Tree
(Output
),
25253 Expression
=> Input
);
25255 -- The new clause contains replicated content that has
25256 -- already been analyzed, mark the clause as analyzed.
25258 Set_Analyzed
(New_Clause
);
25259 Insert_After
(Clause
, New_Clause
);
25262 Input
:= Next_Input
;
25265 end Normalize_Inputs
;
25267 -----------------------
25268 -- Normalize_Outputs --
25269 -----------------------
25271 procedure Normalize_Outputs
(Clause
: Node_Id
) is
25272 Inputs
: constant Node_Id
:= Expression
(Clause
);
25273 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25274 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
25275 Last_Output
: Node_Id
;
25276 New_Clause
: Node_Id
;
25277 Next_Output
: Node_Id
;
25281 -- Multiple outputs appear as an aggregate. Nothing to do when
25282 -- the clause has exactly one output.
25284 if Nkind
(Outputs
) = N_Aggregate
then
25285 Last_Output
:= Last
(Expressions
(Outputs
));
25287 -- Create a clause for each output. Note that each time a new
25288 -- clause is created, the original output list slowly shrinks
25289 -- until there is one item left.
25291 Output
:= First
(Expressions
(Outputs
));
25292 while Present
(Output
) loop
25293 Next_Output
:= Next
(Output
);
25295 -- Unhook the output from the original output list as it
25296 -- will be relocated to a new clause.
25300 -- Special processing for the last output. At this point
25301 -- the original aggregate has been stripped down to one
25302 -- element. Replace the aggregate by the element itself.
25304 if Output
= Last_Output
then
25305 Rewrite
(Outputs
, Output
);
25308 -- Generate a clause of the form:
25309 -- (Output => Inputs)
25312 Make_Component_Association
(Loc
,
25313 Choices
=> New_List
(Output
),
25314 Expression
=> New_Copy_Tree
(Inputs
));
25316 -- The new clause contains replicated content that has
25317 -- already been analyzed. There is not need to reanalyze
25320 Set_Analyzed
(New_Clause
);
25321 Insert_After
(Clause
, New_Clause
);
25324 Output
:= Next_Output
;
25327 end Normalize_Outputs
;
25333 -- Start of processing for Normalize_Clauses
25336 Clause
:= First
(Clauses
);
25337 while Present
(Clause
) loop
25338 Normalize_Outputs
(Clause
);
25342 Clause
:= First
(Clauses
);
25343 while Present
(Clause
) loop
25344 Normalize_Inputs
(Clause
);
25347 end Normalize_Clauses
;
25349 --------------------------
25350 -- Remove_Extra_Clauses --
25351 --------------------------
25353 procedure Remove_Extra_Clauses
25354 (Clauses
: List_Id
;
25355 Matched_Items
: Elist_Id
)
25359 Input_Id
: Entity_Id
;
25360 Next_Clause
: Node_Id
;
25362 State_Id
: Entity_Id
;
25365 Clause
:= First
(Clauses
);
25366 while Present
(Clause
) loop
25367 Next_Clause
:= Next
(Clause
);
25369 Input
:= Expression
(Clause
);
25370 Output
:= First
(Choices
(Clause
));
25372 -- Recognize a clause of the form
25376 -- where Input is a constituent of a state which was already
25377 -- successfully matched. This clause must be removed because it
25378 -- simply indicates that some of the constituents of the state
25381 -- Refined_State => (State => (Constit_1, Constit_2))
25382 -- Depends => (Output => State)
25383 -- Refined_Depends => ((Output => Constit_1), -- State matched
25384 -- (null => Constit_2)) -- OK
25386 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
25388 -- Handle abstract views generated for limited with clauses
25390 Input_Id
:= Available_View
(Entity_Of
(Input
));
25392 -- The input must be a constituent of a state
25394 if Ekind_In
(Input_Id
, E_Abstract_State
,
25397 and then Present
(Encapsulating_State
(Input_Id
))
25399 State_Id
:= Encapsulating_State
(Input_Id
);
25401 -- The state must have a non-null visible refinement and be
25402 -- matched in a previous clause.
25404 if Has_Non_Null_Visible_Refinement
(State_Id
)
25405 and then Contains
(Matched_Items
, State_Id
)
25411 -- Recognize a clause of the form
25415 -- where Output is an arbitrary item. This clause must be removed
25416 -- because a null input legitimately matches anything.
25418 elsif Nkind
(Input
) = N_Null
then
25422 Clause
:= Next_Clause
;
25424 end Remove_Extra_Clauses
;
25426 --------------------------
25427 -- Report_Extra_Clauses --
25428 --------------------------
25430 procedure Report_Extra_Clauses
25431 (Spec_Id
: Entity_Id
;
25437 -- Do not perform this check in an instance because it was already
25438 -- performed successfully in the generic template.
25440 if Is_Generic_Instance
(Spec_Id
) then
25443 elsif Present
(Clauses
) then
25444 Clause
:= First
(Clauses
);
25445 while Present
(Clause
) loop
25447 ("unmatched or extra clause in dependence refinement",
25453 end Report_Extra_Clauses
;
25457 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25458 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25459 Errors
: constant Nat
:= Serious_Errors_Detected
;
25466 Body_Inputs
: Elist_Id
:= No_Elist
;
25467 Body_Outputs
: Elist_Id
:= No_Elist
;
25468 -- The inputs and outputs of the subprogram body synthesized from pragma
25469 -- Refined_Depends.
25471 Dependencies
: List_Id
:= No_List
;
25473 -- The corresponding Depends pragma along with its clauses
25475 Matched_Items
: Elist_Id
:= No_Elist
;
25476 -- A list containing the entities of all successfully matched items
25477 -- found in pragma Depends.
25479 Refinements
: List_Id
:= No_List
;
25480 -- The clauses of pragma Refined_Depends
25482 Spec_Id
: Entity_Id
;
25483 -- The entity of the subprogram subject to pragma Refined_Depends
25485 Spec_Inputs
: Elist_Id
:= No_Elist
;
25486 Spec_Outputs
: Elist_Id
:= No_Elist
;
25487 -- The inputs and outputs of the subprogram spec synthesized from pragma
25490 States
: Elist_Id
:= No_Elist
;
25491 -- A list containing the entities of all states whose constituents
25492 -- appear in pragma Depends.
25494 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25497 -- Do not analyze the pragma multiple times
25499 if Is_Analyzed_Pragma
(N
) then
25503 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25505 -- Use the anonymous object as the proper spec when Refined_Depends
25506 -- applies to the body of a single task type. The object carries the
25507 -- proper Chars as well as all non-refined versions of pragmas.
25509 if Is_Single_Concurrent_Type
(Spec_Id
) then
25510 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25513 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25515 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25516 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25518 if No
(Depends
) then
25520 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25521 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
25525 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25527 -- A null dependency relation renders the refinement useless because it
25528 -- cannot possibly mention abstract states with visible refinement. Note
25529 -- that the inverse is not true as states may be refined to null
25530 -- (SPARK RM 7.2.5(2)).
25532 if Nkind
(Deps
) = N_Null
then
25534 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25535 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
25539 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25540 -- This ensures that the categorization of all refined dependency items
25541 -- is consistent with their role.
25543 Analyze_Depends_In_Decl_Part
(N
);
25545 -- Do not match dependencies against refinements if Refined_Depends is
25546 -- illegal to avoid emitting misleading error.
25548 if Serious_Errors_Detected
= Errors
then
25550 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25551 -- the inputs and outputs of the subprogram spec and body to verify
25552 -- the use of states with visible refinement and their constituents.
25554 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
25555 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
25557 Collect_Subprogram_Inputs_Outputs
25558 (Subp_Id
=> Spec_Id
,
25559 Synthesize
=> True,
25560 Subp_Inputs
=> Spec_Inputs
,
25561 Subp_Outputs
=> Spec_Outputs
,
25562 Global_Seen
=> Dummy
);
25564 Collect_Subprogram_Inputs_Outputs
25565 (Subp_Id
=> Body_Id
,
25566 Synthesize
=> True,
25567 Subp_Inputs
=> Body_Inputs
,
25568 Subp_Outputs
=> Body_Outputs
,
25569 Global_Seen
=> Dummy
);
25571 -- For an output state with a visible refinement, ensure that all
25572 -- constituents appear as outputs in the dependency refinement.
25574 Check_Output_States
25575 (Spec_Id
=> Spec_Id
,
25576 Spec_Inputs
=> Spec_Inputs
,
25577 Spec_Outputs
=> Spec_Outputs
,
25578 Body_Inputs
=> Body_Inputs
,
25579 Body_Outputs
=> Body_Outputs
);
25582 -- Matching is disabled in ASIS because clauses are not normalized as
25583 -- this is a tree altering activity similar to expansion.
25589 -- Multiple dependency clauses appear as component associations of an
25590 -- aggregate. Note that the clauses are copied because the algorithm
25591 -- modifies them and this should not be visible in Depends.
25593 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
25594 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
25595 Normalize_Clauses
(Dependencies
);
25597 -- Gather all states which appear in Depends
25599 States
:= Collect_States
(Dependencies
);
25601 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
25603 if Nkind
(Refs
) = N_Null
then
25604 Refinements
:= No_List
;
25606 -- Multiple dependency clauses appear as component associations of an
25607 -- aggregate. Note that the clauses are copied because the algorithm
25608 -- modifies them and this should not be visible in Refined_Depends.
25610 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
25611 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
25612 Normalize_Clauses
(Refinements
);
25615 -- At this point the clauses of pragmas Depends and Refined_Depends
25616 -- have been normalized into simple dependencies between one output
25617 -- and one input. Examine all clauses of pragma Depends looking for
25618 -- matching clauses in pragma Refined_Depends.
25620 Clause
:= First
(Dependencies
);
25621 while Present
(Clause
) loop
25622 Check_Dependency_Clause
25623 (Spec_Id
=> Spec_Id
,
25624 Dep_Clause
=> Clause
,
25625 Dep_States
=> States
,
25626 Refinements
=> Refinements
,
25627 Matched_Items
=> Matched_Items
);
25632 -- Pragma Refined_Depends may contain multiple clarification clauses
25633 -- which indicate that certain constituents do not influence the data
25634 -- flow in any way. Such clauses must be removed as long as the state
25635 -- has been matched, otherwise they will be incorrectly flagged as
25638 -- Refined_State => (State => (Constit_1, Constit_2))
25639 -- Depends => (Output => State)
25640 -- Refined_Depends => ((Output => Constit_1), -- State matched
25641 -- (null => Constit_2)) -- must be removed
25643 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
25645 if Serious_Errors_Detected
= Errors
then
25646 Report_Extra_Clauses
(Spec_Id
, Refinements
);
25651 Set_Is_Analyzed_Pragma
(N
);
25652 end Analyze_Refined_Depends_In_Decl_Part
;
25654 -----------------------------------------
25655 -- Analyze_Refined_Global_In_Decl_Part --
25656 -----------------------------------------
25658 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
25660 -- The corresponding Global pragma
25662 Has_In_State
: Boolean := False;
25663 Has_In_Out_State
: Boolean := False;
25664 Has_Out_State
: Boolean := False;
25665 Has_Proof_In_State
: Boolean := False;
25666 -- These flags are set when the corresponding Global pragma has a state
25667 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25670 Has_Null_State
: Boolean := False;
25671 -- This flag is set when the corresponding Global pragma has at least
25672 -- one state with a null refinement.
25674 In_Constits
: Elist_Id
:= No_Elist
;
25675 In_Out_Constits
: Elist_Id
:= No_Elist
;
25676 Out_Constits
: Elist_Id
:= No_Elist
;
25677 Proof_In_Constits
: Elist_Id
:= No_Elist
;
25678 -- These lists contain the entities of all Input, In_Out, Output and
25679 -- Proof_In constituents that appear in Refined_Global and participate
25680 -- in state refinement.
25682 In_Items
: Elist_Id
:= No_Elist
;
25683 In_Out_Items
: Elist_Id
:= No_Elist
;
25684 Out_Items
: Elist_Id
:= No_Elist
;
25685 Proof_In_Items
: Elist_Id
:= No_Elist
;
25686 -- These lists contain the entities of all Input, In_Out, Output and
25687 -- Proof_In items defined in the corresponding Global pragma.
25689 Repeat_Items
: Elist_Id
:= No_Elist
;
25690 -- A list of all global items without full visible refinement found
25691 -- in pragma Global. These states should be repeated in the global
25692 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25693 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25695 Spec_Id
: Entity_Id
;
25696 -- The entity of the subprogram subject to pragma Refined_Global
25698 States
: Elist_Id
:= No_Elist
;
25699 -- A list of all states with full or partial visible refinement found in
25702 procedure Check_In_Out_States
;
25703 -- Determine whether the corresponding Global pragma mentions In_Out
25704 -- states with visible refinement and if so, ensure that one of the
25705 -- following completions apply to the constituents of the state:
25706 -- 1) there is at least one constituent of mode In_Out
25707 -- 2) there is at least one Input and one Output constituent
25708 -- 3) not all constituents are present and one of them is of mode
25710 -- This routine may remove elements from In_Constits, In_Out_Constits,
25711 -- Out_Constits and Proof_In_Constits.
25713 procedure Check_Input_States
;
25714 -- Determine whether the corresponding Global pragma mentions Input
25715 -- states with visible refinement and if so, ensure that at least one of
25716 -- its constituents appears as an Input item in Refined_Global.
25717 -- This routine may remove elements from In_Constits, In_Out_Constits,
25718 -- Out_Constits and Proof_In_Constits.
25720 procedure Check_Output_States
;
25721 -- Determine whether the corresponding Global pragma mentions Output
25722 -- states with visible refinement and if so, ensure that all of its
25723 -- constituents appear as Output items in Refined_Global.
25724 -- This routine may remove elements from In_Constits, In_Out_Constits,
25725 -- Out_Constits and Proof_In_Constits.
25727 procedure Check_Proof_In_States
;
25728 -- Determine whether the corresponding Global pragma mentions Proof_In
25729 -- states with visible refinement and if so, ensure that at least one of
25730 -- its constituents appears as a Proof_In item in Refined_Global.
25731 -- This routine may remove elements from In_Constits, In_Out_Constits,
25732 -- Out_Constits and Proof_In_Constits.
25734 procedure Check_Refined_Global_List
25736 Global_Mode
: Name_Id
:= Name_Input
);
25737 -- Verify the legality of a single global list declaration. Global_Mode
25738 -- denotes the current mode in effect.
25740 procedure Collect_Global_Items
25742 Mode
: Name_Id
:= Name_Input
);
25743 -- Gather all Input, In_Out, Output and Proof_In items from node List
25744 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25745 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25746 -- and Has_Proof_In_State are set when there is at least one abstract
25747 -- state with full or partial visible refinement available in the
25748 -- corresponding mode. Flag Has_Null_State is set when at least state
25749 -- has a null refinement. Mode denotes the current global mode in
25752 function Present_Then_Remove
25754 Item
: Entity_Id
) return Boolean;
25755 -- Search List for a particular entity Item. If Item has been found,
25756 -- remove it from List. This routine is used to strip lists In_Constits,
25757 -- In_Out_Constits and Out_Constits of valid constituents.
25759 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
25760 -- Same as function Present_Then_Remove, but do not report the presence
25761 -- of Item in List.
25763 procedure Report_Extra_Constituents
;
25764 -- Emit an error for each constituent found in lists In_Constits,
25765 -- In_Out_Constits and Out_Constits.
25767 procedure Report_Missing_Items
;
25768 -- Emit an error for each global item not repeated found in list
25771 -------------------------
25772 -- Check_In_Out_States --
25773 -------------------------
25775 procedure Check_In_Out_States
is
25776 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25777 -- Determine whether one of the following coverage scenarios is in
25779 -- 1) there is at least one constituent of mode In_Out or Output
25780 -- 2) there is at least one pair of constituents with modes Input
25781 -- and Output, or Proof_In and Output.
25782 -- 3) there is at least one constituent of mode Output and not all
25783 -- constituents are present.
25784 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25786 -----------------------------
25787 -- Check_Constituent_Usage --
25788 -----------------------------
25790 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25791 Constits
: constant Elist_Id
:=
25792 Partial_Refinement_Constituents
(State_Id
);
25793 Constit_Elmt
: Elmt_Id
;
25794 Constit_Id
: Entity_Id
;
25795 Has_Missing
: Boolean := False;
25796 In_Out_Seen
: Boolean := False;
25797 Input_Seen
: Boolean := False;
25798 Output_Seen
: Boolean := False;
25799 Proof_In_Seen
: Boolean := False;
25802 -- Process all the constituents of the state and note their modes
25803 -- within the global refinement.
25805 if Present
(Constits
) then
25806 Constit_Elmt
:= First_Elmt
(Constits
);
25807 while Present
(Constit_Elmt
) loop
25808 Constit_Id
:= Node
(Constit_Elmt
);
25810 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25811 Input_Seen
:= True;
25813 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
25814 In_Out_Seen
:= True;
25816 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25817 Output_Seen
:= True;
25819 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25821 Proof_In_Seen
:= True;
25824 Has_Missing
:= True;
25827 Next_Elmt
(Constit_Elmt
);
25831 -- An In_Out constituent is a valid completion
25833 if In_Out_Seen
then
25836 -- A pair of one Input/Proof_In and one Output constituent is a
25837 -- valid completion.
25839 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
25842 elsif Output_Seen
then
25844 -- A single Output constituent is a valid completion only when
25845 -- some of the other constituents are missing.
25847 if Has_Missing
then
25850 -- Otherwise all constituents are of mode Output
25854 ("global refinement of state & must include at least one "
25855 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
25859 -- The state lacks a completion. When full refinement is visible,
25860 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
25861 -- refinement is visible, emit an error if the abstract state
25862 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
25863 -- both are utilized, Check_State_And_Constituent_Use. will issue
25866 elsif not Input_Seen
25867 and then not In_Out_Seen
25868 and then not Output_Seen
25869 and then not Proof_In_Seen
25871 if Has_Visible_Refinement
(State_Id
)
25872 or else Contains
(Repeat_Items
, State_Id
)
25875 ("missing global refinement of state &", N
, State_Id
);
25878 -- Otherwise the state has a malformed completion where at least
25879 -- one of the constituents has a different mode.
25883 ("global refinement of state & redefines the mode of its "
25884 & "constituents", N
, State_Id
);
25886 end Check_Constituent_Usage
;
25890 Item_Elmt
: Elmt_Id
;
25891 Item_Id
: Entity_Id
;
25893 -- Start of processing for Check_In_Out_States
25896 -- Do not perform this check in an instance because it was already
25897 -- performed successfully in the generic template.
25899 if Is_Generic_Instance
(Spec_Id
) then
25902 -- Inspect the In_Out items of the corresponding Global pragma
25903 -- looking for a state with a visible refinement.
25905 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
25906 Item_Elmt
:= First_Elmt
(In_Out_Items
);
25907 while Present
(Item_Elmt
) loop
25908 Item_Id
:= Node
(Item_Elmt
);
25910 -- Ensure that one of the three coverage variants is satisfied
25912 if Ekind
(Item_Id
) = E_Abstract_State
25913 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25915 Check_Constituent_Usage
(Item_Id
);
25918 Next_Elmt
(Item_Elmt
);
25921 end Check_In_Out_States
;
25923 ------------------------
25924 -- Check_Input_States --
25925 ------------------------
25927 procedure Check_Input_States
is
25928 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25929 -- Determine whether at least one constituent of state State_Id with
25930 -- full or partial visible refinement is used and has mode Input.
25931 -- Ensure that the remaining constituents do not have In_Out or
25932 -- Output modes. Emit an error if this is not the case
25933 -- (SPARK RM 7.2.4(5)).
25935 -----------------------------
25936 -- Check_Constituent_Usage --
25937 -----------------------------
25939 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25940 Constits
: constant Elist_Id
:=
25941 Partial_Refinement_Constituents
(State_Id
);
25942 Constit_Elmt
: Elmt_Id
;
25943 Constit_Id
: Entity_Id
;
25944 In_Seen
: Boolean := False;
25947 if Present
(Constits
) then
25948 Constit_Elmt
:= First_Elmt
(Constits
);
25949 while Present
(Constit_Elmt
) loop
25950 Constit_Id
:= Node
(Constit_Elmt
);
25952 -- At least one of the constituents appears as an Input
25954 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25957 -- A Proof_In constituent can refine an Input state as long
25958 -- as there is at least one Input constituent present.
25960 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25964 -- The constituent appears in the global refinement, but has
25965 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25967 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25968 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25970 Error_Msg_Name_1
:= Chars
(State_Id
);
25972 ("constituent & of state % must have mode `Input` in "
25973 & "global refinement", N
, Constit_Id
);
25976 Next_Elmt
(Constit_Elmt
);
25980 -- Not one of the constituents appeared as Input. Always emit an
25981 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25982 -- When only partial refinement is visible, emit an error if the
25983 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25984 -- the case where both are utilized, an error will be issued in
25985 -- Check_State_And_Constituent_Use.
25988 and then (Has_Visible_Refinement
(State_Id
)
25989 or else Contains
(Repeat_Items
, State_Id
))
25992 ("global refinement of state & must include at least one "
25993 & "constituent of mode `Input`", N
, State_Id
);
25995 end Check_Constituent_Usage
;
25999 Item_Elmt
: Elmt_Id
;
26000 Item_Id
: Entity_Id
;
26002 -- Start of processing for Check_Input_States
26005 -- Do not perform this check in an instance because it was already
26006 -- performed successfully in the generic template.
26008 if Is_Generic_Instance
(Spec_Id
) then
26011 -- Inspect the Input items of the corresponding Global pragma looking
26012 -- for a state with a visible refinement.
26014 elsif Has_In_State
and then Present
(In_Items
) then
26015 Item_Elmt
:= First_Elmt
(In_Items
);
26016 while Present
(Item_Elmt
) loop
26017 Item_Id
:= Node
(Item_Elmt
);
26019 -- When full refinement is visible, ensure that at least one of
26020 -- the constituents is utilized and is of mode Input. When only
26021 -- partial refinement is visible, ensure that either one of
26022 -- the constituents is utilized and is of mode Input, or the
26023 -- abstract state is repeated and no constituent is utilized.
26025 if Ekind
(Item_Id
) = E_Abstract_State
26026 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26028 Check_Constituent_Usage
(Item_Id
);
26031 Next_Elmt
(Item_Elmt
);
26034 end Check_Input_States
;
26036 -------------------------
26037 -- Check_Output_States --
26038 -------------------------
26040 procedure Check_Output_States
is
26041 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26042 -- Determine whether all constituents of state State_Id with full
26043 -- visible refinement are used and have mode Output. Emit an error
26044 -- if this is not the case (SPARK RM 7.2.4(5)).
26046 -----------------------------
26047 -- Check_Constituent_Usage --
26048 -----------------------------
26050 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26051 Constits
: constant Elist_Id
:=
26052 Partial_Refinement_Constituents
(State_Id
);
26053 Only_Partial
: constant Boolean :=
26054 not Has_Visible_Refinement
(State_Id
);
26055 Constit_Elmt
: Elmt_Id
;
26056 Constit_Id
: Entity_Id
;
26057 Posted
: Boolean := False;
26060 if Present
(Constits
) then
26061 Constit_Elmt
:= First_Elmt
(Constits
);
26062 while Present
(Constit_Elmt
) loop
26063 Constit_Id
:= Node
(Constit_Elmt
);
26065 -- Issue an error when a constituent of State_Id is utilized
26066 -- and State_Id has only partial visible refinement
26067 -- (SPARK RM 7.2.4(3d)).
26069 if Only_Partial
then
26070 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
26071 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
26073 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26075 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26077 Error_Msg_Name_1
:= Chars
(State_Id
);
26079 ("constituent & of state % cannot be used in global "
26080 & "refinement", N
, Constit_Id
);
26081 Error_Msg_Name_1
:= Chars
(State_Id
);
26082 SPARK_Msg_N
("\use state % instead", N
);
26085 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26088 -- The constituent appears in the global refinement, but has
26089 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
26091 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26092 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26093 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26095 Error_Msg_Name_1
:= Chars
(State_Id
);
26097 ("constituent & of state % must have mode `Output` in "
26098 & "global refinement", N
, Constit_Id
);
26100 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26106 ("`Output` state & must be replaced by all its "
26107 & "constituents in global refinement", N
, State_Id
);
26111 ("\constituent & is missing in output list",
26115 Next_Elmt
(Constit_Elmt
);
26118 end Check_Constituent_Usage
;
26122 Item_Elmt
: Elmt_Id
;
26123 Item_Id
: Entity_Id
;
26125 -- Start of processing for Check_Output_States
26128 -- Do not perform this check in an instance because it was already
26129 -- performed successfully in the generic template.
26131 if Is_Generic_Instance
(Spec_Id
) then
26134 -- Inspect the Output items of the corresponding Global pragma
26135 -- looking for a state with a visible refinement.
26137 elsif Has_Out_State
and then Present
(Out_Items
) then
26138 Item_Elmt
:= First_Elmt
(Out_Items
);
26139 while Present
(Item_Elmt
) loop
26140 Item_Id
:= Node
(Item_Elmt
);
26142 -- When full refinement is visible, ensure that all of the
26143 -- constituents are utilized and they have mode Output. When
26144 -- only partial refinement is visible, ensure that no
26145 -- constituent is utilized.
26147 if Ekind
(Item_Id
) = E_Abstract_State
26148 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26150 Check_Constituent_Usage
(Item_Id
);
26153 Next_Elmt
(Item_Elmt
);
26156 end Check_Output_States
;
26158 ---------------------------
26159 -- Check_Proof_In_States --
26160 ---------------------------
26162 procedure Check_Proof_In_States
is
26163 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26164 -- Determine whether at least one constituent of state State_Id with
26165 -- full or partial visible refinement is used and has mode Proof_In.
26166 -- Ensure that the remaining constituents do not have Input, In_Out,
26167 -- or Output modes. Emit an error if this is not the case
26168 -- (SPARK RM 7.2.4(5)).
26170 -----------------------------
26171 -- Check_Constituent_Usage --
26172 -----------------------------
26174 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26175 Constits
: constant Elist_Id
:=
26176 Partial_Refinement_Constituents
(State_Id
);
26177 Constit_Elmt
: Elmt_Id
;
26178 Constit_Id
: Entity_Id
;
26179 Proof_In_Seen
: Boolean := False;
26182 if Present
(Constits
) then
26183 Constit_Elmt
:= First_Elmt
(Constits
);
26184 while Present
(Constit_Elmt
) loop
26185 Constit_Id
:= Node
(Constit_Elmt
);
26187 -- At least one of the constituents appears as Proof_In
26189 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
26190 Proof_In_Seen
:= True;
26192 -- The constituent appears in the global refinement, but has
26193 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
26195 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26196 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26197 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26199 Error_Msg_Name_1
:= Chars
(State_Id
);
26201 ("constituent & of state % must have mode `Proof_In` "
26202 & "in global refinement", N
, Constit_Id
);
26205 Next_Elmt
(Constit_Elmt
);
26209 -- Not one of the constituents appeared as Proof_In. Always emit
26210 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
26211 -- When only partial refinement is visible, emit an error if the
26212 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26213 -- the case where both are utilized, an error will be issued by
26214 -- Check_State_And_Constituent_Use.
26216 if not Proof_In_Seen
26217 and then (Has_Visible_Refinement
(State_Id
)
26218 or else Contains
(Repeat_Items
, State_Id
))
26221 ("global refinement of state & must include at least one "
26222 & "constituent of mode `Proof_In`", N
, State_Id
);
26224 end Check_Constituent_Usage
;
26228 Item_Elmt
: Elmt_Id
;
26229 Item_Id
: Entity_Id
;
26231 -- Start of processing for Check_Proof_In_States
26234 -- Do not perform this check in an instance because it was already
26235 -- performed successfully in the generic template.
26237 if Is_Generic_Instance
(Spec_Id
) then
26240 -- Inspect the Proof_In items of the corresponding Global pragma
26241 -- looking for a state with a visible refinement.
26243 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
26244 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
26245 while Present
(Item_Elmt
) loop
26246 Item_Id
:= Node
(Item_Elmt
);
26248 -- Ensure that at least one of the constituents is utilized
26249 -- and is of mode Proof_In. When only partial refinement is
26250 -- visible, ensure that either one of the constituents is
26251 -- utilized and is of mode Proof_In, or the abstract state
26252 -- is repeated and no constituent is utilized.
26254 if Ekind
(Item_Id
) = E_Abstract_State
26255 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26257 Check_Constituent_Usage
(Item_Id
);
26260 Next_Elmt
(Item_Elmt
);
26263 end Check_Proof_In_States
;
26265 -------------------------------
26266 -- Check_Refined_Global_List --
26267 -------------------------------
26269 procedure Check_Refined_Global_List
26271 Global_Mode
: Name_Id
:= Name_Input
)
26273 procedure Check_Refined_Global_Item
26275 Global_Mode
: Name_Id
);
26276 -- Verify the legality of a single global item declaration. Parameter
26277 -- Global_Mode denotes the current mode in effect.
26279 -------------------------------
26280 -- Check_Refined_Global_Item --
26281 -------------------------------
26283 procedure Check_Refined_Global_Item
26285 Global_Mode
: Name_Id
)
26287 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
26289 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
26290 -- Issue a common error message for all mode mismatches. Expect
26291 -- denotes the expected mode.
26293 -----------------------------
26294 -- Inconsistent_Mode_Error --
26295 -----------------------------
26297 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
26300 ("global item & has inconsistent modes", Item
, Item_Id
);
26302 Error_Msg_Name_1
:= Global_Mode
;
26303 Error_Msg_Name_2
:= Expect
;
26304 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
26305 end Inconsistent_Mode_Error
;
26309 Enc_State
: Entity_Id
:= Empty
;
26310 -- Encapsulating state for constituent, Empty otherwise
26312 -- Start of processing for Check_Refined_Global_Item
26315 if Ekind_In
(Item_Id
, E_Abstract_State
,
26319 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
26322 -- When the state or object acts as a constituent of another
26323 -- state with a visible refinement, collect it for the state
26324 -- completeness checks performed later on. Note that the item
26325 -- acts as a constituent only when the encapsulating state is
26326 -- present in pragma Global.
26328 if Present
(Enc_State
)
26329 and then (Has_Visible_Refinement
(Enc_State
)
26330 or else Has_Partial_Visible_Refinement
(Enc_State
))
26331 and then Contains
(States
, Enc_State
)
26333 -- If the state has only partial visible refinement, remove it
26334 -- from the list of items that should be repeated from pragma
26337 if not Has_Visible_Refinement
(Enc_State
) then
26338 Present_Then_Remove
(Repeat_Items
, Enc_State
);
26341 if Global_Mode
= Name_Input
then
26342 Append_New_Elmt
(Item_Id
, In_Constits
);
26344 elsif Global_Mode
= Name_In_Out
then
26345 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
26347 elsif Global_Mode
= Name_Output
then
26348 Append_New_Elmt
(Item_Id
, Out_Constits
);
26350 elsif Global_Mode
= Name_Proof_In
then
26351 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
26354 -- When not a constituent, ensure that both occurrences of the
26355 -- item in pragmas Global and Refined_Global match. Also remove
26356 -- it when present from the list of items that should be repeated
26357 -- from pragma Global.
26360 Present_Then_Remove
(Repeat_Items
, Item_Id
);
26362 if Contains
(In_Items
, Item_Id
) then
26363 if Global_Mode
/= Name_Input
then
26364 Inconsistent_Mode_Error
(Name_Input
);
26367 elsif Contains
(In_Out_Items
, Item_Id
) then
26368 if Global_Mode
/= Name_In_Out
then
26369 Inconsistent_Mode_Error
(Name_In_Out
);
26372 elsif Contains
(Out_Items
, Item_Id
) then
26373 if Global_Mode
/= Name_Output
then
26374 Inconsistent_Mode_Error
(Name_Output
);
26377 elsif Contains
(Proof_In_Items
, Item_Id
) then
26380 -- The item does not appear in the corresponding Global pragma,
26381 -- it must be an extra (SPARK RM 7.2.4(3)).
26384 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
26387 end Check_Refined_Global_Item
;
26393 -- Start of processing for Check_Refined_Global_List
26396 -- Do not perform this check in an instance because it was already
26397 -- performed successfully in the generic template.
26399 if Is_Generic_Instance
(Spec_Id
) then
26402 elsif Nkind
(List
) = N_Null
then
26405 -- Single global item declaration
26407 elsif Nkind_In
(List
, N_Expanded_Name
,
26409 N_Selected_Component
)
26411 Check_Refined_Global_Item
(List
, Global_Mode
);
26413 -- Simple global list or moded global list declaration
26415 elsif Nkind
(List
) = N_Aggregate
then
26417 -- The declaration of a simple global list appear as a collection
26420 if Present
(Expressions
(List
)) then
26421 Item
:= First
(Expressions
(List
));
26422 while Present
(Item
) loop
26423 Check_Refined_Global_Item
(Item
, Global_Mode
);
26427 -- The declaration of a moded global list appears as a collection
26428 -- of component associations where individual choices denote
26431 elsif Present
(Component_Associations
(List
)) then
26432 Item
:= First
(Component_Associations
(List
));
26433 while Present
(Item
) loop
26434 Check_Refined_Global_List
26435 (List
=> Expression
(Item
),
26436 Global_Mode
=> Chars
(First
(Choices
(Item
))));
26444 raise Program_Error
;
26450 raise Program_Error
;
26452 end Check_Refined_Global_List
;
26454 --------------------------
26455 -- Collect_Global_Items --
26456 --------------------------
26458 procedure Collect_Global_Items
26460 Mode
: Name_Id
:= Name_Input
)
26462 procedure Collect_Global_Item
26464 Item_Mode
: Name_Id
);
26465 -- Add a single item to the appropriate list. Item_Mode denotes the
26466 -- current mode in effect.
26468 -------------------------
26469 -- Collect_Global_Item --
26470 -------------------------
26472 procedure Collect_Global_Item
26474 Item_Mode
: Name_Id
)
26476 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
26477 -- The above handles abstract views of variables and states built
26478 -- for limited with clauses.
26481 -- Signal that the global list contains at least one abstract
26482 -- state with a visible refinement. Note that the refinement may
26483 -- be null in which case there are no constituents.
26485 if Ekind
(Item_Id
) = E_Abstract_State
then
26486 if Has_Null_Visible_Refinement
(Item_Id
) then
26487 Has_Null_State
:= True;
26489 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26490 Append_New_Elmt
(Item_Id
, States
);
26492 if Item_Mode
= Name_Input
then
26493 Has_In_State
:= True;
26494 elsif Item_Mode
= Name_In_Out
then
26495 Has_In_Out_State
:= True;
26496 elsif Item_Mode
= Name_Output
then
26497 Has_Out_State
:= True;
26498 elsif Item_Mode
= Name_Proof_In
then
26499 Has_Proof_In_State
:= True;
26504 -- Record global items without full visible refinement found in
26505 -- pragma Global which should be repeated in the global refinement
26506 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26508 if Ekind
(Item_Id
) /= E_Abstract_State
26509 or else not Has_Visible_Refinement
(Item_Id
)
26511 Append_New_Elmt
(Item_Id
, Repeat_Items
);
26514 -- Add the item to the proper list
26516 if Item_Mode
= Name_Input
then
26517 Append_New_Elmt
(Item_Id
, In_Items
);
26518 elsif Item_Mode
= Name_In_Out
then
26519 Append_New_Elmt
(Item_Id
, In_Out_Items
);
26520 elsif Item_Mode
= Name_Output
then
26521 Append_New_Elmt
(Item_Id
, Out_Items
);
26522 elsif Item_Mode
= Name_Proof_In
then
26523 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
26525 end Collect_Global_Item
;
26531 -- Start of processing for Collect_Global_Items
26534 if Nkind
(List
) = N_Null
then
26537 -- Single global item declaration
26539 elsif Nkind_In
(List
, N_Expanded_Name
,
26541 N_Selected_Component
)
26543 Collect_Global_Item
(List
, Mode
);
26545 -- Single global list or moded global list declaration
26547 elsif Nkind
(List
) = N_Aggregate
then
26549 -- The declaration of a simple global list appear as a collection
26552 if Present
(Expressions
(List
)) then
26553 Item
:= First
(Expressions
(List
));
26554 while Present
(Item
) loop
26555 Collect_Global_Item
(Item
, Mode
);
26559 -- The declaration of a moded global list appears as a collection
26560 -- of component associations where individual choices denote mode.
26562 elsif Present
(Component_Associations
(List
)) then
26563 Item
:= First
(Component_Associations
(List
));
26564 while Present
(Item
) loop
26565 Collect_Global_Items
26566 (List
=> Expression
(Item
),
26567 Mode
=> Chars
(First
(Choices
(Item
))));
26575 raise Program_Error
;
26578 -- To accommodate partial decoration of disabled SPARK features, this
26579 -- routine may be called with illegal input. If this is the case, do
26580 -- not raise Program_Error.
26585 end Collect_Global_Items
;
26587 -------------------------
26588 -- Present_Then_Remove --
26589 -------------------------
26591 function Present_Then_Remove
26593 Item
: Entity_Id
) return Boolean
26598 if Present
(List
) then
26599 Elmt
:= First_Elmt
(List
);
26600 while Present
(Elmt
) loop
26601 if Node
(Elmt
) = Item
then
26602 Remove_Elmt
(List
, Elmt
);
26611 end Present_Then_Remove
;
26613 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
26616 Ignore
:= Present_Then_Remove
(List
, Item
);
26617 end Present_Then_Remove
;
26619 -------------------------------
26620 -- Report_Extra_Constituents --
26621 -------------------------------
26623 procedure Report_Extra_Constituents
is
26624 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
26625 -- Emit an error for every element of List
26627 ---------------------------------------
26628 -- Report_Extra_Constituents_In_List --
26629 ---------------------------------------
26631 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
26632 Constit_Elmt
: Elmt_Id
;
26635 if Present
(List
) then
26636 Constit_Elmt
:= First_Elmt
(List
);
26637 while Present
(Constit_Elmt
) loop
26638 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
26639 Next_Elmt
(Constit_Elmt
);
26642 end Report_Extra_Constituents_In_List
;
26644 -- Start of processing for Report_Extra_Constituents
26647 -- Do not perform this check in an instance because it was already
26648 -- performed successfully in the generic template.
26650 if Is_Generic_Instance
(Spec_Id
) then
26654 Report_Extra_Constituents_In_List
(In_Constits
);
26655 Report_Extra_Constituents_In_List
(In_Out_Constits
);
26656 Report_Extra_Constituents_In_List
(Out_Constits
);
26657 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
26659 end Report_Extra_Constituents
;
26661 --------------------------
26662 -- Report_Missing_Items --
26663 --------------------------
26665 procedure Report_Missing_Items
is
26666 Item_Elmt
: Elmt_Id
;
26667 Item_Id
: Entity_Id
;
26670 -- Do not perform this check in an instance because it was already
26671 -- performed successfully in the generic template.
26673 if Is_Generic_Instance
(Spec_Id
) then
26677 if Present
(Repeat_Items
) then
26678 Item_Elmt
:= First_Elmt
(Repeat_Items
);
26679 while Present
(Item_Elmt
) loop
26680 Item_Id
:= Node
(Item_Elmt
);
26681 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
26682 Next_Elmt
(Item_Elmt
);
26686 end Report_Missing_Items
;
26690 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26691 Errors
: constant Nat
:= Serious_Errors_Detected
;
26693 No_Constit
: Boolean;
26695 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26698 -- Do not analyze the pragma multiple times
26700 if Is_Analyzed_Pragma
(N
) then
26704 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26706 -- Use the anonymous object as the proper spec when Refined_Global
26707 -- applies to the body of a single task type. The object carries the
26708 -- proper Chars as well as all non-refined versions of pragmas.
26710 if Is_Single_Concurrent_Type
(Spec_Id
) then
26711 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26714 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
26715 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
26717 -- The subprogram declaration lacks pragma Global. This renders
26718 -- Refined_Global useless as there is nothing to refine.
26720 if No
(Global
) then
26722 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26723 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
26727 -- Extract all relevant items from the corresponding Global pragma
26729 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26731 -- Package and subprogram bodies are instantiated individually in
26732 -- a separate compiler pass. Due to this mode of instantiation, the
26733 -- refinement of a state may no longer be visible when a subprogram
26734 -- body contract is instantiated. Since the generic template is legal,
26735 -- do not perform this check in the instance to circumvent this oddity.
26737 if Is_Generic_Instance
(Spec_Id
) then
26740 -- Non-instance case
26743 -- The corresponding Global pragma must mention at least one
26744 -- state with a visible refinement at the point Refined_Global
26745 -- is processed. States with null refinements need Refined_Global
26746 -- pragma (SPARK RM 7.2.4(2)).
26748 if not Has_In_State
26749 and then not Has_In_Out_State
26750 and then not Has_Out_State
26751 and then not Has_Proof_In_State
26752 and then not Has_Null_State
26755 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26756 & "depend on abstract state with visible refinement"),
26760 -- The global refinement of inputs and outputs cannot be null when
26761 -- the corresponding Global pragma contains at least one item except
26762 -- in the case where we have states with null refinements.
26764 elsif Nkind
(Items
) = N_Null
26766 (Present
(In_Items
)
26767 or else Present
(In_Out_Items
)
26768 or else Present
(Out_Items
)
26769 or else Present
(Proof_In_Items
))
26770 and then not Has_Null_State
26773 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
26774 & "global items"), N
, Spec_Id
);
26779 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26780 -- This ensures that the categorization of all refined global items is
26781 -- consistent with their role.
26783 Analyze_Global_In_Decl_Part
(N
);
26785 -- Perform all refinement checks with respect to completeness and mode
26788 if Serious_Errors_Detected
= Errors
then
26789 Check_Refined_Global_List
(Items
);
26792 -- Store the information that no constituent is used in the global
26793 -- refinement, prior to calling checking procedures which remove items
26794 -- from the list of constituents.
26798 and then No
(In_Out_Constits
)
26799 and then No
(Out_Constits
)
26800 and then No
(Proof_In_Constits
);
26802 -- For Input states with visible refinement, at least one constituent
26803 -- must be used as an Input in the global refinement.
26805 if Serious_Errors_Detected
= Errors
then
26806 Check_Input_States
;
26809 -- Verify all possible completion variants for In_Out states with
26810 -- visible refinement.
26812 if Serious_Errors_Detected
= Errors
then
26813 Check_In_Out_States
;
26816 -- For Output states with visible refinement, all constituents must be
26817 -- used as Outputs in the global refinement.
26819 if Serious_Errors_Detected
= Errors
then
26820 Check_Output_States
;
26823 -- For Proof_In states with visible refinement, at least one constituent
26824 -- must be used as Proof_In in the global refinement.
26826 if Serious_Errors_Detected
= Errors
then
26827 Check_Proof_In_States
;
26830 -- Emit errors for all constituents that belong to other states with
26831 -- visible refinement that do not appear in Global.
26833 if Serious_Errors_Detected
= Errors
then
26834 Report_Extra_Constituents
;
26837 -- Emit errors for all items in Global that are not repeated in the
26838 -- global refinement and for which there is no full visible refinement
26839 -- and, in the case of states with partial visible refinement, no
26840 -- constituent is mentioned in the global refinement.
26842 if Serious_Errors_Detected
= Errors
then
26843 Report_Missing_Items
;
26846 -- Emit an error if no constituent is used in the global refinement
26847 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
26848 -- one may be issued by the checking procedures. Do not perform this
26849 -- check in an instance because it was already performed successfully
26850 -- in the generic template.
26852 if Serious_Errors_Detected
= Errors
26853 and then not Is_Generic_Instance
(Spec_Id
)
26854 and then not Has_Null_State
26855 and then No_Constit
26857 SPARK_Msg_N
("missing refinement", N
);
26861 Set_Is_Analyzed_Pragma
(N
);
26862 end Analyze_Refined_Global_In_Decl_Part
;
26864 ----------------------------------------
26865 -- Analyze_Refined_State_In_Decl_Part --
26866 ----------------------------------------
26868 procedure Analyze_Refined_State_In_Decl_Part
26870 Freeze_Id
: Entity_Id
:= Empty
)
26872 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
26873 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26874 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
26876 Available_States
: Elist_Id
:= No_Elist
;
26877 -- A list of all abstract states defined in the package declaration that
26878 -- are available for refinement. The list is used to report unrefined
26881 Body_States
: Elist_Id
:= No_Elist
;
26882 -- A list of all hidden states that appear in the body of the related
26883 -- package. The list is used to report unused hidden states.
26885 Constituents_Seen
: Elist_Id
:= No_Elist
;
26886 -- A list that contains all constituents processed so far. The list is
26887 -- used to detect multiple uses of the same constituent.
26889 Freeze_Posted
: Boolean := False;
26890 -- A flag that controls the output of a freezing-related error (see use
26893 Refined_States_Seen
: Elist_Id
:= No_Elist
;
26894 -- A list that contains all refined states processed so far. The list is
26895 -- used to detect duplicate refinements.
26897 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
26898 -- Perform full analysis of a single refinement clause
26900 procedure Report_Unrefined_States
(States
: Elist_Id
);
26901 -- Emit errors for all unrefined abstract states found in list States
26903 -------------------------------
26904 -- Analyze_Refinement_Clause --
26905 -------------------------------
26907 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
26908 AR_Constit
: Entity_Id
:= Empty
;
26909 AW_Constit
: Entity_Id
:= Empty
;
26910 ER_Constit
: Entity_Id
:= Empty
;
26911 EW_Constit
: Entity_Id
:= Empty
;
26912 -- The entities of external constituents that contain one of the
26913 -- following enabled properties: Async_Readers, Async_Writers,
26914 -- Effective_Reads and Effective_Writes.
26916 External_Constit_Seen
: Boolean := False;
26917 -- Flag used to mark when at least one external constituent is part
26918 -- of the state refinement.
26920 Non_Null_Seen
: Boolean := False;
26921 Null_Seen
: Boolean := False;
26922 -- Flags used to detect multiple uses of null in a single clause or a
26923 -- mixture of null and non-null constituents.
26925 Part_Of_Constits
: Elist_Id
:= No_Elist
;
26926 -- A list of all candidate constituents subject to indicator Part_Of
26927 -- where the encapsulating state is the current state.
26930 State_Id
: Entity_Id
;
26931 -- The current state being refined
26933 procedure Analyze_Constituent
(Constit
: Node_Id
);
26934 -- Perform full analysis of a single constituent
26936 procedure Check_External_Property
26937 (Prop_Nam
: Name_Id
;
26939 Constit
: Entity_Id
);
26940 -- Determine whether a property denoted by name Prop_Nam is present
26941 -- in the refined state. Emit an error if this is not the case. Flag
26942 -- Enabled should be set when the property applies to the refined
26943 -- state. Constit denotes the constituent (if any) which introduces
26944 -- the property in the refinement.
26946 procedure Match_State
;
26947 -- Determine whether the state being refined appears in list
26948 -- Available_States. Emit an error when attempting to re-refine the
26949 -- state or when the state is not defined in the package declaration,
26950 -- otherwise remove the state from Available_States.
26952 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
26953 -- Emit errors for all unused Part_Of constituents in list Constits
26955 -------------------------
26956 -- Analyze_Constituent --
26957 -------------------------
26959 procedure Analyze_Constituent
(Constit
: Node_Id
) is
26960 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
26961 -- Determine whether constituent Constit denoted by its entity
26962 -- Constit_Id appears in Body_States. Emit an error when the
26963 -- constituent is not a valid hidden state of the related package
26964 -- or when it is used more than once. Otherwise remove the
26965 -- constituent from Body_States.
26967 -----------------------
26968 -- Match_Constituent --
26969 -----------------------
26971 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
26972 procedure Collect_Constituent
;
26973 -- Verify the legality of constituent Constit_Id and add it to
26974 -- the refinements of State_Id.
26976 -------------------------
26977 -- Collect_Constituent --
26978 -------------------------
26980 procedure Collect_Constituent
is
26981 Constits
: Elist_Id
;
26984 -- The Ghost policy in effect at the point of abstract state
26985 -- declaration and constituent must match (SPARK RM 6.9(15))
26987 Check_Ghost_Refinement
26988 (State
, State_Id
, Constit
, Constit_Id
);
26990 -- A synchronized state must be refined by a synchronized
26991 -- object or another synchronized state (SPARK RM 9.6).
26993 if Is_Synchronized_State
(State_Id
)
26994 and then not Is_Synchronized_Object
(Constit_Id
)
26995 and then not Is_Synchronized_State
(Constit_Id
)
26998 ("constituent of synchronized state & must be "
26999 & "synchronized", Constit
, State_Id
);
27002 -- Add the constituent to the list of processed items to aid
27003 -- with the detection of duplicates.
27005 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
27007 -- Collect the constituent in the list of refinement items
27008 -- and establish a relation between the refined state and
27011 Constits
:= Refinement_Constituents
(State_Id
);
27013 if No
(Constits
) then
27014 Constits
:= New_Elmt_List
;
27015 Set_Refinement_Constituents
(State_Id
, Constits
);
27018 Append_Elmt
(Constit_Id
, Constits
);
27019 Set_Encapsulating_State
(Constit_Id
, State_Id
);
27021 -- The state has at least one legal constituent, mark the
27022 -- start of the refinement region. The region ends when the
27023 -- body declarations end (see routine Analyze_Declarations).
27025 Set_Has_Visible_Refinement
(State_Id
);
27027 -- When the constituent is external, save its relevant
27028 -- property for further checks.
27030 if Async_Readers_Enabled
(Constit_Id
) then
27031 AR_Constit
:= Constit_Id
;
27032 External_Constit_Seen
:= True;
27035 if Async_Writers_Enabled
(Constit_Id
) then
27036 AW_Constit
:= Constit_Id
;
27037 External_Constit_Seen
:= True;
27040 if Effective_Reads_Enabled
(Constit_Id
) then
27041 ER_Constit
:= Constit_Id
;
27042 External_Constit_Seen
:= True;
27045 if Effective_Writes_Enabled
(Constit_Id
) then
27046 EW_Constit
:= Constit_Id
;
27047 External_Constit_Seen
:= True;
27049 end Collect_Constituent
;
27053 State_Elmt
: Elmt_Id
;
27055 -- Start of processing for Match_Constituent
27058 -- Detect a duplicate use of a constituent
27060 if Contains
(Constituents_Seen
, Constit_Id
) then
27062 ("duplicate use of constituent &", Constit
, Constit_Id
);
27066 -- The constituent is subject to a Part_Of indicator
27068 if Present
(Encapsulating_State
(Constit_Id
)) then
27069 if Encapsulating_State
(Constit_Id
) = State_Id
then
27070 Remove
(Part_Of_Constits
, Constit_Id
);
27071 Collect_Constituent
;
27073 -- The constituent is part of another state and is used
27074 -- incorrectly in the refinement of the current state.
27077 Error_Msg_Name_1
:= Chars
(State_Id
);
27079 ("& cannot act as constituent of state %",
27080 Constit
, Constit_Id
);
27082 ("\Part_Of indicator specifies encapsulator &",
27083 Constit
, Encapsulating_State
(Constit_Id
));
27086 -- The only other source of legal constituents is the body
27087 -- state space of the related package.
27090 if Present
(Body_States
) then
27091 State_Elmt
:= First_Elmt
(Body_States
);
27092 while Present
(State_Elmt
) loop
27094 -- Consume a valid constituent to signal that it has
27095 -- been encountered.
27097 if Node
(State_Elmt
) = Constit_Id
then
27098 Remove_Elmt
(Body_States
, State_Elmt
);
27099 Collect_Constituent
;
27103 Next_Elmt
(State_Elmt
);
27107 -- Constants are part of the hidden state of a package, but
27108 -- the compiler cannot determine whether they have variable
27109 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
27110 -- hidden state. Accept the constant quietly even if it is
27111 -- a visible state or lacks a Part_Of indicator.
27113 if Ekind
(Constit_Id
) = E_Constant
then
27114 Collect_Constituent
;
27116 -- If we get here, then the constituent is not a hidden
27117 -- state of the related package and may not be used in a
27118 -- refinement (SPARK RM 7.2.2(9)).
27121 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27123 ("cannot use & in refinement, constituent is not a "
27124 & "hidden state of package %", Constit
, Constit_Id
);
27127 end Match_Constituent
;
27131 Constit_Id
: Entity_Id
;
27132 Constits
: Elist_Id
;
27134 -- Start of processing for Analyze_Constituent
27137 -- Detect multiple uses of null in a single refinement clause or a
27138 -- mixture of null and non-null constituents.
27140 if Nkind
(Constit
) = N_Null
then
27143 ("multiple null constituents not allowed", Constit
);
27145 elsif Non_Null_Seen
then
27147 ("cannot mix null and non-null constituents", Constit
);
27152 -- Collect the constituent in the list of refinement items
27154 Constits
:= Refinement_Constituents
(State_Id
);
27156 if No
(Constits
) then
27157 Constits
:= New_Elmt_List
;
27158 Set_Refinement_Constituents
(State_Id
, Constits
);
27161 Append_Elmt
(Constit
, Constits
);
27163 -- The state has at least one legal constituent, mark the
27164 -- start of the refinement region. The region ends when the
27165 -- body declarations end (see Analyze_Declarations).
27167 Set_Has_Visible_Refinement
(State_Id
);
27170 -- Non-null constituents
27173 Non_Null_Seen
:= True;
27177 ("cannot mix null and non-null constituents", Constit
);
27181 Resolve_State
(Constit
);
27183 -- Ensure that the constituent denotes a valid state or a
27184 -- whole object (SPARK RM 7.2.2(5)).
27186 if Is_Entity_Name
(Constit
) then
27187 Constit_Id
:= Entity_Of
(Constit
);
27189 -- When a constituent is declared after a subprogram body
27190 -- that caused "freezing" of the related contract where
27191 -- pragma Refined_State resides, the constituent appears
27192 -- undefined and carries Any_Id as its entity.
27194 -- package body Pack
27195 -- with Refined_State => (State => Constit)
27198 -- with Refined_Global => (Input => Constit)
27206 if Constit_Id
= Any_Id
then
27207 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
27209 -- Emit a specialized info message when the contract of
27210 -- the related package body was "frozen" by another body.
27211 -- Note that it is not possible to precisely identify why
27212 -- the constituent is undefined because it is not visible
27213 -- when pragma Refined_State is analyzed. This message is
27214 -- a reasonable approximation.
27216 if Present
(Freeze_Id
) and then not Freeze_Posted
then
27217 Freeze_Posted
:= True;
27219 Error_Msg_Name_1
:= Chars
(Body_Id
);
27220 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27222 ("body & declared # freezes the contract of %",
27225 ("\all constituents must be declared before body #",
27228 -- A misplaced constituent is a critical error because
27229 -- pragma Refined_Depends or Refined_Global depends on
27230 -- the proper link between a state and a constituent.
27231 -- Stop the compilation, as this leads to a multitude
27232 -- of misleading cascaded errors.
27234 raise Program_Error
;
27237 -- The constituent is a valid state or object
27239 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
27243 Match_Constituent
(Constit_Id
);
27245 -- The variable may eventually become a constituent of a
27246 -- single protected/task type. Record the reference now
27247 -- and verify its legality when analyzing the contract of
27248 -- the variable (SPARK RM 9.3).
27250 if Ekind
(Constit_Id
) = E_Variable
then
27251 Record_Possible_Part_Of_Reference
27252 (Var_Id
=> Constit_Id
,
27256 -- Otherwise the constituent is illegal
27260 ("constituent & must denote object or state",
27261 Constit
, Constit_Id
);
27264 -- The constituent is illegal
27267 SPARK_Msg_N
("malformed constituent", Constit
);
27270 end Analyze_Constituent
;
27272 -----------------------------
27273 -- Check_External_Property --
27274 -----------------------------
27276 procedure Check_External_Property
27277 (Prop_Nam
: Name_Id
;
27279 Constit
: Entity_Id
)
27282 -- The property is missing in the declaration of the state, but
27283 -- a constituent is introducing it in the state refinement
27284 -- (SPARK RM 7.2.8(2)).
27286 if not Enabled
and then Present
(Constit
) then
27287 Error_Msg_Name_1
:= Prop_Nam
;
27288 Error_Msg_Name_2
:= Chars
(State_Id
);
27290 ("constituent & introduces external property % in refinement "
27291 & "of state %", State
, Constit
);
27293 Error_Msg_Sloc
:= Sloc
(State_Id
);
27295 ("\property is missing in abstract state declaration #",
27298 end Check_External_Property
;
27304 procedure Match_State
is
27305 State_Elmt
: Elmt_Id
;
27308 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
27310 if Contains
(Refined_States_Seen
, State_Id
) then
27312 ("duplicate refinement of state &", State
, State_Id
);
27316 -- Inspect the abstract states defined in the package declaration
27317 -- looking for a match.
27319 State_Elmt
:= First_Elmt
(Available_States
);
27320 while Present
(State_Elmt
) loop
27322 -- A valid abstract state is being refined in the body. Add
27323 -- the state to the list of processed refined states to aid
27324 -- with the detection of duplicate refinements. Remove the
27325 -- state from Available_States to signal that it has already
27328 if Node
(State_Elmt
) = State_Id
then
27329 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
27330 Remove_Elmt
(Available_States
, State_Elmt
);
27334 Next_Elmt
(State_Elmt
);
27337 -- If we get here, we are refining a state that is not defined in
27338 -- the package declaration.
27340 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27342 ("cannot refine state, & is not defined in package %",
27346 --------------------------------
27347 -- Report_Unused_Constituents --
27348 --------------------------------
27350 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
27351 Constit_Elmt
: Elmt_Id
;
27352 Constit_Id
: Entity_Id
;
27353 Posted
: Boolean := False;
27356 if Present
(Constits
) then
27357 Constit_Elmt
:= First_Elmt
(Constits
);
27358 while Present
(Constit_Elmt
) loop
27359 Constit_Id
:= Node
(Constit_Elmt
);
27361 -- Generate an error message of the form:
27363 -- state ... has unused Part_Of constituents
27364 -- abstract state ... defined at ...
27365 -- constant ... defined at ...
27366 -- variable ... defined at ...
27371 ("state & has unused Part_Of constituents",
27375 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
27377 if Ekind
(Constit_Id
) = E_Abstract_State
then
27379 ("\abstract state & defined #", State
, Constit_Id
);
27381 elsif Ekind
(Constit_Id
) = E_Constant
then
27383 ("\constant & defined #", State
, Constit_Id
);
27386 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
27387 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
27390 Next_Elmt
(Constit_Elmt
);
27393 end Report_Unused_Constituents
;
27395 -- Local declarations
27397 Body_Ref
: Node_Id
;
27398 Body_Ref_Elmt
: Elmt_Id
;
27400 Extra_State
: Node_Id
;
27402 -- Start of processing for Analyze_Refinement_Clause
27405 -- A refinement clause appears as a component association where the
27406 -- sole choice is the state and the expressions are the constituents.
27407 -- This is a syntax error, always report.
27409 if Nkind
(Clause
) /= N_Component_Association
then
27410 Error_Msg_N
("malformed state refinement clause", Clause
);
27414 -- Analyze the state name of a refinement clause
27416 State
:= First
(Choices
(Clause
));
27419 Resolve_State
(State
);
27421 -- Ensure that the state name denotes a valid abstract state that is
27422 -- defined in the spec of the related package.
27424 if Is_Entity_Name
(State
) then
27425 State_Id
:= Entity_Of
(State
);
27427 -- When the abstract state is undefined, it appears as Any_Id. Do
27428 -- not continue with the analysis of the clause.
27430 if State_Id
= Any_Id
then
27433 -- Catch any attempts to re-refine a state or refine a state that
27434 -- is not defined in the package declaration.
27436 elsif Ekind
(State_Id
) = E_Abstract_State
then
27440 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
27444 -- References to a state with visible refinement are illegal.
27445 -- When nested packages are involved, detecting such references is
27446 -- tricky because pragma Refined_State is analyzed later than the
27447 -- offending pragma Depends or Global. References that occur in
27448 -- such nested context are stored in a list. Emit errors for all
27449 -- references found in Body_References (SPARK RM 6.1.4(8)).
27451 if Present
(Body_References
(State_Id
)) then
27452 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
27453 while Present
(Body_Ref_Elmt
) loop
27454 Body_Ref
:= Node
(Body_Ref_Elmt
);
27456 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
27457 Error_Msg_Sloc
:= Sloc
(State
);
27458 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
27460 Next_Elmt
(Body_Ref_Elmt
);
27464 -- The state name is illegal. This is a syntax error, always report.
27467 Error_Msg_N
("malformed state name in refinement clause", State
);
27471 -- A refinement clause may only refine one state at a time
27473 Extra_State
:= Next
(State
);
27475 if Present
(Extra_State
) then
27477 ("refinement clause cannot cover multiple states", Extra_State
);
27480 -- Replicate the Part_Of constituents of the refined state because
27481 -- the algorithm will consume items.
27483 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
27485 -- Analyze all constituents of the refinement. Multiple constituents
27486 -- appear as an aggregate.
27488 Constit
:= Expression
(Clause
);
27490 if Nkind
(Constit
) = N_Aggregate
then
27491 if Present
(Component_Associations
(Constit
)) then
27493 ("constituents of refinement clause must appear in "
27494 & "positional form", Constit
);
27496 else pragma Assert
(Present
(Expressions
(Constit
)));
27497 Constit
:= First
(Expressions
(Constit
));
27498 while Present
(Constit
) loop
27499 Analyze_Constituent
(Constit
);
27504 -- Various forms of a single constituent. Note that these may include
27505 -- malformed constituents.
27508 Analyze_Constituent
(Constit
);
27511 -- Verify that external constituents do not introduce new external
27512 -- property in the state refinement (SPARK RM 7.2.8(2)).
27514 if Is_External_State
(State_Id
) then
27515 Check_External_Property
27516 (Prop_Nam
=> Name_Async_Readers
,
27517 Enabled
=> Async_Readers_Enabled
(State_Id
),
27518 Constit
=> AR_Constit
);
27520 Check_External_Property
27521 (Prop_Nam
=> Name_Async_Writers
,
27522 Enabled
=> Async_Writers_Enabled
(State_Id
),
27523 Constit
=> AW_Constit
);
27525 Check_External_Property
27526 (Prop_Nam
=> Name_Effective_Reads
,
27527 Enabled
=> Effective_Reads_Enabled
(State_Id
),
27528 Constit
=> ER_Constit
);
27530 Check_External_Property
27531 (Prop_Nam
=> Name_Effective_Writes
,
27532 Enabled
=> Effective_Writes_Enabled
(State_Id
),
27533 Constit
=> EW_Constit
);
27535 -- When a refined state is not external, it should not have external
27536 -- constituents (SPARK RM 7.2.8(1)).
27538 elsif External_Constit_Seen
then
27540 ("non-external state & cannot contain external constituents in "
27541 & "refinement", State
, State_Id
);
27544 -- Ensure that all Part_Of candidate constituents have been mentioned
27545 -- in the refinement clause.
27547 Report_Unused_Constituents
(Part_Of_Constits
);
27548 end Analyze_Refinement_Clause
;
27550 -----------------------------
27551 -- Report_Unrefined_States --
27552 -----------------------------
27554 procedure Report_Unrefined_States
(States
: Elist_Id
) is
27555 State_Elmt
: Elmt_Id
;
27558 if Present
(States
) then
27559 State_Elmt
:= First_Elmt
(States
);
27560 while Present
(State_Elmt
) loop
27562 ("abstract state & must be refined", Node
(State_Elmt
));
27564 Next_Elmt
(State_Elmt
);
27567 end Report_Unrefined_States
;
27569 -- Local declarations
27571 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
27574 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27577 -- Do not analyze the pragma multiple times
27579 if Is_Analyzed_Pragma
(N
) then
27583 -- Replicate the abstract states declared by the package because the
27584 -- matching algorithm will consume states.
27586 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
27588 -- Gather all abstract states and objects declared in the visible
27589 -- state space of the package body. These items must be utilized as
27590 -- constituents in a state refinement.
27592 Body_States
:= Collect_Body_States
(Body_Id
);
27594 -- Multiple non-null state refinements appear as an aggregate
27596 if Nkind
(Clauses
) = N_Aggregate
then
27597 if Present
(Expressions
(Clauses
)) then
27599 ("state refinements must appear as component associations",
27602 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
27603 Clause
:= First
(Component_Associations
(Clauses
));
27604 while Present
(Clause
) loop
27605 Analyze_Refinement_Clause
(Clause
);
27610 -- Various forms of a single state refinement. Note that these may
27611 -- include malformed refinements.
27614 Analyze_Refinement_Clause
(Clauses
);
27617 -- List all abstract states that were left unrefined
27619 Report_Unrefined_States
(Available_States
);
27621 Set_Is_Analyzed_Pragma
(N
);
27622 end Analyze_Refined_State_In_Decl_Part
;
27624 ------------------------------------
27625 -- Analyze_Test_Case_In_Decl_Part --
27626 ------------------------------------
27628 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
27629 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27630 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27632 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
27633 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27634 -- denoted by Arg_Nam.
27636 ------------------------------
27637 -- Preanalyze_Test_Case_Arg --
27638 ------------------------------
27640 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
27644 -- Preanalyze the original aspect argument for ASIS or for a generic
27645 -- subprogram to properly capture global references.
27647 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
27651 Arg_Nam
=> Arg_Nam
,
27652 From_Aspect
=> True);
27654 if Present
(Arg
) then
27655 Preanalyze_Assert_Expression
27656 (Expression
(Arg
), Standard_Boolean
);
27660 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
27662 if Present
(Arg
) then
27663 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
27665 end Preanalyze_Test_Case_Arg
;
27669 Restore_Scope
: Boolean := False;
27671 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27674 -- Do not analyze the pragma multiple times
27676 if Is_Analyzed_Pragma
(N
) then
27680 -- Ensure that the formal parameters are visible when analyzing all
27681 -- clauses. This falls out of the general rule of aspects pertaining
27682 -- to subprogram declarations.
27684 if not In_Open_Scopes
(Spec_Id
) then
27685 Restore_Scope
:= True;
27686 Push_Scope
(Spec_Id
);
27688 if Is_Generic_Subprogram
(Spec_Id
) then
27689 Install_Generic_Formals
(Spec_Id
);
27691 Install_Formals
(Spec_Id
);
27695 Preanalyze_Test_Case_Arg
(Name_Requires
);
27696 Preanalyze_Test_Case_Arg
(Name_Ensures
);
27698 if Restore_Scope
then
27702 -- Currently it is not possible to inline pre/postconditions on a
27703 -- subprogram subject to pragma Inline_Always.
27705 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
27707 Set_Is_Analyzed_Pragma
(N
);
27708 end Analyze_Test_Case_In_Decl_Part
;
27714 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
27719 if Present
(List
) then
27720 Elmt
:= First_Elmt
(List
);
27721 while Present
(Elmt
) loop
27722 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
27725 Id
:= Entity_Of
(Node
(Elmt
));
27728 if Id
= Item_Id
then
27739 -----------------------------------
27740 -- Build_Pragma_Check_Equivalent --
27741 -----------------------------------
27743 function Build_Pragma_Check_Equivalent
27745 Subp_Id
: Entity_Id
:= Empty
;
27746 Inher_Id
: Entity_Id
:= Empty
;
27747 Keep_Pragma_Id
: Boolean := False) return Node_Id
27749 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
27750 -- Detect whether node N references a formal parameter subject to
27751 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27752 -- to False to suppress the generation of a reference when analyzing
27755 ------------------------
27756 -- Suppress_Reference --
27757 ------------------------
27759 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
27760 Formal
: Entity_Id
;
27763 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27764 Formal
:= Entity
(N
);
27766 -- The formal parameter is subject to pragma Unreferenced. Prevent
27767 -- the generation of references by resetting the Comes_From_Source
27770 if Is_Formal
(Formal
)
27771 and then Has_Pragma_Unreferenced
(Formal
)
27773 Set_Comes_From_Source
(N
, False);
27778 end Suppress_Reference
;
27780 procedure Suppress_References
is
27781 new Traverse_Proc
(Suppress_Reference
);
27785 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
27786 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
27787 Check_Prag
: Node_Id
;
27791 Needs_Wrapper
: Boolean;
27792 pragma Unreferenced
(Needs_Wrapper
);
27794 -- Start of processing for Build_Pragma_Check_Equivalent
27797 -- When the pre- or postcondition is inherited, map the formals of the
27798 -- inherited subprogram to those of the current subprogram. In addition,
27799 -- map primitive operations of the parent type into the corresponding
27800 -- primitive operations of the descendant.
27802 if Present
(Inher_Id
) then
27803 pragma Assert
(Present
(Subp_Id
));
27805 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
27807 -- Use generic machinery to copy inherited pragma, as if it were an
27808 -- instantiation, resetting source locations appropriately, so that
27809 -- expressions inside the inherited pragma use chained locations.
27810 -- This is used in particular in GNATprove to locate precisely
27811 -- messages on a given inherited pragma.
27813 Set_Copied_Sloc_For_Inherited_Pragma
27814 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
27815 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27817 -- Build the inherited class-wide condition
27819 Build_Class_Wide_Expression
27820 (Prag
=> Check_Prag
,
27822 Par_Subp
=> Inher_Id
,
27823 Adjust_Sloc
=> True,
27824 Needs_Wrapper
=> Needs_Wrapper
);
27826 -- If not an inherited condition simply copy the original pragma
27829 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27832 -- Mark the pragma as being internally generated and reset the Analyzed
27835 Set_Analyzed
(Check_Prag
, False);
27836 Set_Comes_From_Source
(Check_Prag
, False);
27838 -- The tree of the original pragma may contain references to the
27839 -- formal parameters of the related subprogram. At the same time
27840 -- the corresponding body may mark the formals as unreferenced:
27842 -- procedure Proc (Formal : ...)
27843 -- with Pre => Formal ...;
27845 -- procedure Proc (Formal : ...) is
27846 -- pragma Unreferenced (Formal);
27849 -- This creates problems because all pragma Check equivalents are
27850 -- analyzed at the end of the body declarations. Since all source
27851 -- references have already been accounted for, reset any references
27852 -- to such formals in the generated pragma Check equivalent.
27854 Suppress_References
(Check_Prag
);
27856 if Present
(Corresponding_Aspect
(Prag
)) then
27857 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
27862 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
27863 -- the copied pragma in the newly created pragma, convert the copy into
27864 -- pragma Check by correcting the name and adding a check_kind argument.
27866 if not Keep_Pragma_Id
then
27867 Set_Class_Present
(Check_Prag
, False);
27869 Set_Pragma_Identifier
27870 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
27872 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
27873 Make_Pragma_Argument_Association
(Loc
,
27874 Expression
=> Make_Identifier
(Loc
, Nam
)));
27877 -- Update the error message when the pragma is inherited
27879 if Present
(Inher_Id
) then
27880 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
27882 if Chars
(Msg_Arg
) = Name_Message
then
27883 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
27885 -- Insert "inherited" to improve the error message
27887 if Name_Buffer
(1 .. 8) = "failed p" then
27888 Insert_Str_In_Name_Buffer
("inherited ", 8);
27889 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
27895 end Build_Pragma_Check_Equivalent
;
27897 -----------------------------
27898 -- Check_Applicable_Policy --
27899 -----------------------------
27901 procedure Check_Applicable_Policy
(N
: Node_Id
) is
27905 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
27908 -- No effect if not valid assertion kind name
27910 if not Is_Valid_Assertion_Kind
(Ename
) then
27914 -- Loop through entries in check policy list
27916 PP
:= Opt
.Check_Policy_List
;
27917 while Present
(PP
) loop
27919 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27920 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27924 or else Pnm
= Name_Assertion
27925 or else (Pnm
= Name_Statement_Assertions
27926 and then Nam_In
(Ename
, Name_Assert
,
27927 Name_Assert_And_Cut
,
27929 Name_Loop_Invariant
,
27930 Name_Loop_Variant
))
27932 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
27938 Set_Is_Ignored
(N
, True);
27939 Set_Is_Checked
(N
, False);
27944 Set_Is_Checked
(N
, True);
27945 Set_Is_Ignored
(N
, False);
27947 when Name_Disable
=>
27948 Set_Is_Ignored
(N
, True);
27949 Set_Is_Checked
(N
, False);
27950 Set_Is_Disabled
(N
, True);
27952 -- That should be exhaustive, the null here is a defence
27953 -- against a malformed tree from previous errors.
27962 PP
:= Next_Pragma
(PP
);
27966 -- If there are no specific entries that matched, then we let the
27967 -- setting of assertions govern. Note that this provides the needed
27968 -- compatibility with the RM for the cases of assertion, invariant,
27969 -- precondition, predicate, and postcondition.
27971 if Assertions_Enabled
then
27972 Set_Is_Checked
(N
, True);
27973 Set_Is_Ignored
(N
, False);
27975 Set_Is_Checked
(N
, False);
27976 Set_Is_Ignored
(N
, True);
27978 end Check_Applicable_Policy
;
27980 -------------------------------
27981 -- Check_External_Properties --
27982 -------------------------------
27984 procedure Check_External_Properties
27992 -- All properties enabled
27994 if AR
and AW
and ER
and EW
then
27997 -- Async_Readers + Effective_Writes
27998 -- Async_Readers + Async_Writers + Effective_Writes
28000 elsif AR
and EW
and not ER
then
28003 -- Async_Writers + Effective_Reads
28004 -- Async_Readers + Async_Writers + Effective_Reads
28006 elsif AW
and ER
and not EW
then
28009 -- Async_Readers + Async_Writers
28011 elsif AR
and AW
and not ER
and not EW
then
28016 elsif AR
and not AW
and not ER
and not EW
then
28021 elsif AW
and not AR
and not ER
and not EW
then
28026 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
28029 end Check_External_Properties
;
28035 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
28039 -- Loop through entries in check policy list
28041 PP
:= Opt
.Check_Policy_List
;
28042 while Present
(PP
) loop
28044 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28045 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28049 or else (Pnm
= Name_Assertion
28050 and then Is_Valid_Assertion_Kind
(Nam
))
28051 or else (Pnm
= Name_Statement_Assertions
28052 and then Nam_In
(Nam
, Name_Assert
,
28053 Name_Assert_And_Cut
,
28055 Name_Loop_Invariant
,
28056 Name_Loop_Variant
))
28058 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
28067 return Name_Ignore
;
28069 when Name_Disable
=>
28070 return Name_Disable
;
28073 raise Program_Error
;
28077 PP
:= Next_Pragma
(PP
);
28082 -- If there are no specific entries that matched, then we let the
28083 -- setting of assertions govern. Note that this provides the needed
28084 -- compatibility with the RM for the cases of assertion, invariant,
28085 -- precondition, predicate, and postcondition.
28087 if Assertions_Enabled
then
28090 return Name_Ignore
;
28094 ---------------------------
28095 -- Check_Missing_Part_Of --
28096 ---------------------------
28098 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
28099 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
28100 -- Determine whether a package denoted by Pack_Id declares at least one
28103 -----------------------
28104 -- Has_Visible_State --
28105 -----------------------
28107 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
28108 Item_Id
: Entity_Id
;
28111 -- Traverse the entity chain of the package trying to find at least
28112 -- one visible abstract state, variable or a package [instantiation]
28113 -- that declares a visible state.
28115 Item_Id
:= First_Entity
(Pack_Id
);
28116 while Present
(Item_Id
)
28117 and then not In_Private_Part
(Item_Id
)
28119 -- Do not consider internally generated items
28121 if not Comes_From_Source
(Item_Id
) then
28124 -- A visible state has been found
28126 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
28129 -- Recursively peek into nested packages and instantiations
28131 elsif Ekind
(Item_Id
) = E_Package
28132 and then Has_Visible_State
(Item_Id
)
28137 Next_Entity
(Item_Id
);
28141 end Has_Visible_State
;
28145 Pack_Id
: Entity_Id
;
28146 Placement
: State_Space_Kind
;
28148 -- Start of processing for Check_Missing_Part_Of
28151 -- Do not consider abstract states, variables or package instantiations
28152 -- coming from an instance as those always inherit the Part_Of indicator
28153 -- of the instance itself.
28155 if In_Instance
then
28158 -- Do not consider internally generated entities as these can never
28159 -- have a Part_Of indicator.
28161 elsif not Comes_From_Source
(Item_Id
) then
28164 -- Perform these checks only when SPARK_Mode is enabled as they will
28165 -- interfere with standard Ada rules and produce false positives.
28167 elsif SPARK_Mode
/= On
then
28170 -- Do not consider constants, because the compiler cannot accurately
28171 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
28172 -- act as a hidden state of a package.
28174 elsif Ekind
(Item_Id
) = E_Constant
then
28178 -- Find where the abstract state, variable or package instantiation
28179 -- lives with respect to the state space.
28181 Find_Placement_In_State_Space
28182 (Item_Id
=> Item_Id
,
28183 Placement
=> Placement
,
28184 Pack_Id
=> Pack_Id
);
28186 -- Items that appear in a non-package construct (subprogram, block, etc)
28187 -- do not require a Part_Of indicator because they can never act as a
28190 if Placement
= Not_In_Package
then
28193 -- An item declared in the body state space of a package always act as a
28194 -- constituent and does not need explicit Part_Of indicator.
28196 elsif Placement
= Body_State_Space
then
28199 -- In general an item declared in the visible state space of a package
28200 -- does not require a Part_Of indicator. The only exception is when the
28201 -- related package is a private child unit in which case Part_Of must
28202 -- denote a state in the parent unit or in one of its descendants.
28204 elsif Placement
= Visible_State_Space
then
28205 if Is_Child_Unit
(Pack_Id
)
28206 and then Is_Private_Descendant
(Pack_Id
)
28208 -- A package instantiation does not need a Part_Of indicator when
28209 -- the related generic template has no visible state.
28211 if Ekind
(Item_Id
) = E_Package
28212 and then Is_Generic_Instance
(Item_Id
)
28213 and then not Has_Visible_State
(Item_Id
)
28217 -- All other cases require Part_Of
28221 ("indicator Part_Of is required in this context "
28222 & "(SPARK RM 7.2.6(3))", Item_Id
);
28223 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28225 ("\& is declared in the visible part of private child "
28226 & "unit %", Item_Id
);
28230 -- When the item appears in the private state space of a packge, it must
28231 -- be a part of some state declared by the said package.
28233 else pragma Assert
(Placement
= Private_State_Space
);
28235 -- The related package does not declare a state, the item cannot act
28236 -- as a Part_Of constituent.
28238 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
28241 -- A package instantiation does not need a Part_Of indicator when the
28242 -- related generic template has no visible state.
28244 elsif Ekind
(Pack_Id
) = E_Package
28245 and then Is_Generic_Instance
(Pack_Id
)
28246 and then not Has_Visible_State
(Pack_Id
)
28250 -- All other cases require Part_Of
28254 ("indicator Part_Of is required in this context "
28255 & "(SPARK RM 7.2.6(2))", Item_Id
);
28256 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28258 ("\& is declared in the private part of package %", Item_Id
);
28261 end Check_Missing_Part_Of
;
28263 ---------------------------------------------------
28264 -- Check_Postcondition_Use_In_Inlined_Subprogram --
28265 ---------------------------------------------------
28267 procedure Check_Postcondition_Use_In_Inlined_Subprogram
28269 Spec_Id
: Entity_Id
)
28272 if Warn_On_Redundant_Constructs
28273 and then Has_Pragma_Inline_Always
(Spec_Id
)
28274 and then Assertions_Enabled
28276 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28278 if From_Aspect_Specification
(Prag
) then
28280 ("aspect % not enforced on inlined subprogram &?r?",
28281 Corresponding_Aspect
(Prag
), Spec_Id
);
28284 ("pragma % not enforced on inlined subprogram &?r?",
28288 end Check_Postcondition_Use_In_Inlined_Subprogram
;
28290 -------------------------------------
28291 -- Check_State_And_Constituent_Use --
28292 -------------------------------------
28294 procedure Check_State_And_Constituent_Use
28295 (States
: Elist_Id
;
28296 Constits
: Elist_Id
;
28299 Constit_Elmt
: Elmt_Id
;
28300 Constit_Id
: Entity_Id
;
28301 State_Id
: Entity_Id
;
28304 -- Nothing to do if there are no states or constituents
28306 if No
(States
) or else No
(Constits
) then
28310 -- Inspect the list of constituents and try to determine whether its
28311 -- encapsulating state is in list States.
28313 Constit_Elmt
:= First_Elmt
(Constits
);
28314 while Present
(Constit_Elmt
) loop
28315 Constit_Id
:= Node
(Constit_Elmt
);
28317 -- Determine whether the constituent is part of an encapsulating
28318 -- state that appears in the same context and if this is the case,
28319 -- emit an error (SPARK RM 7.2.6(7)).
28321 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
28323 if Present
(State_Id
) then
28324 Error_Msg_Name_1
:= Chars
(Constit_Id
);
28326 ("cannot mention state & and its constituent % in the same "
28327 & "context", Context
, State_Id
);
28331 Next_Elmt
(Constit_Elmt
);
28333 end Check_State_And_Constituent_Use
;
28335 ---------------------------------------------
28336 -- Collect_Inherited_Class_Wide_Conditions --
28337 ---------------------------------------------
28339 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
28340 Parent_Subp
: constant Entity_Id
:=
28341 Ultimate_Alias
(Overridden_Operation
(Subp
));
28342 -- The Overridden_Operation may itself be inherited and as such have no
28343 -- explicit contract.
28345 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
28346 In_Spec_Expr
: Boolean;
28347 Installed
: Boolean;
28349 New_Prag
: Node_Id
;
28352 Installed
:= False;
28354 -- Iterate over the contract of the overridden subprogram to find all
28355 -- inherited class-wide pre- and postconditions.
28357 if Present
(Prags
) then
28358 Prag
:= Pre_Post_Conditions
(Prags
);
28360 while Present
(Prag
) loop
28361 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
28362 Name_Precondition
, Name_Postcondition
)
28363 and then Class_Present
(Prag
)
28365 -- The generated pragma must be analyzed in the context of
28366 -- the subprogram, to make its formals visible. In addition,
28367 -- we must inhibit freezing and full analysis because the
28368 -- controlling type of the subprogram is not frozen yet, and
28369 -- may have further primitives.
28371 if not Installed
then
28374 Install_Formals
(Subp
);
28375 In_Spec_Expr
:= In_Spec_Expression
;
28376 In_Spec_Expression
:= True;
28380 Build_Pragma_Check_Equivalent
28381 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
28383 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
28384 Preanalyze
(New_Prag
);
28386 -- Prevent further analysis in subsequent processing of the
28387 -- current list of declarations
28389 Set_Analyzed
(New_Prag
);
28392 Prag
:= Next_Pragma
(Prag
);
28396 In_Spec_Expression
:= In_Spec_Expr
;
28400 end Collect_Inherited_Class_Wide_Conditions
;
28402 ---------------------------------------
28403 -- Collect_Subprogram_Inputs_Outputs --
28404 ---------------------------------------
28406 procedure Collect_Subprogram_Inputs_Outputs
28407 (Subp_Id
: Entity_Id
;
28408 Synthesize
: Boolean := False;
28409 Subp_Inputs
: in out Elist_Id
;
28410 Subp_Outputs
: in out Elist_Id
;
28411 Global_Seen
: out Boolean)
28413 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
28414 -- Collect all relevant items from a dependency clause
28416 procedure Collect_Global_List
28418 Mode
: Name_Id
:= Name_Input
);
28419 -- Collect all relevant items from a global list
28421 -------------------------------
28422 -- Collect_Dependency_Clause --
28423 -------------------------------
28425 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
28426 procedure Collect_Dependency_Item
28428 Is_Input
: Boolean);
28429 -- Add an item to the proper subprogram input or output collection
28431 -----------------------------
28432 -- Collect_Dependency_Item --
28433 -----------------------------
28435 procedure Collect_Dependency_Item
28437 Is_Input
: Boolean)
28442 -- Nothing to collect when the item is null
28444 if Nkind
(Item
) = N_Null
then
28447 -- Ditto for attribute 'Result
28449 elsif Is_Attribute_Result
(Item
) then
28452 -- Multiple items appear as an aggregate
28454 elsif Nkind
(Item
) = N_Aggregate
then
28455 Extra
:= First
(Expressions
(Item
));
28456 while Present
(Extra
) loop
28457 Collect_Dependency_Item
(Extra
, Is_Input
);
28461 -- Otherwise this is a solitary item
28465 Append_New_Elmt
(Item
, Subp_Inputs
);
28467 Append_New_Elmt
(Item
, Subp_Outputs
);
28470 end Collect_Dependency_Item
;
28472 -- Start of processing for Collect_Dependency_Clause
28475 if Nkind
(Clause
) = N_Null
then
28478 -- A dependency clause appears as component association
28480 elsif Nkind
(Clause
) = N_Component_Association
then
28481 Collect_Dependency_Item
28482 (Item
=> Expression
(Clause
),
28485 Collect_Dependency_Item
28486 (Item
=> First
(Choices
(Clause
)),
28487 Is_Input
=> False);
28489 -- To accommodate partial decoration of disabled SPARK features, this
28490 -- routine may be called with illegal input. If this is the case, do
28491 -- not raise Program_Error.
28496 end Collect_Dependency_Clause
;
28498 -------------------------
28499 -- Collect_Global_List --
28500 -------------------------
28502 procedure Collect_Global_List
28504 Mode
: Name_Id
:= Name_Input
)
28506 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
28507 -- Add an item to the proper subprogram input or output collection
28509 -------------------------
28510 -- Collect_Global_Item --
28511 -------------------------
28513 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
28515 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
28516 Append_New_Elmt
(Item
, Subp_Inputs
);
28519 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
28520 Append_New_Elmt
(Item
, Subp_Outputs
);
28522 end Collect_Global_Item
;
28529 -- Start of processing for Collect_Global_List
28532 if Nkind
(List
) = N_Null
then
28535 -- Single global item declaration
28537 elsif Nkind_In
(List
, N_Expanded_Name
,
28539 N_Selected_Component
)
28541 Collect_Global_Item
(List
, Mode
);
28543 -- Simple global list or moded global list declaration
28545 elsif Nkind
(List
) = N_Aggregate
then
28546 if Present
(Expressions
(List
)) then
28547 Item
:= First
(Expressions
(List
));
28548 while Present
(Item
) loop
28549 Collect_Global_Item
(Item
, Mode
);
28554 Assoc
:= First
(Component_Associations
(List
));
28555 while Present
(Assoc
) loop
28556 Collect_Global_List
28557 (List
=> Expression
(Assoc
),
28558 Mode
=> Chars
(First
(Choices
(Assoc
))));
28563 -- To accommodate partial decoration of disabled SPARK features, this
28564 -- routine may be called with illegal input. If this is the case, do
28565 -- not raise Program_Error.
28570 end Collect_Global_List
;
28577 Formal
: Entity_Id
;
28579 Spec_Id
: Entity_Id
;
28580 Subp_Decl
: Node_Id
;
28583 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28586 Global_Seen
:= False;
28588 -- Process all formal parameters of entries, [generic] subprograms, and
28591 if Ekind_In
(Subp_Id
, E_Entry
,
28594 E_Generic_Function
,
28595 E_Generic_Procedure
,
28599 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
28600 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28602 -- Process all formal parameters
28604 Formal
:= First_Entity
(Spec_Id
);
28605 while Present
(Formal
) loop
28606 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
28607 Append_New_Elmt
(Formal
, Subp_Inputs
);
28610 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
28611 Append_New_Elmt
(Formal
, Subp_Outputs
);
28613 -- Out parameters can act as inputs when the related type is
28614 -- tagged, unconstrained array, unconstrained record, or record
28615 -- with unconstrained components.
28617 if Ekind
(Formal
) = E_Out_Parameter
28618 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
28620 Append_New_Elmt
(Formal
, Subp_Inputs
);
28624 Next_Entity
(Formal
);
28627 -- Otherwise the input denotes a task type, a task body, or the
28628 -- anonymous object created for a single task type.
28630 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
28631 or else Is_Single_Task_Object
(Subp_Id
)
28633 Subp_Decl
:= Declaration_Node
(Subp_Id
);
28634 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28637 -- When processing an entry, subprogram or task body, look for pragmas
28638 -- Refined_Depends and Refined_Global as they specify the inputs and
28641 if Is_Entry_Body
(Subp_Id
)
28642 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
28644 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
28645 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
28647 -- Subprogram declaration or stand alone body case, look for pragmas
28648 -- Depends and Global
28651 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
28652 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28655 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28656 -- because it provides finer granularity of inputs and outputs.
28658 if Present
(Global
) then
28659 Global_Seen
:= True;
28660 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28662 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28663 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28664 -- the inputs and outputs from [Refined_]Depends.
28666 elsif Synthesize
and then Present
(Depends
) then
28667 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
28669 -- Multiple dependency clauses appear as an aggregate
28671 if Nkind
(Clauses
) = N_Aggregate
then
28672 Clause
:= First
(Component_Associations
(Clauses
));
28673 while Present
(Clause
) loop
28674 Collect_Dependency_Clause
(Clause
);
28678 -- Otherwise this is a single dependency clause
28681 Collect_Dependency_Clause
(Clauses
);
28685 -- The current instance of a protected type acts as a formal parameter
28686 -- of mode IN for functions and IN OUT for entries and procedures
28687 -- (SPARK RM 6.1.4).
28689 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
28690 Typ
:= Scope
(Spec_Id
);
28692 -- Use the anonymous object when the type is single protected
28694 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28695 Typ
:= Anonymous_Object
(Typ
);
28698 Append_New_Elmt
(Typ
, Subp_Inputs
);
28700 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
28701 Append_New_Elmt
(Typ
, Subp_Outputs
);
28704 -- The current instance of a task type acts as a formal parameter of
28705 -- mode IN OUT (SPARK RM 6.1.4).
28707 elsif Ekind
(Spec_Id
) = E_Task_Type
then
28710 -- Use the anonymous object when the type is single task
28712 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28713 Typ
:= Anonymous_Object
(Typ
);
28716 Append_New_Elmt
(Typ
, Subp_Inputs
);
28717 Append_New_Elmt
(Typ
, Subp_Outputs
);
28719 elsif Is_Single_Task_Object
(Spec_Id
) then
28720 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
28721 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
28723 end Collect_Subprogram_Inputs_Outputs
;
28725 ---------------------------
28726 -- Contract_Freeze_Error --
28727 ---------------------------
28729 procedure Contract_Freeze_Error
28730 (Contract_Id
: Entity_Id
;
28731 Freeze_Id
: Entity_Id
)
28734 Error_Msg_Name_1
:= Chars
(Contract_Id
);
28735 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28738 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
28740 ("\all contractual items must be declared before body #", Contract_Id
);
28741 end Contract_Freeze_Error
;
28743 ---------------------------------
28744 -- Delay_Config_Pragma_Analyze --
28745 ---------------------------------
28747 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
28749 return Nam_In
(Pragma_Name_Unmapped
(N
),
28750 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
28751 end Delay_Config_Pragma_Analyze
;
28753 -----------------------
28754 -- Duplication_Error --
28755 -----------------------
28757 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
28758 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
28759 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
28762 Error_Msg_Sloc
:= Sloc
(Prev
);
28763 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28765 -- Emit a precise message to distinguish between source pragmas and
28766 -- pragmas generated from aspects. The ordering of the two pragmas is
28770 -- Prag -- duplicate
28772 -- No error is emitted when both pragmas come from aspects because this
28773 -- is already detected by the general aspect analysis mechanism.
28775 if Prag_From_Asp
and Prev_From_Asp
then
28777 elsif Prag_From_Asp
then
28778 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
28779 elsif Prev_From_Asp
then
28780 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
28782 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
28784 end Duplication_Error
;
28786 ------------------------------
28787 -- Find_Encapsulating_State --
28788 ------------------------------
28790 function Find_Encapsulating_State
28791 (States
: Elist_Id
;
28792 Constit_Id
: Entity_Id
) return Entity_Id
28794 State_Id
: Entity_Id
;
28797 -- Since a constituent may be part of a larger constituent set, climb
28798 -- the encapsulating state chain looking for a state that appears in
28801 State_Id
:= Encapsulating_State
(Constit_Id
);
28802 while Present
(State_Id
) loop
28803 if Contains
(States
, State_Id
) then
28807 State_Id
:= Encapsulating_State
(State_Id
);
28811 end Find_Encapsulating_State
;
28813 --------------------------
28814 -- Find_Related_Context --
28815 --------------------------
28817 function Find_Related_Context
28819 Do_Checks
: Boolean := False) return Node_Id
28824 Stmt
:= Prev
(Prag
);
28825 while Present
(Stmt
) loop
28827 -- Skip prior pragmas, but check for duplicates
28829 if Nkind
(Stmt
) = N_Pragma
then
28831 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
28838 -- Skip internally generated code
28840 elsif not Comes_From_Source
(Stmt
) then
28842 -- The anonymous object created for a single concurrent type is a
28843 -- suitable context.
28845 if Nkind
(Stmt
) = N_Object_Declaration
28846 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28851 -- Return the current source construct
28861 end Find_Related_Context
;
28863 --------------------------------------
28864 -- Find_Related_Declaration_Or_Body --
28865 --------------------------------------
28867 function Find_Related_Declaration_Or_Body
28869 Do_Checks
: Boolean := False) return Node_Id
28871 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
28873 procedure Expression_Function_Error
;
28874 -- Emit an error concerning pragma Prag that illegaly applies to an
28875 -- expression function.
28877 -------------------------------
28878 -- Expression_Function_Error --
28879 -------------------------------
28881 procedure Expression_Function_Error
is
28883 Error_Msg_Name_1
:= Prag_Nam
;
28885 -- Emit a precise message to distinguish between source pragmas and
28886 -- pragmas generated from aspects.
28888 if From_Aspect_Specification
(Prag
) then
28890 ("aspect % cannot apply to a stand alone expression function",
28894 ("pragma % cannot apply to a stand alone expression function",
28897 end Expression_Function_Error
;
28901 Context
: constant Node_Id
:= Parent
(Prag
);
28904 Look_For_Body
: constant Boolean :=
28905 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
28906 Name_Refined_Global
,
28908 Name_Refined_State
);
28909 -- Refinement pragmas must be associated with a subprogram body [stub]
28911 -- Start of processing for Find_Related_Declaration_Or_Body
28914 Stmt
:= Prev
(Prag
);
28915 while Present
(Stmt
) loop
28917 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28918 -- by splitting a complex pre/postcondition are not considered to
28921 if Nkind
(Stmt
) = N_Pragma
then
28923 and then not Split_PPC
(Stmt
)
28924 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
28931 -- Emit an error when a refinement pragma appears on an expression
28932 -- function without a completion.
28935 and then Look_For_Body
28936 and then Nkind
(Stmt
) = N_Subprogram_Declaration
28937 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
28938 and then not Has_Completion
(Defining_Entity
(Stmt
))
28940 Expression_Function_Error
;
28943 -- The refinement pragma applies to a subprogram body stub
28945 elsif Look_For_Body
28946 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
28950 -- Skip internally generated code
28952 elsif not Comes_From_Source
(Stmt
) then
28954 -- The anonymous object created for a single concurrent type is a
28955 -- suitable context.
28957 if Nkind
(Stmt
) = N_Object_Declaration
28958 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28962 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
28964 -- The subprogram declaration is an internally generated spec
28965 -- for an expression function.
28967 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28970 -- The subprogram is actually an instance housed within an
28971 -- anonymous wrapper package.
28973 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28978 -- Return the current construct which is either a subprogram body,
28979 -- a subprogram declaration or is illegal.
28988 -- If we fall through, then the pragma was either the first declaration
28989 -- or it was preceded by other pragmas and no source constructs.
28991 -- The pragma is associated with a library-level subprogram
28993 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
28994 return Unit
(Parent
(Context
));
28996 -- The pragma appears inside the declarations of an entry body
28998 elsif Nkind
(Context
) = N_Entry_Body
then
29001 -- The pragma appears inside the statements of a subprogram body. This
29002 -- placement is the result of subprogram contract expansion.
29004 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
29005 return Parent
(Context
);
29007 -- The pragma appears inside the declarative part of a package body
29009 elsif Nkind
(Context
) = N_Package_Body
then
29012 -- The pragma appears inside the declarative part of a subprogram body
29014 elsif Nkind
(Context
) = N_Subprogram_Body
then
29017 -- The pragma appears inside the declarative part of a task body
29019 elsif Nkind
(Context
) = N_Task_Body
then
29022 -- The pragma appears inside the visible part of a package specification
29024 elsif Nkind
(Context
) = N_Package_Specification
then
29025 return Parent
(Context
);
29027 -- The pragma is a byproduct of aspect expansion, return the related
29028 -- context of the original aspect. This case has a lower priority as
29029 -- the above circuitry pinpoints precisely the related context.
29031 elsif Present
(Corresponding_Aspect
(Prag
)) then
29032 return Parent
(Corresponding_Aspect
(Prag
));
29034 -- No candidate subprogram [body] found
29039 end Find_Related_Declaration_Or_Body
;
29041 ----------------------------------
29042 -- Find_Related_Package_Or_Body --
29043 ----------------------------------
29045 function Find_Related_Package_Or_Body
29047 Do_Checks
: Boolean := False) return Node_Id
29049 Context
: constant Node_Id
:= Parent
(Prag
);
29050 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29054 Stmt
:= Prev
(Prag
);
29055 while Present
(Stmt
) loop
29057 -- Skip prior pragmas, but check for duplicates
29059 if Nkind
(Stmt
) = N_Pragma
then
29060 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
29066 -- Skip internally generated code
29068 elsif not Comes_From_Source
(Stmt
) then
29069 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
29071 -- The subprogram declaration is an internally generated spec
29072 -- for an expression function.
29074 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29077 -- The subprogram is actually an instance housed within an
29078 -- anonymous wrapper package.
29080 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29085 -- Return the current source construct which is illegal
29094 -- If we fall through, then the pragma was either the first declaration
29095 -- or it was preceded by other pragmas and no source constructs.
29097 -- The pragma is associated with a package. The immediate context in
29098 -- this case is the specification of the package.
29100 if Nkind
(Context
) = N_Package_Specification
then
29101 return Parent
(Context
);
29103 -- The pragma appears in the declarations of a package body
29105 elsif Nkind
(Context
) = N_Package_Body
then
29108 -- The pragma appears in the statements of a package body
29110 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
29111 and then Nkind
(Parent
(Context
)) = N_Package_Body
29113 return Parent
(Context
);
29115 -- The pragma is a byproduct of aspect expansion, return the related
29116 -- context of the original aspect. This case has a lower priority as
29117 -- the above circuitry pinpoints precisely the related context.
29119 elsif Present
(Corresponding_Aspect
(Prag
)) then
29120 return Parent
(Corresponding_Aspect
(Prag
));
29122 -- No candidate packge [body] found
29127 end Find_Related_Package_Or_Body
;
29133 function Get_Argument
29135 Context_Id
: Entity_Id
:= Empty
) return Node_Id
29137 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
29140 -- Use the expression of the original aspect when compiling for ASIS or
29141 -- when analyzing the template of a generic unit. In both cases the
29142 -- aspect's tree must be decorated to allow for ASIS queries or to save
29143 -- the global references in the generic context.
29145 if From_Aspect_Specification
(Prag
)
29146 and then (ASIS_Mode
or else (Present
(Context_Id
)
29147 and then Is_Generic_Unit
(Context_Id
)))
29149 return Corresponding_Aspect
(Prag
);
29151 -- Otherwise use the expression of the pragma
29153 elsif Present
(Args
) then
29154 return First
(Args
);
29161 -------------------------
29162 -- Get_Base_Subprogram --
29163 -------------------------
29165 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
29166 Result
: Entity_Id
;
29169 -- Follow subprogram renaming chain
29173 if Is_Subprogram
(Result
)
29175 Nkind
(Parent
(Declaration_Node
(Result
))) =
29176 N_Subprogram_Renaming_Declaration
29177 and then Present
(Alias
(Result
))
29179 Result
:= Alias
(Result
);
29183 end Get_Base_Subprogram
;
29185 -----------------------
29186 -- Get_SPARK_Mode_Type --
29187 -----------------------
29189 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
29191 if N
= Name_On
then
29193 elsif N
= Name_Off
then
29196 -- Any other argument is illegal
29199 raise Program_Error
;
29201 end Get_SPARK_Mode_Type
;
29203 ------------------------------------
29204 -- Get_SPARK_Mode_From_Annotation --
29205 ------------------------------------
29207 function Get_SPARK_Mode_From_Annotation
29208 (N
: Node_Id
) return SPARK_Mode_Type
29213 if Nkind
(N
) = N_Aspect_Specification
then
29214 Mode
:= Expression
(N
);
29216 else pragma Assert
(Nkind
(N
) = N_Pragma
);
29217 Mode
:= First
(Pragma_Argument_Associations
(N
));
29219 if Present
(Mode
) then
29220 Mode
:= Get_Pragma_Arg
(Mode
);
29224 -- Aspect or pragma SPARK_Mode specifies an explicit mode
29226 if Present
(Mode
) then
29227 if Nkind
(Mode
) = N_Identifier
then
29228 return Get_SPARK_Mode_Type
(Chars
(Mode
));
29230 -- In case of a malformed aspect or pragma, return the default None
29236 -- Otherwise the lack of an expression defaults SPARK_Mode to On
29241 end Get_SPARK_Mode_From_Annotation
;
29243 ---------------------------
29244 -- Has_Extra_Parentheses --
29245 ---------------------------
29247 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
29251 -- The aggregate should not have an expression list because a clause
29252 -- is always interpreted as a component association. The only way an
29253 -- expression list can sneak in is by adding extra parentheses around
29254 -- the individual clauses:
29256 -- Depends (Output => Input) -- proper form
29257 -- Depends ((Output => Input)) -- extra parentheses
29259 -- Since the extra parentheses are not allowed by the syntax of the
29260 -- pragma, flag them now to avoid emitting misleading errors down the
29263 if Nkind
(Clause
) = N_Aggregate
29264 and then Present
(Expressions
(Clause
))
29266 Expr
:= First
(Expressions
(Clause
));
29267 while Present
(Expr
) loop
29269 -- A dependency clause surrounded by extra parentheses appears
29270 -- as an aggregate of component associations with an optional
29271 -- Paren_Count set.
29273 if Nkind
(Expr
) = N_Aggregate
29274 and then Present
(Component_Associations
(Expr
))
29277 ("dependency clause contains extra parentheses", Expr
);
29279 -- Otherwise the expression is a malformed construct
29282 SPARK_Msg_N
("malformed dependency clause", Expr
);
29292 end Has_Extra_Parentheses
;
29298 procedure Initialize
is
29309 Dummy
:= Dummy
+ 1;
29312 -----------------------------
29313 -- Is_Config_Static_String --
29314 -----------------------------
29316 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29318 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
29319 -- This is an internal recursive function that is just like the outer
29320 -- function except that it adds the string to the name buffer rather
29321 -- than placing the string in the name buffer.
29323 ------------------------------
29324 -- Add_Config_Static_String --
29325 ------------------------------
29327 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29334 if Nkind
(N
) = N_Op_Concat
then
29335 if Add_Config_Static_String
(Left_Opnd
(N
)) then
29336 N
:= Right_Opnd
(N
);
29342 if Nkind
(N
) /= N_String_Literal
then
29343 Error_Msg_N
("string literal expected for pragma argument", N
);
29347 for J
in 1 .. String_Length
(Strval
(N
)) loop
29348 C
:= Get_String_Char
(Strval
(N
), J
);
29350 if not In_Character_Range
(C
) then
29352 ("string literal contains invalid wide character",
29353 Sloc
(N
) + 1 + Source_Ptr
(J
));
29357 Add_Char_To_Name_Buffer
(Get_Character
(C
));
29362 end Add_Config_Static_String
;
29364 -- Start of processing for Is_Config_Static_String
29369 return Add_Config_Static_String
(Arg
);
29370 end Is_Config_Static_String
;
29372 -------------------------------
29373 -- Is_Elaboration_SPARK_Mode --
29374 -------------------------------
29376 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
29379 (Nkind
(N
) = N_Pragma
29380 and then Pragma_Name
(N
) = Name_SPARK_Mode
29381 and then Is_List_Member
(N
));
29383 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29384 -- appears in the statement part of the body.
29387 Present
(Parent
(N
))
29388 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
29389 and then List_Containing
(N
) = Statements
(Parent
(N
))
29390 and then Present
(Parent
(Parent
(N
)))
29391 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
29392 end Is_Elaboration_SPARK_Mode
;
29394 -----------------------
29395 -- Is_Enabled_Pragma --
29396 -----------------------
29398 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
29402 if Present
(Prag
) then
29403 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29405 if Present
(Arg
) then
29406 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
29408 -- The lack of a Boolean argument automatically enables the pragma
29414 -- The pragma is missing, therefore it is not enabled
29419 end Is_Enabled_Pragma
;
29421 -----------------------------------------
29422 -- Is_Non_Significant_Pragma_Reference --
29423 -----------------------------------------
29425 -- This function makes use of the following static table which indicates
29426 -- whether appearance of some name in a given pragma is to be considered
29427 -- as a reference for the purposes of warnings about unreferenced objects.
29429 -- -1 indicates that appearence in any argument is significant
29430 -- 0 indicates that appearance in any argument is not significant
29431 -- +n indicates that appearance as argument n is significant, but all
29432 -- other arguments are not significant
29433 -- 9n arguments from n on are significant, before n insignificant
29435 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
29436 (Pragma_Abort_Defer
=> -1,
29437 Pragma_Abstract_State
=> -1,
29438 Pragma_Ada_83
=> -1,
29439 Pragma_Ada_95
=> -1,
29440 Pragma_Ada_05
=> -1,
29441 Pragma_Ada_2005
=> -1,
29442 Pragma_Ada_12
=> -1,
29443 Pragma_Ada_2012
=> -1,
29444 Pragma_Ada_2020
=> -1,
29445 Pragma_All_Calls_Remote
=> -1,
29446 Pragma_Allow_Integer_Address
=> -1,
29447 Pragma_Annotate
=> 93,
29448 Pragma_Assert
=> -1,
29449 Pragma_Assert_And_Cut
=> -1,
29450 Pragma_Assertion_Policy
=> 0,
29451 Pragma_Assume
=> -1,
29452 Pragma_Assume_No_Invalid_Values
=> 0,
29453 Pragma_Async_Readers
=> 0,
29454 Pragma_Async_Writers
=> 0,
29455 Pragma_Asynchronous
=> 0,
29456 Pragma_Atomic
=> 0,
29457 Pragma_Atomic_Components
=> 0,
29458 Pragma_Attach_Handler
=> -1,
29459 Pragma_Attribute_Definition
=> 92,
29460 Pragma_Check
=> -1,
29461 Pragma_Check_Float_Overflow
=> 0,
29462 Pragma_Check_Name
=> 0,
29463 Pragma_Check_Policy
=> 0,
29464 Pragma_CPP_Class
=> 0,
29465 Pragma_CPP_Constructor
=> 0,
29466 Pragma_CPP_Virtual
=> 0,
29467 Pragma_CPP_Vtable
=> 0,
29469 Pragma_C_Pass_By_Copy
=> 0,
29470 Pragma_Comment
=> -1,
29471 Pragma_Common_Object
=> 0,
29472 Pragma_Compile_Time_Error
=> -1,
29473 Pragma_Compile_Time_Warning
=> -1,
29474 Pragma_Compiler_Unit
=> -1,
29475 Pragma_Compiler_Unit_Warning
=> -1,
29476 Pragma_Complete_Representation
=> 0,
29477 Pragma_Complex_Representation
=> 0,
29478 Pragma_Component_Alignment
=> 0,
29479 Pragma_Constant_After_Elaboration
=> 0,
29480 Pragma_Contract_Cases
=> -1,
29481 Pragma_Controlled
=> 0,
29482 Pragma_Convention
=> 0,
29483 Pragma_Convention_Identifier
=> 0,
29484 Pragma_Deadline_Floor
=> -1,
29485 Pragma_Debug
=> -1,
29486 Pragma_Debug_Policy
=> 0,
29487 Pragma_Detect_Blocking
=> 0,
29488 Pragma_Default_Initial_Condition
=> -1,
29489 Pragma_Default_Scalar_Storage_Order
=> 0,
29490 Pragma_Default_Storage_Pool
=> 0,
29491 Pragma_Depends
=> -1,
29492 Pragma_Disable_Atomic_Synchronization
=> 0,
29493 Pragma_Discard_Names
=> 0,
29494 Pragma_Dispatching_Domain
=> -1,
29495 Pragma_Effective_Reads
=> 0,
29496 Pragma_Effective_Writes
=> 0,
29497 Pragma_Elaborate
=> 0,
29498 Pragma_Elaborate_All
=> 0,
29499 Pragma_Elaborate_Body
=> 0,
29500 Pragma_Elaboration_Checks
=> 0,
29501 Pragma_Eliminate
=> 0,
29502 Pragma_Enable_Atomic_Synchronization
=> 0,
29503 Pragma_Export
=> -1,
29504 Pragma_Export_Function
=> -1,
29505 Pragma_Export_Object
=> -1,
29506 Pragma_Export_Procedure
=> -1,
29507 Pragma_Export_Value
=> -1,
29508 Pragma_Export_Valued_Procedure
=> -1,
29509 Pragma_Extend_System
=> -1,
29510 Pragma_Extensions_Allowed
=> 0,
29511 Pragma_Extensions_Visible
=> 0,
29512 Pragma_External
=> -1,
29513 Pragma_Favor_Top_Level
=> 0,
29514 Pragma_External_Name_Casing
=> 0,
29515 Pragma_Fast_Math
=> 0,
29516 Pragma_Finalize_Storage_Only
=> 0,
29518 Pragma_Global
=> -1,
29519 Pragma_Ident
=> -1,
29520 Pragma_Ignore_Pragma
=> 0,
29521 Pragma_Implementation_Defined
=> -1,
29522 Pragma_Implemented
=> -1,
29523 Pragma_Implicit_Packing
=> 0,
29524 Pragma_Import
=> 93,
29525 Pragma_Import_Function
=> 0,
29526 Pragma_Import_Object
=> 0,
29527 Pragma_Import_Procedure
=> 0,
29528 Pragma_Import_Valued_Procedure
=> 0,
29529 Pragma_Independent
=> 0,
29530 Pragma_Independent_Components
=> 0,
29531 Pragma_Initial_Condition
=> -1,
29532 Pragma_Initialize_Scalars
=> 0,
29533 Pragma_Initializes
=> -1,
29534 Pragma_Inline
=> 0,
29535 Pragma_Inline_Always
=> 0,
29536 Pragma_Inline_Generic
=> 0,
29537 Pragma_Inspection_Point
=> -1,
29538 Pragma_Interface
=> 92,
29539 Pragma_Interface_Name
=> 0,
29540 Pragma_Interrupt_Handler
=> -1,
29541 Pragma_Interrupt_Priority
=> -1,
29542 Pragma_Interrupt_State
=> -1,
29543 Pragma_Invariant
=> -1,
29544 Pragma_Keep_Names
=> 0,
29545 Pragma_License
=> 0,
29546 Pragma_Link_With
=> -1,
29547 Pragma_Linker_Alias
=> -1,
29548 Pragma_Linker_Constructor
=> -1,
29549 Pragma_Linker_Destructor
=> -1,
29550 Pragma_Linker_Options
=> -1,
29551 Pragma_Linker_Section
=> 0,
29553 Pragma_Lock_Free
=> 0,
29554 Pragma_Locking_Policy
=> 0,
29555 Pragma_Loop_Invariant
=> -1,
29556 Pragma_Loop_Optimize
=> 0,
29557 Pragma_Loop_Variant
=> -1,
29558 Pragma_Machine_Attribute
=> -1,
29560 Pragma_Main_Storage
=> -1,
29561 Pragma_Max_Queue_Length
=> 0,
29562 Pragma_Memory_Size
=> 0,
29563 Pragma_No_Return
=> 0,
29564 Pragma_No_Body
=> 0,
29565 Pragma_No_Component_Reordering
=> -1,
29566 Pragma_No_Elaboration_Code_All
=> 0,
29567 Pragma_No_Heap_Finalization
=> 0,
29568 Pragma_No_Inline
=> 0,
29569 Pragma_No_Run_Time
=> -1,
29570 Pragma_No_Strict_Aliasing
=> -1,
29571 Pragma_No_Tagged_Streams
=> 0,
29572 Pragma_Normalize_Scalars
=> 0,
29573 Pragma_Obsolescent
=> 0,
29574 Pragma_Optimize
=> 0,
29575 Pragma_Optimize_Alignment
=> 0,
29576 Pragma_Overflow_Mode
=> 0,
29577 Pragma_Overriding_Renamings
=> 0,
29578 Pragma_Ordered
=> 0,
29581 Pragma_Part_Of
=> 0,
29582 Pragma_Partition_Elaboration_Policy
=> 0,
29583 Pragma_Passive
=> 0,
29584 Pragma_Persistent_BSS
=> 0,
29585 Pragma_Polling
=> 0,
29586 Pragma_Prefix_Exception_Messages
=> 0,
29588 Pragma_Postcondition
=> -1,
29589 Pragma_Post_Class
=> -1,
29591 Pragma_Precondition
=> -1,
29592 Pragma_Predicate
=> -1,
29593 Pragma_Predicate_Failure
=> -1,
29594 Pragma_Preelaborable_Initialization
=> -1,
29595 Pragma_Preelaborate
=> 0,
29596 Pragma_Pre_Class
=> -1,
29597 Pragma_Priority
=> -1,
29598 Pragma_Priority_Specific_Dispatching
=> 0,
29599 Pragma_Profile
=> 0,
29600 Pragma_Profile_Warnings
=> 0,
29601 Pragma_Propagate_Exceptions
=> 0,
29602 Pragma_Provide_Shift_Operators
=> 0,
29603 Pragma_Psect_Object
=> 0,
29605 Pragma_Pure_Function
=> 0,
29606 Pragma_Queuing_Policy
=> 0,
29607 Pragma_Rational
=> 0,
29608 Pragma_Ravenscar
=> 0,
29609 Pragma_Refined_Depends
=> -1,
29610 Pragma_Refined_Global
=> -1,
29611 Pragma_Refined_Post
=> -1,
29612 Pragma_Refined_State
=> -1,
29613 Pragma_Relative_Deadline
=> 0,
29614 Pragma_Rename_Pragma
=> 0,
29615 Pragma_Remote_Access_Type
=> -1,
29616 Pragma_Remote_Call_Interface
=> -1,
29617 Pragma_Remote_Types
=> -1,
29618 Pragma_Restricted_Run_Time
=> 0,
29619 Pragma_Restriction_Warnings
=> 0,
29620 Pragma_Restrictions
=> 0,
29621 Pragma_Reviewable
=> -1,
29622 Pragma_Secondary_Stack_Size
=> -1,
29623 Pragma_Short_Circuit_And_Or
=> 0,
29624 Pragma_Share_Generic
=> 0,
29625 Pragma_Shared
=> 0,
29626 Pragma_Shared_Passive
=> 0,
29627 Pragma_Short_Descriptors
=> 0,
29628 Pragma_Simple_Storage_Pool_Type
=> 0,
29629 Pragma_Source_File_Name
=> 0,
29630 Pragma_Source_File_Name_Project
=> 0,
29631 Pragma_Source_Reference
=> 0,
29632 Pragma_SPARK_Mode
=> 0,
29633 Pragma_Storage_Size
=> -1,
29634 Pragma_Storage_Unit
=> 0,
29635 Pragma_Static_Elaboration_Desired
=> 0,
29636 Pragma_Stream_Convert
=> 0,
29637 Pragma_Style_Checks
=> 0,
29638 Pragma_Subtitle
=> 0,
29639 Pragma_Suppress
=> 0,
29640 Pragma_Suppress_Exception_Locations
=> 0,
29641 Pragma_Suppress_All
=> 0,
29642 Pragma_Suppress_Debug_Info
=> 0,
29643 Pragma_Suppress_Initialization
=> 0,
29644 Pragma_System_Name
=> 0,
29645 Pragma_Task_Dispatching_Policy
=> 0,
29646 Pragma_Task_Info
=> -1,
29647 Pragma_Task_Name
=> -1,
29648 Pragma_Task_Storage
=> -1,
29649 Pragma_Test_Case
=> -1,
29650 Pragma_Thread_Local_Storage
=> -1,
29651 Pragma_Time_Slice
=> -1,
29653 Pragma_Type_Invariant
=> -1,
29654 Pragma_Type_Invariant_Class
=> -1,
29655 Pragma_Unchecked_Union
=> 0,
29656 Pragma_Unevaluated_Use_Of_Old
=> 0,
29657 Pragma_Unimplemented_Unit
=> 0,
29658 Pragma_Universal_Aliasing
=> 0,
29659 Pragma_Universal_Data
=> 0,
29660 Pragma_Unmodified
=> 0,
29661 Pragma_Unreferenced
=> 0,
29662 Pragma_Unreferenced_Objects
=> 0,
29663 Pragma_Unreserve_All_Interrupts
=> 0,
29664 Pragma_Unsuppress
=> 0,
29665 Pragma_Unused
=> 0,
29666 Pragma_Use_VADS_Size
=> 0,
29667 Pragma_Validity_Checks
=> 0,
29668 Pragma_Volatile
=> 0,
29669 Pragma_Volatile_Components
=> 0,
29670 Pragma_Volatile_Full_Access
=> 0,
29671 Pragma_Volatile_Function
=> 0,
29672 Pragma_Warning_As_Error
=> 0,
29673 Pragma_Warnings
=> 0,
29674 Pragma_Weak_External
=> 0,
29675 Pragma_Wide_Character_Encoding
=> 0,
29676 Unknown_Pragma
=> 0);
29678 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
29684 function Arg_No
return Nat
;
29685 -- Returns an integer showing what argument we are in. A value of
29686 -- zero means we are not in any of the arguments.
29692 function Arg_No
return Nat
is
29697 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
29711 -- Start of processing for Non_Significant_Pragma_Reference
29716 if Nkind
(P
) /= N_Pragma_Argument_Association
then
29720 Id
:= Get_Pragma_Id
(Parent
(P
));
29721 C
:= Sig_Flags
(Id
);
29736 return AN
< (C
- 90);
29742 end Is_Non_Significant_Pragma_Reference
;
29744 ------------------------------
29745 -- Is_Pragma_String_Literal --
29746 ------------------------------
29748 -- This function returns true if the corresponding pragma argument is a
29749 -- static string expression. These are the only cases in which string
29750 -- literals can appear as pragma arguments. We also allow a string literal
29751 -- as the first argument to pragma Assert (although it will of course
29752 -- always generate a type error).
29754 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
29755 Pragn
: constant Node_Id
:= Parent
(Par
);
29756 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
29757 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
29763 N
:= First
(Assoc
);
29770 if Pname
= Name_Assert
then
29773 elsif Pname
= Name_Export
then
29776 elsif Pname
= Name_Ident
then
29779 elsif Pname
= Name_Import
then
29782 elsif Pname
= Name_Interface_Name
then
29785 elsif Pname
= Name_Linker_Alias
then
29788 elsif Pname
= Name_Linker_Section
then
29791 elsif Pname
= Name_Machine_Attribute
then
29794 elsif Pname
= Name_Source_File_Name
then
29797 elsif Pname
= Name_Source_Reference
then
29800 elsif Pname
= Name_Title
then
29803 elsif Pname
= Name_Subtitle
then
29809 end Is_Pragma_String_Literal
;
29811 ---------------------------
29812 -- Is_Private_SPARK_Mode --
29813 ---------------------------
29815 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
29818 (Nkind
(N
) = N_Pragma
29819 and then Pragma_Name
(N
) = Name_SPARK_Mode
29820 and then Is_List_Member
(N
));
29822 -- For pragma SPARK_Mode to be private, it has to appear in the private
29823 -- declarations of a package.
29826 Present
(Parent
(N
))
29827 and then Nkind
(Parent
(N
)) = N_Package_Specification
29828 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
29829 end Is_Private_SPARK_Mode
;
29831 -------------------------------------
29832 -- Is_Unconstrained_Or_Tagged_Item --
29833 -------------------------------------
29835 function Is_Unconstrained_Or_Tagged_Item
29836 (Item
: Entity_Id
) return Boolean
29838 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
29839 -- Determine whether record type Typ has at least one unconstrained
29842 ---------------------------------
29843 -- Has_Unconstrained_Component --
29844 ---------------------------------
29846 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
29850 Comp
:= First_Component
(Typ
);
29851 while Present
(Comp
) loop
29852 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
29856 Next_Component
(Comp
);
29860 end Has_Unconstrained_Component
;
29864 Typ
: constant Entity_Id
:= Etype
(Item
);
29866 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29869 if Is_Tagged_Type
(Typ
) then
29872 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
29875 elsif Is_Record_Type
(Typ
) then
29876 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
29879 return Has_Unconstrained_Component
(Typ
);
29882 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
29888 end Is_Unconstrained_Or_Tagged_Item
;
29890 -----------------------------
29891 -- Is_Valid_Assertion_Kind --
29892 -----------------------------
29894 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
29901 | Name_Assertion_Policy
29902 | Name_Static_Predicate
29903 | Name_Dynamic_Predicate
29908 | Name_Type_Invariant
29909 | Name_uType_Invariant
29913 | Name_Assert_And_Cut
29915 | Name_Contract_Cases
29917 | Name_Default_Initial_Condition
29919 | Name_Initial_Condition
29922 | Name_Loop_Invariant
29923 | Name_Loop_Variant
29924 | Name_Postcondition
29925 | Name_Precondition
29927 | Name_Refined_Post
29928 | Name_Statement_Assertions
29935 end Is_Valid_Assertion_Kind
;
29937 --------------------------------------
29938 -- Process_Compilation_Unit_Pragmas --
29939 --------------------------------------
29941 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
29943 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29944 -- strange because it comes at the end of the unit. Rational has the
29945 -- same name for a pragma, but treats it as a program unit pragma, In
29946 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29947 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29948 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29949 -- the context clause to ensure the correct processing.
29951 if Has_Pragma_Suppress_All
(N
) then
29952 Prepend_To
(Context_Items
(N
),
29953 Make_Pragma
(Sloc
(N
),
29954 Chars
=> Name_Suppress
,
29955 Pragma_Argument_Associations
=> New_List
(
29956 Make_Pragma_Argument_Association
(Sloc
(N
),
29957 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
29960 -- Nothing else to do at the current time
29962 end Process_Compilation_Unit_Pragmas
;
29964 -------------------------------------------
29965 -- Process_Compile_Time_Warning_Or_Error --
29966 -------------------------------------------
29968 procedure Process_Compile_Time_Warning_Or_Error
29972 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
29973 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
29974 Arg2
: constant Node_Id
:= Next
(Arg1
);
29977 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
29979 if Compile_Time_Known_Value
(Arg1x
) then
29980 if Is_True
(Expr_Value
(Arg1x
)) then
29982 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29983 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
29984 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
29985 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
29986 Str_Len
: constant Nat
:= String_Length
(Str
);
29988 Force
: constant Boolean :=
29989 Prag_Id
= Pragma_Compile_Time_Warning
29990 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
29991 and then (Ekind
(Cent
) /= E_Package
29992 or else not In_Private_Part
(Cent
));
29993 -- Set True if this is the warning case, and we are in the
29994 -- visible part of a package spec, or in a subprogram spec,
29995 -- in which case we want to force the client to see the
29996 -- warning, even though it is not in the main unit.
30004 -- Loop through segments of message separated by line feeds.
30005 -- We output these segments as separate messages with
30006 -- continuation marks for all but the first.
30011 Error_Msg_Strlen
:= 0;
30013 -- Loop to copy characters from argument to error message
30017 exit when Ptr
> Str_Len
;
30018 CC
:= Get_String_Char
(Str
, Ptr
);
30021 -- Ignore wide chars ??? else store character
30023 if In_Character_Range
(CC
) then
30024 C
:= Get_Character
(CC
);
30025 exit when C
= ASCII
.LF
;
30026 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
30027 Error_Msg_String
(Error_Msg_Strlen
) := C
;
30031 -- Here with one line ready to go
30033 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
30035 -- If this is a warning in a spec, then we want clients
30036 -- to see the warning, so mark the message with the
30037 -- special sequence !! to force the warning. In the case
30038 -- of a package spec, we do not force this if we are in
30039 -- the private part of the spec.
30042 if Cont
= False then
30043 Error_Msg
("<<~!!", Eloc
);
30046 Error_Msg
("\<<~!!", Eloc
);
30049 -- Error, rather than warning, or in a body, so we do not
30050 -- need to force visibility for client (error will be
30051 -- output in any case, and this is the situation in which
30052 -- we do not want a client to get a warning, since the
30053 -- warning is in the body or the spec private part).
30056 if Cont
= False then
30057 Error_Msg
("<<~", Eloc
);
30060 Error_Msg
("\<<~", Eloc
);
30064 exit when Ptr
> Str_Len
;
30069 end Process_Compile_Time_Warning_Or_Error
;
30071 ------------------------------------
30072 -- Record_Possible_Body_Reference --
30073 ------------------------------------
30075 procedure Record_Possible_Body_Reference
30076 (State_Id
: Entity_Id
;
30080 Spec_Id
: Entity_Id
;
30083 -- Ensure that we are dealing with a reference to a state
30085 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
30087 -- Climb the tree starting from the reference looking for a package body
30088 -- whose spec declares the referenced state. This criteria automatically
30089 -- excludes references in package specs which are legal. Note that it is
30090 -- not wise to emit an error now as the package body may lack pragma
30091 -- Refined_State or the referenced state may not be mentioned in the
30092 -- refinement. This approach avoids the generation of misleading errors.
30095 while Present
(Context
) loop
30096 if Nkind
(Context
) = N_Package_Body
then
30097 Spec_Id
:= Corresponding_Spec
(Context
);
30099 if Present
(Abstract_States
(Spec_Id
))
30100 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
30102 if No
(Body_References
(State_Id
)) then
30103 Set_Body_References
(State_Id
, New_Elmt_List
);
30106 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
30111 Context
:= Parent
(Context
);
30113 end Record_Possible_Body_Reference
;
30115 ------------------------------------------
30116 -- Relocate_Pragmas_To_Anonymous_Object --
30117 ------------------------------------------
30119 procedure Relocate_Pragmas_To_Anonymous_Object
30120 (Typ_Decl
: Node_Id
;
30121 Obj_Decl
: Node_Id
)
30125 Next_Decl
: Node_Id
;
30128 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
30129 Def
:= Protected_Definition
(Typ_Decl
);
30131 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
30132 Def
:= Task_Definition
(Typ_Decl
);
30135 -- The concurrent definition has a visible declaration list. Inspect it
30136 -- and relocate all canidate pragmas.
30138 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
30139 Decl
:= First
(Visible_Declarations
(Def
));
30140 while Present
(Decl
) loop
30142 -- Preserve the following declaration for iteration purposes due
30143 -- to possible relocation of a pragma.
30145 Next_Decl
:= Next
(Decl
);
30147 if Nkind
(Decl
) = N_Pragma
30148 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
30151 Insert_After
(Obj_Decl
, Decl
);
30153 -- Skip internally generated code
30155 elsif not Comes_From_Source
(Decl
) then
30158 -- No candidate pragmas are available for relocation
30167 end Relocate_Pragmas_To_Anonymous_Object
;
30169 ------------------------------
30170 -- Relocate_Pragmas_To_Body --
30171 ------------------------------
30173 procedure Relocate_Pragmas_To_Body
30174 (Subp_Body
: Node_Id
;
30175 Target_Body
: Node_Id
:= Empty
)
30177 procedure Relocate_Pragma
(Prag
: Node_Id
);
30178 -- Remove a single pragma from its current list and add it to the
30179 -- declarations of the proper body (either Subp_Body or Target_Body).
30181 ---------------------
30182 -- Relocate_Pragma --
30183 ---------------------
30185 procedure Relocate_Pragma
(Prag
: Node_Id
) is
30190 -- When subprogram stubs or expression functions are involves, the
30191 -- destination declaration list belongs to the proper body.
30193 if Present
(Target_Body
) then
30194 Target
:= Target_Body
;
30196 Target
:= Subp_Body
;
30199 Decls
:= Declarations
(Target
);
30203 Set_Declarations
(Target
, Decls
);
30206 -- Unhook the pragma from its current list
30209 Prepend
(Prag
, Decls
);
30210 end Relocate_Pragma
;
30214 Body_Id
: constant Entity_Id
:=
30215 Defining_Unit_Name
(Specification
(Subp_Body
));
30216 Next_Stmt
: Node_Id
;
30219 -- Start of processing for Relocate_Pragmas_To_Body
30222 -- Do not process a body that comes from a separate unit as no construct
30223 -- can possibly follow it.
30225 if not Is_List_Member
(Subp_Body
) then
30228 -- Do not relocate pragmas that follow a stub if the stub does not have
30231 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
30232 and then No
(Target_Body
)
30236 -- Do not process internally generated routine _Postconditions
30238 elsif Ekind
(Body_Id
) = E_Procedure
30239 and then Chars
(Body_Id
) = Name_uPostconditions
30244 -- Look at what is following the body. We are interested in certain kind
30245 -- of pragmas (either from source or byproducts of expansion) that can
30246 -- apply to a body [stub].
30248 Stmt
:= Next
(Subp_Body
);
30249 while Present
(Stmt
) loop
30251 -- Preserve the following statement for iteration purposes due to a
30252 -- possible relocation of a pragma.
30254 Next_Stmt
:= Next
(Stmt
);
30256 -- Move a candidate pragma following the body to the declarations of
30259 if Nkind
(Stmt
) = N_Pragma
30260 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
30263 -- If a source pragma Warnings follows the body, it applies to
30264 -- following statements and does not belong in the body.
30266 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
30267 and then Comes_From_Source
(Stmt
)
30271 Relocate_Pragma
(Stmt
);
30274 -- Skip internally generated code
30276 elsif not Comes_From_Source
(Stmt
) then
30279 -- No candidate pragmas are available for relocation
30287 end Relocate_Pragmas_To_Body
;
30289 -------------------
30290 -- Resolve_State --
30291 -------------------
30293 procedure Resolve_State
(N
: Node_Id
) is
30298 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30299 Func
:= Entity
(N
);
30301 -- Handle overloading of state names by functions. Traverse the
30302 -- homonym chain looking for an abstract state.
30304 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
30305 pragma Assert
(Is_Overloaded
(N
));
30307 State
:= Homonym
(Func
);
30308 while Present
(State
) loop
30309 if Ekind
(State
) = E_Abstract_State
then
30311 -- Resolve the overloading by setting the proper entity of
30312 -- the reference to that of the state.
30314 Set_Etype
(N
, Standard_Void_Type
);
30315 Set_Entity
(N
, State
);
30316 Set_Is_Overloaded
(N
, False);
30318 Generate_Reference
(State
, N
);
30322 State
:= Homonym
(State
);
30325 -- A function can never act as a state. If the homonym chain does
30326 -- not contain a corresponding state, then something went wrong in
30327 -- the overloading mechanism.
30329 raise Program_Error
;
30334 ----------------------------
30335 -- Rewrite_Assertion_Kind --
30336 ----------------------------
30338 procedure Rewrite_Assertion_Kind
30340 From_Policy
: Boolean := False)
30346 if Nkind
(N
) = N_Attribute_Reference
30347 and then Attribute_Name
(N
) = Name_Class
30348 and then Nkind
(Prefix
(N
)) = N_Identifier
30350 case Chars
(Prefix
(N
)) is
30357 when Name_Type_Invariant
=>
30358 Nam
:= Name_uType_Invariant
;
30360 when Name_Invariant
=>
30361 Nam
:= Name_uInvariant
;
30367 -- Recommend standard use of aspect names Pre/Post
30369 elsif Nkind
(N
) = N_Identifier
30370 and then From_Policy
30371 and then Serious_Errors_Detected
= 0
30372 and then not ASIS_Mode
30374 if Chars
(N
) = Name_Precondition
30375 or else Chars
(N
) = Name_Postcondition
30377 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
30379 ("\use Assertion_Policy and aspect names Pre/Post for "
30380 & "Ada2012 conformance?", N
);
30386 if Nam
/= No_Name
then
30387 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
30389 end Rewrite_Assertion_Kind
;
30397 Dummy
:= Dummy
+ 1;
30400 --------------------------------
30401 -- Set_Encoded_Interface_Name --
30402 --------------------------------
30404 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
30405 Str
: constant String_Id
:= Strval
(S
);
30406 Len
: constant Nat
:= String_Length
(Str
);
30411 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
30414 -- Stores encoded value of character code CC. The encoding we use an
30415 -- underscore followed by four lower case hex digits.
30421 procedure Encode
is
30423 Store_String_Char
(Get_Char_Code
('_'));
30425 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
30427 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
30429 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
30431 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
30434 -- Start of processing for Set_Encoded_Interface_Name
30437 -- If first character is asterisk, this is a link name, and we leave it
30438 -- completely unmodified. We also ignore null strings (the latter case
30439 -- happens only in error cases).
30442 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
30444 Set_Interface_Name
(E
, S
);
30449 CC
:= Get_String_Char
(Str
, J
);
30451 exit when not In_Character_Range
(CC
);
30453 C
:= Get_Character
(CC
);
30455 exit when C
/= '_' and then C
/= '$'
30456 and then C
not in '0' .. '9'
30457 and then C
not in 'a' .. 'z'
30458 and then C
not in 'A' .. 'Z';
30461 Set_Interface_Name
(E
, S
);
30469 -- Here we need to encode. The encoding we use as follows:
30470 -- three underscores + four hex digits (lower case)
30474 for J
in 1 .. String_Length
(Str
) loop
30475 CC
:= Get_String_Char
(Str
, J
);
30477 if not In_Character_Range
(CC
) then
30480 C
:= Get_Character
(CC
);
30482 if C
= '_' or else C
= '$'
30483 or else C
in '0' .. '9'
30484 or else C
in 'a' .. 'z'
30485 or else C
in 'A' .. 'Z'
30487 Store_String_Char
(CC
);
30494 Set_Interface_Name
(E
,
30495 Make_String_Literal
(Sloc
(S
),
30496 Strval
=> End_String
));
30498 end Set_Encoded_Interface_Name
;
30500 ------------------------
30501 -- Set_Elab_Unit_Name --
30502 ------------------------
30504 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
30509 if Nkind
(N
) = N_Identifier
30510 and then Nkind
(With_Item
) = N_Identifier
30512 Set_Entity
(N
, Entity
(With_Item
));
30514 elsif Nkind
(N
) = N_Selected_Component
then
30515 Change_Selected_Component_To_Expanded_Name
(N
);
30516 Set_Entity
(N
, Entity
(With_Item
));
30517 Set_Entity
(Selector_Name
(N
), Entity
(N
));
30519 Pref
:= Prefix
(N
);
30520 Scop
:= Scope
(Entity
(N
));
30521 while Nkind
(Pref
) = N_Selected_Component
loop
30522 Change_Selected_Component_To_Expanded_Name
(Pref
);
30523 Set_Entity
(Selector_Name
(Pref
), Scop
);
30524 Set_Entity
(Pref
, Scop
);
30525 Pref
:= Prefix
(Pref
);
30526 Scop
:= Scope
(Scop
);
30529 Set_Entity
(Pref
, Scop
);
30532 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
30533 end Set_Elab_Unit_Name
;
30535 -------------------
30536 -- Test_Case_Arg --
30537 -------------------
30539 function Test_Case_Arg
30542 From_Aspect
: Boolean := False) return Node_Id
30544 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
30549 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
30554 -- The caller requests the aspect argument
30556 if From_Aspect
then
30557 if Present
(Aspect
)
30558 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
30560 Args
:= Expression
(Aspect
);
30562 -- "Name" and "Mode" may appear without an identifier as a
30563 -- positional association.
30565 if Present
(Expressions
(Args
)) then
30566 Arg
:= First
(Expressions
(Args
));
30568 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30576 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30581 -- Some or all arguments may appear as component associatons
30583 if Present
(Component_Associations
(Args
)) then
30584 Arg
:= First
(Component_Associations
(Args
));
30585 while Present
(Arg
) loop
30586 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
30595 -- Otherwise retrieve the argument directly from the pragma
30598 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30600 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30604 -- Skip argument "Name"
30608 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30612 -- Skip argument "Mode"
30616 -- Arguments "Requires" and "Ensures" are optional and may not be
30619 while Present
(Arg
) loop
30620 if Chars
(Arg
) = Arg_Nam
then