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 -- When the initialization item is undefined, it appears as
2822 -- Any_Id. Do not continue with the analysis of the item.
2824 if Item_Id
= Any_Id
then
2827 -- The state or variable must be declared in the visible
2828 -- declarations of the package (SPARK RM 7.1.5(7)).
2830 elsif not Contains
(States_And_Objs
, Item_Id
) then
2831 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2833 ("initialization item & must appear in the visible "
2834 & "declarations of package %", Item
, Item_Id
);
2836 -- Detect a duplicate use of the same initialization item
2837 -- (SPARK RM 7.1.5(5)).
2839 elsif Contains
(Items_Seen
, Item_Id
) then
2840 SPARK_Msg_N
("duplicate initialization item", Item
);
2842 -- The item is legal, add it to the list of processed states
2846 Append_New_Elmt
(Item_Id
, Items_Seen
);
2848 if Ekind
(Item_Id
) = E_Abstract_State
then
2849 Append_New_Elmt
(Item_Id
, States_Seen
);
2852 if Present
(Encapsulating_State
(Item_Id
)) then
2853 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2857 -- The item references something that is not a state or object
2858 -- (SPARK RM 7.1.5(3)).
2862 ("initialization item must denote object or state", Item
);
2865 -- Some form of illegal construct masquerading as a name
2866 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2870 ("initialization item must denote object or state", Item
);
2873 end Analyze_Initialization_Item
;
2875 ---------------------------------------------
2876 -- Analyze_Initialization_Item_With_Inputs --
2877 ---------------------------------------------
2879 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2880 Inputs_Seen
: Elist_Id
:= No_Elist
;
2881 -- A list of all inputs processed so far. This list is used to detect
2882 -- duplicate uses of an input.
2884 Non_Null_Seen
: Boolean := False;
2885 Null_Seen
: Boolean := False;
2886 -- Flags used to check the legality of an input list
2888 procedure Analyze_Input_Item
(Input
: Node_Id
);
2889 -- Verify the legality of a single input item
2891 ------------------------
2892 -- Analyze_Input_Item --
2893 ------------------------
2895 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2896 Input_Id
: Entity_Id
;
2897 Input_OK
: Boolean := True;
2902 if Nkind
(Input
) = N_Null
then
2905 ("multiple null initializations not allowed", Item
);
2907 elsif Non_Null_Seen
then
2909 ("cannot mix null and non-null initialization item", Item
);
2917 Non_Null_Seen
:= True;
2921 ("cannot mix null and non-null initialization item", Item
);
2925 Resolve_State
(Input
);
2927 if Is_Entity_Name
(Input
) then
2928 Input_Id
:= Entity_Of
(Input
);
2930 if Present
(Input_Id
)
2931 and then Ekind_In
(Input_Id
, E_Abstract_State
,
2933 E_Generic_In_Out_Parameter
,
2934 E_Generic_In_Parameter
,
2940 -- The input cannot denote states or objects declared
2941 -- within the related package (SPARK RM 7.1.5(4)).
2943 if Within_Scope
(Input_Id
, Current_Scope
) then
2945 -- Do not consider generic formal parameters or their
2946 -- respective mappings to generic formals. Even though
2947 -- the formals appear within the scope of the package,
2948 -- it is allowed for an initialization item to depend
2949 -- on an input item.
2951 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2952 E_Generic_In_Parameter
)
2956 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2957 and then Present
(Corresponding_Generic_Association
2958 (Declaration_Node
(Input_Id
)))
2964 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2966 ("input item & cannot denote a visible object or "
2967 & "state of package %", Input
, Input_Id
);
2971 -- Detect a duplicate use of the same input item
2972 -- (SPARK RM 7.1.5(5)).
2974 if Contains
(Inputs_Seen
, Input_Id
) then
2976 SPARK_Msg_N
("duplicate input item", Input
);
2979 -- Input is legal, add it to the list of processed inputs
2982 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2984 if Ekind
(Input_Id
) = E_Abstract_State
then
2985 Append_New_Elmt
(Input_Id
, States_Seen
);
2988 if Ekind_In
(Input_Id
, E_Abstract_State
,
2991 and then Present
(Encapsulating_State
(Input_Id
))
2993 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2997 -- The input references something that is not a state or an
2998 -- object (SPARK RM 7.1.5(3)).
3002 ("input item must denote object or state", Input
);
3005 -- Some form of illegal construct masquerading as a name
3006 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
3010 ("input item must denote object or state", Input
);
3013 end Analyze_Input_Item
;
3017 Inputs
: constant Node_Id
:= Expression
(Item
);
3021 Name_Seen
: Boolean := False;
3022 -- A flag used to detect multiple item names
3024 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3027 -- Inspect the name of an item with inputs
3029 Elmt
:= First
(Choices
(Item
));
3030 while Present
(Elmt
) loop
3032 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3035 Analyze_Initialization_Item
(Elmt
);
3041 -- Multiple input items appear as an aggregate
3043 if Nkind
(Inputs
) = N_Aggregate
then
3044 if Present
(Expressions
(Inputs
)) then
3045 Input
:= First
(Expressions
(Inputs
));
3046 while Present
(Input
) loop
3047 Analyze_Input_Item
(Input
);
3052 if Present
(Component_Associations
(Inputs
)) then
3054 ("inputs must appear in named association form", Inputs
);
3057 -- Single input item
3060 Analyze_Input_Item
(Inputs
);
3062 end Analyze_Initialization_Item_With_Inputs
;
3064 --------------------------------
3065 -- Collect_States_And_Objects --
3066 --------------------------------
3068 procedure Collect_States_And_Objects
is
3069 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3073 -- Collect the abstract states defined in the package (if any)
3075 if Present
(Abstract_States
(Pack_Id
)) then
3076 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3079 -- Collect all objects that appear in the visible declarations of the
3082 if Present
(Visible_Declarations
(Pack_Spec
)) then
3083 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3084 while Present
(Decl
) loop
3085 if Comes_From_Source
(Decl
)
3086 and then Nkind_In
(Decl
, N_Object_Declaration
,
3087 N_Object_Renaming_Declaration
)
3089 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3091 elsif Is_Single_Concurrent_Type_Declaration
(Decl
) then
3093 (Anonymous_Object
(Defining_Entity
(Decl
)),
3100 end Collect_States_And_Objects
;
3104 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3107 -- Start of processing for Analyze_Initializes_In_Decl_Part
3110 -- Do not analyze the pragma multiple times
3112 if Is_Analyzed_Pragma
(N
) then
3116 -- Nothing to do when the initialization list is empty
3118 if Nkind
(Inits
) = N_Null
then
3122 -- Single and multiple initialization clauses appear as an aggregate. If
3123 -- this is not the case, then either the parser or the analysis of the
3124 -- pragma failed to produce an aggregate.
3126 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3128 -- Initialize the various lists used during analysis
3130 Collect_States_And_Objects
;
3132 if Present
(Expressions
(Inits
)) then
3133 Init
:= First
(Expressions
(Inits
));
3134 while Present
(Init
) loop
3135 Analyze_Initialization_Item
(Init
);
3140 if Present
(Component_Associations
(Inits
)) then
3141 Init
:= First
(Component_Associations
(Inits
));
3142 while Present
(Init
) loop
3143 Analyze_Initialization_Item_With_Inputs
(Init
);
3148 -- Ensure that a state and a corresponding constituent do not appear
3149 -- together in pragma Initializes.
3151 Check_State_And_Constituent_Use
3152 (States
=> States_Seen
,
3153 Constits
=> Constits_Seen
,
3156 Set_Is_Analyzed_Pragma
(N
);
3157 end Analyze_Initializes_In_Decl_Part
;
3159 ---------------------
3160 -- Analyze_Part_Of --
3161 ---------------------
3163 procedure Analyze_Part_Of
3165 Item_Id
: Entity_Id
;
3167 Encap_Id
: out Entity_Id
;
3168 Legal
: out Boolean)
3170 Encap_Typ
: Entity_Id
;
3171 Item_Decl
: Node_Id
;
3172 Pack_Id
: Entity_Id
;
3173 Placement
: State_Space_Kind
;
3174 Parent_Unit
: Entity_Id
;
3177 -- Assume that the indicator is illegal
3182 if Nkind_In
(Encap
, N_Expanded_Name
,
3184 N_Selected_Component
)
3187 Resolve_State
(Encap
);
3189 Encap_Id
:= Entity
(Encap
);
3191 -- The encapsulator is an abstract state
3193 if Ekind
(Encap_Id
) = E_Abstract_State
then
3196 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3198 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3201 -- Otherwise the encapsulator is not a legal choice
3205 ("indicator Part_Of must denote abstract state, single "
3206 & "protected type or single task type", Encap
);
3210 -- This is a syntax error, always report
3214 ("indicator Part_Of must denote abstract state, single protected "
3215 & "type or single task type", Encap
);
3219 -- Catch a case where indicator Part_Of denotes the abstract view of a
3220 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3222 if From_Limited_With
(Encap_Id
)
3223 and then Present
(Non_Limited_View
(Encap_Id
))
3224 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3226 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3227 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3231 -- The encapsulator is an abstract state
3233 if Ekind
(Encap_Id
) = E_Abstract_State
then
3235 -- Determine where the object, package instantiation or state lives
3236 -- with respect to the enclosing packages or package bodies.
3238 Find_Placement_In_State_Space
3239 (Item_Id
=> Item_Id
,
3240 Placement
=> Placement
,
3241 Pack_Id
=> Pack_Id
);
3243 -- The item appears in a non-package construct with a declarative
3244 -- part (subprogram, block, etc). As such, the item is not allowed
3245 -- to be a part of an encapsulating state because the item is not
3248 if Placement
= Not_In_Package
then
3250 ("indicator Part_Of cannot appear in this context "
3251 & "(SPARK RM 7.2.6(5))", Indic
);
3252 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3254 ("\& is not part of the hidden state of package %",
3258 -- The item appears in the visible state space of some package. In
3259 -- general this scenario does not warrant Part_Of except when the
3260 -- package is a private child unit and the encapsulating state is
3261 -- declared in a parent unit or a public descendant of that parent
3264 elsif Placement
= Visible_State_Space
then
3265 if Is_Child_Unit
(Pack_Id
)
3266 and then Is_Private_Descendant
(Pack_Id
)
3268 -- A variable or state abstraction which is part of the visible
3269 -- state of a private child unit (or one of its public
3270 -- descendants) must have its Part_Of indicator specified. The
3271 -- Part_Of indicator must denote a state abstraction declared
3272 -- by either the parent unit of the private unit or by a public
3273 -- descendant of that parent unit.
3275 -- Find nearest private ancestor (which can be the current unit
3278 Parent_Unit
:= Pack_Id
;
3279 while Present
(Parent_Unit
) loop
3282 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3283 Parent_Unit
:= Scope
(Parent_Unit
);
3286 Parent_Unit
:= Scope
(Parent_Unit
);
3288 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3290 ("indicator Part_Of must denote abstract state of & "
3291 & "or of its public descendant (SPARK RM 7.2.6(3))",
3292 Indic
, Parent_Unit
);
3295 elsif Scope
(Encap_Id
) = Parent_Unit
3297 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3298 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3304 ("indicator Part_Of must denote abstract state of & "
3305 & "or of its public descendant (SPARK RM 7.2.6(3))",
3306 Indic
, Parent_Unit
);
3310 -- Indicator Part_Of is not needed when the related package is not
3311 -- a private child unit or a public descendant thereof.
3315 ("indicator Part_Of cannot appear in this context "
3316 & "(SPARK RM 7.2.6(5))", Indic
);
3317 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3319 ("\& is declared in the visible part of package %",
3324 -- When the item appears in the private state space of a package, the
3325 -- encapsulating state must be declared in the same package.
3327 elsif Placement
= Private_State_Space
then
3328 if Scope
(Encap_Id
) /= Pack_Id
then
3330 ("indicator Part_Of must denote an abstract state of "
3331 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3332 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3334 ("\& is declared in the private part of package %",
3339 -- Items declared in the body state space of a package do not need
3340 -- Part_Of indicators as the refinement has already been seen.
3344 ("indicator Part_Of cannot appear in this context "
3345 & "(SPARK RM 7.2.6(5))", Indic
);
3347 if Scope
(Encap_Id
) = Pack_Id
then
3348 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3350 ("\& is declared in the body of package %", Indic
, Item_Id
);
3356 -- The encapsulator is a single concurrent type
3359 Encap_Typ
:= Etype
(Encap_Id
);
3361 -- Only abstract states and variables can act as constituents of an
3362 -- encapsulating single concurrent type.
3364 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3367 -- The constituent is a constant
3369 elsif Ekind
(Item_Id
) = E_Constant
then
3370 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3372 (Fix_Msg
(Encap_Typ
, "constant & cannot act as constituent of "
3373 & "single protected type %"), Indic
, Item_Id
);
3376 -- The constituent is a package instantiation
3379 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3381 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3382 & "constituent of single protected type %"), Indic
, Item_Id
);
3386 -- When the item denotes an abstract state of a nested package, use
3387 -- the declaration of the package to detect proper placement.
3392 -- with Abstract_State => (State with Part_Of => T)
3394 if Ekind
(Item_Id
) = E_Abstract_State
then
3395 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3397 Item_Decl
:= Declaration_Node
(Item_Id
);
3400 -- Both the item and its encapsulating single concurrent type must
3401 -- appear in the same declarative region (SPARK RM 9.3). Note that
3402 -- privacy is ignored.
3404 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3405 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3407 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3408 & "immediately within the same region as single protected "
3409 & "type %"), Indic
, Item_Id
);
3413 -- The declaration of the item should follow the declaration of its
3414 -- encapsulating single concurrent type and must appear in the same
3415 -- declarative region (SPARK RM 9.3).
3421 N
:= Next
(Declaration_Node
(Encap_Id
));
3422 while Present
(N
) loop
3423 exit when N
= Item_Decl
;
3427 -- The single concurrent type might be in the visible part of a
3428 -- package, and the declaration of the item in the private part
3429 -- of the same package.
3433 Pack
: constant Node_Id
:=
3434 Parent
(Declaration_Node
(Encap_Id
));
3436 if Nkind
(Pack
) = N_Package_Specification
3437 and then not In_Private_Part
(Encap_Id
)
3439 N
:= First
(Private_Declarations
(Pack
));
3440 while Present
(N
) loop
3441 exit when N
= Item_Decl
;
3450 ("indicator Part_Of must denote a previously declared "
3451 & "single protected type or single task type", Encap
);
3458 end Analyze_Part_Of
;
3460 ----------------------------------
3461 -- Analyze_Part_Of_In_Decl_Part --
3462 ----------------------------------
3464 procedure Analyze_Part_Of_In_Decl_Part
3466 Freeze_Id
: Entity_Id
:= Empty
)
3468 Encap
: constant Node_Id
:=
3469 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3470 Errors
: constant Nat
:= Serious_Errors_Detected
;
3471 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3472 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3473 Constits
: Elist_Id
;
3474 Encap_Id
: Entity_Id
;
3478 -- Detect any discrepancies between the placement of the variable with
3479 -- respect to general state space and the encapsulating state or single
3486 Encap_Id
=> Encap_Id
,
3489 -- The Part_Of indicator turns the variable into a constituent of the
3490 -- encapsulating state or single concurrent type.
3493 pragma Assert
(Present
(Encap_Id
));
3494 Constits
:= Part_Of_Constituents
(Encap_Id
);
3496 if No
(Constits
) then
3497 Constits
:= New_Elmt_List
;
3498 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3501 Append_Elmt
(Var_Id
, Constits
);
3502 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3504 -- A Part_Of constituent partially refines an abstract state. This
3505 -- property does not apply to protected or task units.
3507 if Ekind
(Encap_Id
) = E_Abstract_State
then
3508 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3512 -- Emit a clarification message when the encapsulator is undefined,
3513 -- possibly due to contract freezing.
3515 if Errors
/= Serious_Errors_Detected
3516 and then Present
(Freeze_Id
)
3517 and then Has_Undefined_Reference
(Encap
)
3519 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3521 end Analyze_Part_Of_In_Decl_Part
;
3523 --------------------
3524 -- Analyze_Pragma --
3525 --------------------
3527 procedure Analyze_Pragma
(N
: Node_Id
) is
3528 Loc
: constant Source_Ptr
:= Sloc
(N
);
3530 Pname
: Name_Id
:= Pragma_Name
(N
);
3531 -- Name of the source pragma, or name of the corresponding aspect for
3532 -- pragmas which originate in a source aspect. In the latter case, the
3533 -- name may be different from the pragma name.
3535 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3537 Pragma_Exit
: exception;
3538 -- This exception is used to exit pragma processing completely. It
3539 -- is used when an error is detected, and no further processing is
3540 -- required. It is also used if an earlier error has left the tree in
3541 -- a state where the pragma should not be processed.
3544 -- Number of pragma argument associations
3550 -- First four pragma arguments (pragma argument association nodes, or
3551 -- Empty if the corresponding argument does not exist).
3553 type Name_List
is array (Natural range <>) of Name_Id
;
3554 type Args_List
is array (Natural range <>) of Node_Id
;
3555 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3557 -----------------------
3558 -- Local Subprograms --
3559 -----------------------
3561 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3562 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3563 -- get the given string argument, and place it in Name_Buffer, adding
3564 -- leading and trailing asterisks if they are not already present. The
3565 -- caller has already checked that Arg is a static string expression.
3567 procedure Ada_2005_Pragma
;
3568 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3569 -- Ada 95 mode, these are implementation defined pragmas, so should be
3570 -- caught by the No_Implementation_Pragmas restriction.
3572 procedure Ada_2012_Pragma
;
3573 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3574 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3575 -- should be caught by the No_Implementation_Pragmas restriction.
3577 procedure Analyze_Depends_Global
3578 (Spec_Id
: out Entity_Id
;
3579 Subp_Decl
: out Node_Id
;
3580 Legal
: out Boolean);
3581 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3582 -- legality of the placement and related context of the pragma. Spec_Id
3583 -- is the entity of the related subprogram. Subp_Decl is the declaration
3584 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3586 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3587 -- Inspect the remainder of the list containing pragma N and look for
3588 -- a pragma that matches Id. If found, analyze the pragma.
3590 procedure Analyze_Pre_Post_Condition
;
3591 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3593 procedure Analyze_Refined_Depends_Global_Post
3594 (Spec_Id
: out Entity_Id
;
3595 Body_Id
: out Entity_Id
;
3596 Legal
: out Boolean);
3597 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3598 -- Refined_Global and Refined_Post. Verify the legality of the placement
3599 -- and related context of the pragma. Spec_Id is the entity of the
3600 -- related subprogram. Body_Id is the entity of the subprogram body.
3601 -- Flag Legal is set when the pragma is legal.
3603 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3604 -- Perform full analysis of pragma Unmodified and the write aspect of
3605 -- pragma Unused. Flag Is_Unused should be set when verifying the
3606 -- semantics of pragma Unused.
3608 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3609 -- Perform full analysis of pragma Unreferenced and the read aspect of
3610 -- pragma Unused. Flag Is_Unused should be set when verifying the
3611 -- semantics of pragma Unused.
3613 procedure Check_Ada_83_Warning
;
3614 -- Issues a warning message for the current pragma if operating in Ada
3615 -- 83 mode (used for language pragmas that are not a standard part of
3616 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3619 procedure Check_Arg_Count
(Required
: Nat
);
3620 -- Check argument count for pragma is equal to given parameter. If not,
3621 -- then issue an error message and raise Pragma_Exit.
3623 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3624 -- Arg which can either be a pragma argument association, in which case
3625 -- the check is applied to the expression of the association or an
3626 -- expression directly.
3628 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3629 -- Check that an argument has the right form for an EXTERNAL_NAME
3630 -- parameter of an extended import/export pragma. The rule is that the
3631 -- name must be an identifier or string literal (in Ada 83 mode) or a
3632 -- static string expression (in Ada 95 mode).
3634 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3635 -- Check the specified argument Arg to make sure that it is an
3636 -- identifier. If not give error and raise Pragma_Exit.
3638 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3639 -- Check the specified argument Arg to make sure that it is an integer
3640 -- literal. If not give error and raise Pragma_Exit.
3642 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3643 -- Check the specified argument Arg to make sure that it has the proper
3644 -- syntactic form for a local name and meets the semantic requirements
3645 -- for a local name. The local name is analyzed as part of the
3646 -- processing for this call. In addition, the local name is required
3647 -- to represent an entity at the library level.
3649 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3650 -- Check the specified argument Arg to make sure that it has the proper
3651 -- syntactic form for a local name and meets the semantic requirements
3652 -- for a local name. The local name is analyzed as part of the
3653 -- processing for this call.
3655 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3656 -- Check the specified argument Arg to make sure that it is a valid
3657 -- locking policy name. If not give error and raise Pragma_Exit.
3659 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3660 -- Check the specified argument Arg to make sure that it is a valid
3661 -- elaboration policy name. If not give error and raise Pragma_Exit.
3663 procedure Check_Arg_Is_One_Of
3666 procedure Check_Arg_Is_One_Of
3668 N1
, N2
, N3
: Name_Id
);
3669 procedure Check_Arg_Is_One_Of
3671 N1
, N2
, N3
, N4
: Name_Id
);
3672 procedure Check_Arg_Is_One_Of
3674 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3675 -- Check the specified argument Arg to make sure that it is an
3676 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3677 -- present). If not then give error and raise Pragma_Exit.
3679 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3680 -- Check the specified argument Arg to make sure that it is a valid
3681 -- queuing policy name. If not give error and raise Pragma_Exit.
3683 procedure Check_Arg_Is_OK_Static_Expression
3685 Typ
: Entity_Id
:= Empty
);
3686 -- Check the specified argument Arg to make sure that it is a static
3687 -- expression of the given type (i.e. it will be analyzed and resolved
3688 -- using this type, which can be any valid argument to Resolve, e.g.
3689 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3690 -- Typ is left Empty, then any static expression is allowed. Includes
3691 -- checking that the argument does not raise Constraint_Error.
3693 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3694 -- Check the specified argument Arg to make sure that it is a valid task
3695 -- dispatching policy name. If not give error and raise Pragma_Exit.
3697 procedure Check_Arg_Order
(Names
: Name_List
);
3698 -- Checks for an instance of two arguments with identifiers for the
3699 -- current pragma which are not in the sequence indicated by Names,
3700 -- and if so, generates a fatal message about bad order of arguments.
3702 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3703 -- Check there are at least N arguments present
3705 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3706 -- Check there are no more than N arguments present
3708 procedure Check_Component
3711 In_Variant_Part
: Boolean := False);
3712 -- Examine an Unchecked_Union component for correct use of per-object
3713 -- constrained subtypes, and for restrictions on finalizable components.
3714 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3715 -- should be set when Comp comes from a record variant.
3717 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3718 -- Check if a rep item of the same name as the current pragma is already
3719 -- chained as a rep pragma to the given entity. If so give a message
3720 -- about the duplicate, and then raise Pragma_Exit so does not return.
3721 -- Note that if E is a type, then this routine avoids flagging a pragma
3722 -- which applies to a parent type from which E is derived.
3724 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3725 -- Nam is an N_String_Literal node containing the external name set by
3726 -- an Import or Export pragma (or extended Import or Export pragma).
3727 -- This procedure checks for possible duplications if this is the export
3728 -- case, and if found, issues an appropriate error message.
3730 procedure Check_Expr_Is_OK_Static_Expression
3732 Typ
: Entity_Id
:= Empty
);
3733 -- Check the specified expression Expr to make sure that it is a static
3734 -- expression of the given type (i.e. it will be analyzed and resolved
3735 -- using this type, which can be any valid argument to Resolve, e.g.
3736 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3737 -- Typ is left Empty, then any static expression is allowed. Includes
3738 -- checking that the expression does not raise Constraint_Error.
3740 procedure Check_First_Subtype
(Arg
: Node_Id
);
3741 -- Checks that Arg, whose expression is an entity name, references a
3744 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3745 -- Checks that the given argument has an identifier, and if so, requires
3746 -- it to match the given identifier name. If there is no identifier, or
3747 -- a non-matching identifier, then an error message is given and
3748 -- Pragma_Exit is raised.
3750 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3751 -- Checks that the given argument has an identifier, and if so, requires
3752 -- it to match one of the given identifier names. If there is no
3753 -- identifier, or a non-matching identifier, then an error message is
3754 -- given and Pragma_Exit is raised.
3756 procedure Check_In_Main_Program
;
3757 -- Common checks for pragmas that appear within a main program
3758 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3760 procedure Check_Interrupt_Or_Attach_Handler
;
3761 -- Common processing for first argument of pragma Interrupt_Handler or
3762 -- pragma Attach_Handler.
3764 procedure Check_Loop_Pragma_Placement
;
3765 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3766 -- appear immediately within a construct restricted to loops, and that
3767 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3769 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3770 -- Check that pragma appears in a declarative part, or in a package
3771 -- specification, i.e. that it does not occur in a statement sequence
3774 procedure Check_No_Identifier
(Arg
: Node_Id
);
3775 -- Checks that the given argument does not have an identifier. If
3776 -- an identifier is present, then an error message is issued, and
3777 -- Pragma_Exit is raised.
3779 procedure Check_No_Identifiers
;
3780 -- Checks that none of the arguments to the pragma has an identifier.
3781 -- If any argument has an identifier, then an error message is issued,
3782 -- and Pragma_Exit is raised.
3784 procedure Check_No_Link_Name
;
3785 -- Checks that no link name is specified
3787 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3788 -- Checks if the given argument has an identifier, and if so, requires
3789 -- it to match the given identifier name. If there is a non-matching
3790 -- identifier, then an error message is given and Pragma_Exit is raised.
3792 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3793 -- Checks if the given argument has an identifier, and if so, requires
3794 -- it to match the given identifier name. If there is a non-matching
3795 -- identifier, then an error message is given and Pragma_Exit is raised.
3796 -- In this version of the procedure, the identifier name is given as
3797 -- a string with lower case letters.
3799 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3800 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3801 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3802 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3803 -- is an OK static boolean expression. Emit an error if this is not the
3806 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3807 -- Constr is a constraint from an N_Subtype_Indication node from a
3808 -- component constraint in an Unchecked_Union type. This routine checks
3809 -- that the constraint is static as required by the restrictions for
3812 procedure Check_Valid_Configuration_Pragma
;
3813 -- Legality checks for placement of a configuration pragma
3815 procedure Check_Valid_Library_Unit_Pragma
;
3816 -- Legality checks for library unit pragmas. A special case arises for
3817 -- pragmas in generic instances that come from copies of the original
3818 -- library unit pragmas in the generic templates. In the case of other
3819 -- than library level instantiations these can appear in contexts which
3820 -- would normally be invalid (they only apply to the original template
3821 -- and to library level instantiations), and they are simply ignored,
3822 -- which is implemented by rewriting them as null statements.
3824 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3825 -- Check an Unchecked_Union variant for lack of nested variants and
3826 -- presence of at least one component. UU_Typ is the related Unchecked_
3829 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3830 -- Subsidiary routine to the processing of pragmas Abstract_State,
3831 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3832 -- Refined_Global and Refined_State. Transform argument Arg into
3833 -- an aggregate if not one already. N_Null is never transformed.
3834 -- Arg may denote an aspect specification or a pragma argument
3837 procedure Error_Pragma
(Msg
: String);
3838 pragma No_Return
(Error_Pragma
);
3839 -- Outputs error message for current pragma. The message contains a %
3840 -- that will be replaced with the pragma name, and the flag is placed
3841 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3842 -- calls Fix_Error (see spec of that procedure for details).
3844 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3845 pragma No_Return
(Error_Pragma_Arg
);
3846 -- Outputs error message for current pragma. The message may contain
3847 -- a % that will be replaced with the pragma name. The parameter Arg
3848 -- may either be a pragma argument association, in which case the flag
3849 -- is placed on the expression of this association, or an expression,
3850 -- in which case the flag is placed directly on the expression. The
3851 -- message is placed using Error_Msg_N, so the message may also contain
3852 -- an & insertion character which will reference the given Arg value.
3853 -- After placing the message, Pragma_Exit is raised. Note: this routine
3854 -- calls Fix_Error (see spec of that procedure for details).
3856 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3857 pragma No_Return
(Error_Pragma_Arg
);
3858 -- Similar to above form of Error_Pragma_Arg except that two messages
3859 -- are provided, the second is a continuation comment starting with \.
3861 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3862 pragma No_Return
(Error_Pragma_Arg_Ident
);
3863 -- Outputs error message for current pragma. The message may contain a %
3864 -- that will be replaced with the pragma name. The parameter Arg must be
3865 -- a pragma argument association with a non-empty identifier (i.e. its
3866 -- Chars field must be set), and the error message is placed on the
3867 -- identifier. The message is placed using Error_Msg_N so the message
3868 -- may also contain an & insertion character which will reference
3869 -- the identifier. After placing the message, Pragma_Exit is raised.
3870 -- Note: this routine calls Fix_Error (see spec of that procedure for
3873 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3874 pragma No_Return
(Error_Pragma_Ref
);
3875 -- Outputs error message for current pragma. The message may contain
3876 -- a % that will be replaced with the pragma name. The parameter Ref
3877 -- must be an entity whose name can be referenced by & and sloc by #.
3878 -- After placing the message, Pragma_Exit is raised. Note: this routine
3879 -- calls Fix_Error (see spec of that procedure for details).
3881 function Find_Lib_Unit_Name
return Entity_Id
;
3882 -- Used for a library unit pragma to find the entity to which the
3883 -- library unit pragma applies, returns the entity found.
3885 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3886 -- If the pragma is a compilation unit pragma, the id must denote the
3887 -- compilation unit in the same compilation, and the pragma must appear
3888 -- in the list of preceding or trailing pragmas. If it is a program
3889 -- unit pragma that is not a compilation unit pragma, then the
3890 -- identifier must be visible.
3892 function Find_Unique_Parameterless_Procedure
3894 Arg
: Node_Id
) return Entity_Id
;
3895 -- Used for a procedure pragma to find the unique parameterless
3896 -- procedure identified by Name, returns it if it exists, otherwise
3897 -- errors out and uses Arg as the pragma argument for the message.
3899 function Fix_Error
(Msg
: String) return String;
3900 -- This is called prior to issuing an error message. Msg is the normal
3901 -- error message issued in the pragma case. This routine checks for the
3902 -- case of a pragma coming from an aspect in the source, and returns a
3903 -- message suitable for the aspect case as follows:
3905 -- Each substring "pragma" is replaced by "aspect"
3907 -- If "argument of" is at the start of the error message text, it is
3908 -- replaced by "entity for".
3910 -- If "argument" is at the start of the error message text, it is
3911 -- replaced by "entity".
3913 -- So for example, "argument of pragma X must be discrete type"
3914 -- returns "entity for aspect X must be a discrete type".
3916 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3917 -- be different from the pragma name). If the current pragma results
3918 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3919 -- original pragma name.
3921 procedure Gather_Associations
3923 Args
: out Args_List
);
3924 -- This procedure is used to gather the arguments for a pragma that
3925 -- permits arbitrary ordering of parameters using the normal rules
3926 -- for named and positional parameters. The Names argument is a list
3927 -- of Name_Id values that corresponds to the allowed pragma argument
3928 -- association identifiers in order. The result returned in Args is
3929 -- a list of corresponding expressions that are the pragma arguments.
3930 -- Note that this is a list of expressions, not of pragma argument
3931 -- associations (Gather_Associations has completely checked all the
3932 -- optional identifiers when it returns). An entry in Args is Empty
3933 -- on return if the corresponding argument is not present.
3935 procedure GNAT_Pragma
;
3936 -- Called for all GNAT defined pragmas to check the relevant restriction
3937 -- (No_Implementation_Pragmas).
3939 function Is_Before_First_Decl
3940 (Pragma_Node
: Node_Id
;
3941 Decls
: List_Id
) return Boolean;
3942 -- Return True if Pragma_Node is before the first declarative item in
3943 -- Decls where Decls is the list of declarative items.
3945 function Is_Configuration_Pragma
return Boolean;
3946 -- Determines if the placement of the current pragma is appropriate
3947 -- for a configuration pragma.
3949 function Is_In_Context_Clause
return Boolean;
3950 -- Returns True if pragma appears within the context clause of a unit,
3951 -- and False for any other placement (does not generate any messages).
3953 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3954 -- Analyzes the argument, and determines if it is a static string
3955 -- expression, returns True if so, False if non-static or not String.
3956 -- A special case is that a string literal returns True in Ada 83 mode
3957 -- (which has no such thing as static string expressions). Note that
3958 -- the call analyzes its argument, so this cannot be used for the case
3959 -- where an identifier might not be declared.
3961 procedure Pragma_Misplaced
;
3962 pragma No_Return
(Pragma_Misplaced
);
3963 -- Issue fatal error message for misplaced pragma
3965 procedure Process_Atomic_Independent_Shared_Volatile
;
3966 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3967 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3968 -- and treated as being identical in effect to pragma Atomic.
3970 procedure Process_Compile_Time_Warning_Or_Error
;
3971 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3973 procedure Process_Convention
3974 (C
: out Convention_Id
;
3975 Ent
: out Entity_Id
);
3976 -- Common processing for Convention, Interface, Import and Export.
3977 -- Checks first two arguments of pragma, and sets the appropriate
3978 -- convention value in the specified entity or entities. On return
3979 -- C is the convention, Ent is the referenced entity.
3981 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3982 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3983 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3985 procedure Process_Extended_Import_Export_Object_Pragma
3986 (Arg_Internal
: Node_Id
;
3987 Arg_External
: Node_Id
;
3988 Arg_Size
: Node_Id
);
3989 -- Common processing for the pragmas Import/Export_Object. The three
3990 -- arguments correspond to the three named parameters of the pragmas. An
3991 -- argument is empty if the corresponding parameter is not present in
3994 procedure Process_Extended_Import_Export_Internal_Arg
3995 (Arg_Internal
: Node_Id
:= Empty
);
3996 -- Common processing for all extended Import and Export pragmas. The
3997 -- argument is the pragma parameter for the Internal argument. If
3998 -- Arg_Internal is empty or inappropriate, an error message is posted.
3999 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
4000 -- set to identify the referenced entity.
4002 procedure Process_Extended_Import_Export_Subprogram_Pragma
4003 (Arg_Internal
: Node_Id
;
4004 Arg_External
: Node_Id
;
4005 Arg_Parameter_Types
: Node_Id
;
4006 Arg_Result_Type
: Node_Id
:= Empty
;
4007 Arg_Mechanism
: Node_Id
;
4008 Arg_Result_Mechanism
: Node_Id
:= Empty
);
4009 -- Common processing for all extended Import and Export pragmas applying
4010 -- to subprograms. The caller omits any arguments that do not apply to
4011 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
4012 -- only in the Import_Function and Export_Function cases). The argument
4013 -- names correspond to the allowed pragma association identifiers.
4015 procedure Process_Generic_List
;
4016 -- Common processing for Share_Generic and Inline_Generic
4018 procedure Process_Import_Or_Interface
;
4019 -- Common processing for Import or Interface
4021 procedure Process_Import_Predefined_Type
;
4022 -- Processing for completing a type with pragma Import. This is used
4023 -- to declare types that match predefined C types, especially for cases
4024 -- without corresponding Ada predefined type.
4026 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
4027 -- Inline status of a subprogram, indicated as follows:
4028 -- Suppressed: inlining is suppressed for the subprogram
4029 -- Disabled: no inlining is requested for the subprogram
4030 -- Enabled: inlining is requested/required for the subprogram
4032 procedure Process_Inline
(Status
: Inline_Status
);
4033 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
4034 -- indicates the inline status specified by the pragma.
4036 procedure Process_Interface_Name
4037 (Subprogram_Def
: Entity_Id
;
4041 -- Given the last two arguments of pragma Import, pragma Export, or
4042 -- pragma Interface_Name, performs validity checks and sets the
4043 -- Interface_Name field of the given subprogram entity to the
4044 -- appropriate external or link name, depending on the arguments given.
4045 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
4046 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
4047 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
4048 -- nor Link_Arg is present, the interface name is set to the default
4049 -- from the subprogram name. In addition, the pragma itself is passed
4050 -- to analyze any expressions in the case the pragma came from an aspect
4053 procedure Process_Interrupt_Or_Attach_Handler
;
4054 -- Common processing for Interrupt and Attach_Handler pragmas
4056 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
4057 -- Common processing for Restrictions and Restriction_Warnings pragmas.
4058 -- Warn is True for Restriction_Warnings, or for Restrictions if the
4059 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
4060 -- is not set in the Restrictions case.
4062 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
4063 -- Common processing for Suppress and Unsuppress. The boolean parameter
4064 -- Suppress_Case is True for the Suppress case, and False for the
4067 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
4068 -- Subsidiary to the analysis of pragmas Independent[_Components].
4069 -- Record such a pragma N applied to entity E for future checks.
4071 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
4072 -- This procedure sets the Is_Exported flag for the given entity,
4073 -- checking that the entity was not previously imported. Arg is
4074 -- the argument that specified the entity. A check is also made
4075 -- for exporting inappropriate entities.
4077 procedure Set_Extended_Import_Export_External_Name
4078 (Internal_Ent
: Entity_Id
;
4079 Arg_External
: Node_Id
);
4080 -- Common processing for all extended import export pragmas. The first
4081 -- argument, Internal_Ent, is the internal entity, which has already
4082 -- been checked for validity by the caller. Arg_External is from the
4083 -- Import or Export pragma, and may be null if no External parameter
4084 -- was present. If Arg_External is present and is a non-null string
4085 -- (a null string is treated as the default), then the Interface_Name
4086 -- field of Internal_Ent is set appropriately.
4088 procedure Set_Imported
(E
: Entity_Id
);
4089 -- This procedure sets the Is_Imported flag for the given entity,
4090 -- checking that it is not previously exported or imported.
4092 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4093 -- Mech is a parameter passing mechanism (see Import_Function syntax
4094 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4095 -- has the right form, and if not issues an error message. If the
4096 -- argument has the right form then the Mechanism field of Ent is
4097 -- set appropriately.
4099 procedure Set_Rational_Profile
;
4100 -- Activate the set of configuration pragmas and permissions that make
4101 -- up the Rational profile.
4103 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4104 -- Activate the set of configuration pragmas and restrictions that make
4105 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
4106 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
4107 -- which is used for error messages on any constructs violating the
4110 ----------------------------------
4111 -- Acquire_Warning_Match_String --
4112 ----------------------------------
4114 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4116 String_To_Name_Buffer
4117 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4119 -- Add asterisk at start if not already there
4121 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4122 Name_Buffer
(2 .. Name_Len
+ 1) :=
4123 Name_Buffer
(1 .. Name_Len
);
4124 Name_Buffer
(1) := '*';
4125 Name_Len
:= Name_Len
+ 1;
4128 -- Add asterisk at end if not already there
4130 if Name_Buffer
(Name_Len
) /= '*' then
4131 Name_Len
:= Name_Len
+ 1;
4132 Name_Buffer
(Name_Len
) := '*';
4134 end Acquire_Warning_Match_String
;
4136 ---------------------
4137 -- Ada_2005_Pragma --
4138 ---------------------
4140 procedure Ada_2005_Pragma
is
4142 if Ada_Version
<= Ada_95
then
4143 Check_Restriction
(No_Implementation_Pragmas
, N
);
4145 end Ada_2005_Pragma
;
4147 ---------------------
4148 -- Ada_2012_Pragma --
4149 ---------------------
4151 procedure Ada_2012_Pragma
is
4153 if Ada_Version
<= Ada_2005
then
4154 Check_Restriction
(No_Implementation_Pragmas
, N
);
4156 end Ada_2012_Pragma
;
4158 ----------------------------
4159 -- Analyze_Depends_Global --
4160 ----------------------------
4162 procedure Analyze_Depends_Global
4163 (Spec_Id
: out Entity_Id
;
4164 Subp_Decl
: out Node_Id
;
4165 Legal
: out Boolean)
4168 -- Assume that the pragma is illegal
4175 Check_Arg_Count
(1);
4177 -- Ensure the proper placement of the pragma. Depends/Global must be
4178 -- associated with a subprogram declaration or a body that acts as a
4181 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4185 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4188 -- Generic subprogram
4190 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4193 -- Object declaration of a single concurrent type
4195 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
4196 and then Is_Single_Concurrent_Object
4197 (Unique_Defining_Entity
(Subp_Decl
))
4203 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4206 -- Subprogram body acts as spec
4208 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4209 and then No
(Corresponding_Spec
(Subp_Decl
))
4213 -- Subprogram body stub acts as spec
4215 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4216 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4220 -- Subprogram declaration
4222 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4227 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4235 -- If we get here, then the pragma is legal
4238 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4240 -- When the related context is an entry, the entry must belong to a
4241 -- protected unit (SPARK RM 6.1.4(6)).
4243 if Is_Entry_Declaration
(Spec_Id
)
4244 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4249 -- When the related context is an anonymous object created for a
4250 -- simple concurrent type, the type must be a task
4251 -- (SPARK RM 6.1.4(6)).
4253 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4254 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4260 -- A pragma that applies to a Ghost entity becomes Ghost for the
4261 -- purposes of legality checks and removal of ignored Ghost code.
4263 Mark_Ghost_Pragma
(N
, Spec_Id
);
4264 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4265 end Analyze_Depends_Global
;
4267 ------------------------
4268 -- Analyze_If_Present --
4269 ------------------------
4271 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4275 pragma Assert
(Is_List_Member
(N
));
4277 -- Inspect the declarations or statements following pragma N looking
4278 -- for another pragma whose Id matches the caller's request. If it is
4279 -- available, analyze it.
4282 while Present
(Stmt
) loop
4283 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4284 Analyze_Pragma
(Stmt
);
4287 -- The first source declaration or statement immediately following
4288 -- N ends the region where a pragma may appear.
4290 elsif Comes_From_Source
(Stmt
) then
4296 end Analyze_If_Present
;
4298 --------------------------------
4299 -- Analyze_Pre_Post_Condition --
4300 --------------------------------
4302 procedure Analyze_Pre_Post_Condition
is
4303 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4304 Subp_Decl
: Node_Id
;
4305 Subp_Id
: Entity_Id
;
4307 Duplicates_OK
: Boolean := False;
4308 -- Flag set when a pre/postcondition allows multiple pragmas of the
4311 In_Body_OK
: Boolean := False;
4312 -- Flag set when a pre/postcondition is allowed to appear on a body
4313 -- even though the subprogram may have a spec.
4315 Is_Pre_Post
: Boolean := False;
4316 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4319 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4320 -- Implement rules in AI12-0131: an overriding operation can have
4321 -- a class-wide precondition only if one of its ancestors has an
4322 -- explicit class-wide precondition.
4324 -----------------------------
4325 -- Inherits_Class_Wide_Pre --
4326 -----------------------------
4328 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4329 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4332 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4335 -- Check ancestors on the overriding operation to examine the
4336 -- preconditions that may apply to them.
4338 while Present
(Prev
) loop
4339 Cont
:= Contract
(Prev
);
4340 if Present
(Cont
) then
4341 Prag
:= Pre_Post_Conditions
(Cont
);
4342 while Present
(Prag
) loop
4343 if Class_Present
(Prag
) then
4347 Prag
:= Next_Pragma
(Prag
);
4351 -- For a type derived from a generic formal type, the operation
4352 -- inheriting the condition is a renaming, not an overriding of
4353 -- the operation of the formal. Ditto for an inherited
4354 -- operation which has no explicit contracts.
4356 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4357 or else not Comes_From_Source
(Prev
)
4359 Prev
:= Alias
(Prev
);
4361 Prev
:= Overridden_Operation
(Prev
);
4365 -- If the controlling type of the subprogram has progenitors, an
4366 -- interface operation implemented by the current operation may
4367 -- have a class-wide precondition.
4369 if Has_Interfaces
(Typ
) then
4374 Prim_Elmt
: Elmt_Id
;
4375 Prim_List
: Elist_Id
;
4378 Collect_Interfaces
(Typ
, Ints
);
4379 Elmt
:= First_Elmt
(Ints
);
4381 -- Iterate over the primitive operations of each interface
4383 while Present
(Elmt
) loop
4384 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4385 Prim_Elmt
:= First_Elmt
(Prim_List
);
4386 while Present
(Prim_Elmt
) loop
4387 Prim
:= Node
(Prim_Elmt
);
4388 if Chars
(Prim
) = Chars
(E
)
4389 and then Present
(Contract
(Prim
))
4390 and then Class_Present
4391 (Pre_Post_Conditions
(Contract
(Prim
)))
4396 Next_Elmt
(Prim_Elmt
);
4405 end Inherits_Class_Wide_Pre
;
4407 -- Start of processing for Analyze_Pre_Post_Condition
4410 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4411 -- offer uniformity among the various kinds of pre/postconditions by
4412 -- rewriting the pragma identifier. This allows the retrieval of the
4413 -- original pragma name by routine Original_Aspect_Pragma_Name.
4415 if Comes_From_Source
(N
) then
4416 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4417 Is_Pre_Post
:= True;
4418 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4419 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4421 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4422 Is_Pre_Post
:= True;
4423 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4424 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4428 -- Determine the semantics with respect to duplicates and placement
4429 -- in a body. Pragmas Precondition and Postcondition were introduced
4430 -- before aspects and are not subject to the same aspect-like rules.
4432 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4433 Duplicates_OK
:= True;
4439 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4440 -- argument without an identifier.
4443 Check_Arg_Count
(1);
4444 Check_No_Identifiers
;
4446 -- Pragmas Precondition and Postcondition have complex argument
4450 Check_At_Least_N_Arguments
(1);
4451 Check_At_Most_N_Arguments
(2);
4452 Check_Optional_Identifier
(Arg1
, Name_Check
);
4454 if Present
(Arg2
) then
4455 Check_Optional_Identifier
(Arg2
, Name_Message
);
4456 Preanalyze_Spec_Expression
4457 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4461 -- For a pragma PPC in the extended main source unit, record enabled
4463 -- ??? nothing checks that the pragma is in the main source unit
4465 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4466 Set_SCO_Pragma_Enabled
(Loc
);
4469 -- Ensure the proper placement of the pragma
4472 Find_Related_Declaration_Or_Body
4473 (N
, Do_Checks
=> not Duplicates_OK
);
4475 -- When a pre/postcondition pragma applies to an abstract subprogram,
4476 -- its original form must be an aspect with 'Class.
4478 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4479 if not From_Aspect_Specification
(N
) then
4481 ("pragma % cannot be applied to abstract subprogram");
4483 elsif not Class_Present
(N
) then
4485 ("aspect % requires ''Class for abstract subprogram");
4488 -- Entry declaration
4490 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4493 -- Generic subprogram declaration
4495 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4500 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4501 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4505 -- Subprogram body stub
4507 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4508 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4512 -- Subprogram declaration
4514 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4516 -- AI05-0230: When a pre/postcondition pragma applies to a null
4517 -- procedure, its original form must be an aspect with 'Class.
4519 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4520 and then Null_Present
(Specification
(Subp_Decl
))
4521 and then From_Aspect_Specification
(N
)
4522 and then not Class_Present
(N
)
4524 Error_Pragma
("aspect % requires ''Class for null procedure");
4527 -- Implement the legality checks mandated by AI12-0131:
4528 -- Pre'Class shall not be specified for an overriding primitive
4529 -- subprogram of a tagged type T unless the Pre'Class aspect is
4530 -- specified for the corresponding primitive subprogram of some
4534 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4537 if Class_Present
(N
)
4538 and then Pragma_Name
(N
) = Name_Precondition
4539 and then Present
(Overridden_Operation
(E
))
4540 and then not Inherits_Class_Wide_Pre
(E
)
4543 ("illegal class-wide precondition on overriding operation",
4544 Corresponding_Aspect
(N
));
4548 -- A renaming declaration may inherit a generated pragma, its
4549 -- placement comes from expansion, not from source.
4551 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4552 and then not Comes_From_Source
(N
)
4556 -- Otherwise the placement is illegal
4563 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4565 -- A pragma that applies to a Ghost entity becomes Ghost for the
4566 -- purposes of legality checks and removal of ignored Ghost code.
4568 Mark_Ghost_Pragma
(N
, Subp_Id
);
4570 -- Chain the pragma on the contract for further processing by
4571 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4573 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4575 -- Fully analyze the pragma when it appears inside an entry or
4576 -- subprogram body because it cannot benefit from forward references.
4578 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4580 N_Subprogram_Body_Stub
)
4582 -- The legality checks of pragmas Precondition and Postcondition
4583 -- are affected by the SPARK mode in effect and the volatility of
4584 -- the context. Analyze all pragmas in a specific order.
4586 Analyze_If_Present
(Pragma_SPARK_Mode
);
4587 Analyze_If_Present
(Pragma_Volatile_Function
);
4588 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4590 end Analyze_Pre_Post_Condition
;
4592 -----------------------------------------
4593 -- Analyze_Refined_Depends_Global_Post --
4594 -----------------------------------------
4596 procedure Analyze_Refined_Depends_Global_Post
4597 (Spec_Id
: out Entity_Id
;
4598 Body_Id
: out Entity_Id
;
4599 Legal
: out Boolean)
4601 Body_Decl
: Node_Id
;
4602 Spec_Decl
: Node_Id
;
4605 -- Assume that the pragma is illegal
4612 Check_Arg_Count
(1);
4613 Check_No_Identifiers
;
4615 -- Verify the placement of the pragma and check for duplicates. The
4616 -- pragma must apply to a subprogram body [stub].
4618 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4622 if Nkind
(Body_Decl
) = N_Entry_Body
then
4627 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4630 -- Subprogram body stub
4632 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4637 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4645 Body_Id
:= Defining_Entity
(Body_Decl
);
4646 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4648 -- The pragma must apply to the second declaration of a subprogram.
4649 -- In other words, the body [stub] cannot acts as a spec.
4651 if No
(Spec_Id
) then
4652 Error_Pragma
("pragma % cannot apply to a stand alone body");
4655 -- Catch the case where the subprogram body is a subunit and acts as
4656 -- the third declaration of the subprogram.
4658 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4659 Error_Pragma
("pragma % cannot apply to a subunit");
4663 -- A refined pragma can only apply to the body [stub] of a subprogram
4664 -- declared in the visible part of a package. Retrieve the context of
4665 -- the subprogram declaration.
4667 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4669 -- When dealing with protected entries or protected subprograms, use
4670 -- the enclosing protected type as the proper context.
4672 if Ekind_In
(Spec_Id
, E_Entry
,
4676 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4678 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4681 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4683 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4684 & "subprogram declared in a package specification"));
4688 -- If we get here, then the pragma is legal
4692 -- A pragma that applies to a Ghost entity becomes Ghost for the
4693 -- purposes of legality checks and removal of ignored Ghost code.
4695 Mark_Ghost_Pragma
(N
, Spec_Id
);
4697 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4698 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4700 end Analyze_Refined_Depends_Global_Post
;
4702 ----------------------------------
4703 -- Analyze_Unmodified_Or_Unused --
4704 ----------------------------------
4706 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4711 Ghost_Error_Posted
: Boolean := False;
4712 -- Flag set when an error concerning the illegal mix of Ghost and
4713 -- non-Ghost variables is emitted.
4715 Ghost_Id
: Entity_Id
:= Empty
;
4716 -- The entity of the first Ghost variable encountered while
4717 -- processing the arguments of the pragma.
4721 Check_At_Least_N_Arguments
(1);
4723 -- Loop through arguments
4726 while Present
(Arg
) loop
4727 Check_No_Identifier
(Arg
);
4729 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4730 -- in fact generate reference, so that the entity will have a
4731 -- reference, which will inhibit any warnings about it not
4732 -- being referenced, and also properly show up in the ali file
4733 -- as a reference. But this reference is recorded before the
4734 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4735 -- generated for this reference.
4737 Check_Arg_Is_Local_Name
(Arg
);
4738 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4740 if Is_Entity_Name
(Arg_Expr
) then
4741 Arg_Id
:= Entity
(Arg_Expr
);
4743 -- Skip processing the argument if already flagged
4745 if Is_Assignable
(Arg_Id
)
4746 and then not Has_Pragma_Unmodified
(Arg_Id
)
4747 and then not Has_Pragma_Unused
(Arg_Id
)
4749 Set_Has_Pragma_Unmodified
(Arg_Id
);
4752 Set_Has_Pragma_Unused
(Arg_Id
);
4755 -- A pragma that applies to a Ghost entity becomes Ghost for
4756 -- the purposes of legality checks and removal of ignored
4759 Mark_Ghost_Pragma
(N
, Arg_Id
);
4761 -- Capture the entity of the first Ghost variable being
4762 -- processed for error detection purposes.
4764 if Is_Ghost_Entity
(Arg_Id
) then
4765 if No
(Ghost_Id
) then
4769 -- Otherwise the variable is non-Ghost. It is illegal to mix
4770 -- references to Ghost and non-Ghost entities
4773 elsif Present
(Ghost_Id
)
4774 and then not Ghost_Error_Posted
4776 Ghost_Error_Posted
:= True;
4778 Error_Msg_Name_1
:= Pname
;
4780 ("pragma % cannot mention ghost and non-ghost "
4783 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4784 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4786 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4787 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4790 -- Warn if already flagged as Unused or Unmodified
4792 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4793 if Has_Pragma_Unused
(Arg_Id
) then
4795 ("??pragma Unused already given for &!", Arg_Expr
,
4799 ("??pragma Unmodified already given for &!", Arg_Expr
,
4803 -- Otherwise the pragma referenced an illegal entity
4807 ("pragma% can only be applied to a variable", Arg_Expr
);
4813 end Analyze_Unmodified_Or_Unused
;
4815 -----------------------------------
4816 -- Analyze_Unreference_Or_Unused --
4817 -----------------------------------
4819 procedure Analyze_Unreferenced_Or_Unused
4820 (Is_Unused
: Boolean := False)
4827 Ghost_Error_Posted
: Boolean := False;
4828 -- Flag set when an error concerning the illegal mix of Ghost and
4829 -- non-Ghost names is emitted.
4831 Ghost_Id
: Entity_Id
:= Empty
;
4832 -- The entity of the first Ghost name encountered while processing
4833 -- the arguments of the pragma.
4837 Check_At_Least_N_Arguments
(1);
4839 -- Check case of appearing within context clause
4841 if not Is_Unused
and then Is_In_Context_Clause
then
4843 -- The arguments must all be units mentioned in a with clause in
4844 -- the same context clause. Note that Par.Prag already checked
4845 -- that the arguments are either identifiers or selected
4849 while Present
(Arg
) loop
4850 Citem
:= First
(List_Containing
(N
));
4851 while Citem
/= N
loop
4852 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4854 if Nkind
(Citem
) = N_With_Clause
4855 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4857 Set_Has_Pragma_Unreferenced
4860 (Library_Unit
(Citem
))));
4861 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4870 ("argument of pragma% is not withed unit", Arg
);
4876 -- Case of not in list of context items
4880 while Present
(Arg
) loop
4881 Check_No_Identifier
(Arg
);
4883 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4884 -- in fact generate reference, so that the entity will have a
4885 -- reference, which will inhibit any warnings about it not
4886 -- being referenced, and also properly show up in the ali file
4887 -- as a reference. But this reference is recorded before the
4888 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4889 -- generated for this reference.
4891 Check_Arg_Is_Local_Name
(Arg
);
4892 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4894 if Is_Entity_Name
(Arg_Expr
) then
4895 Arg_Id
:= Entity
(Arg_Expr
);
4897 -- Warn if already flagged as Unused or Unreferenced and
4898 -- skip processing the argument.
4900 if Has_Pragma_Unreferenced
(Arg_Id
) then
4901 if Has_Pragma_Unused
(Arg_Id
) then
4903 ("??pragma Unused already given for &!", Arg_Expr
,
4907 ("??pragma Unreferenced already given for &!",
4911 -- Apply Unreferenced to the entity
4914 -- If the entity is overloaded, the pragma applies to the
4915 -- most recent overloading, as documented. In this case,
4916 -- name resolution does not generate a reference, so it
4917 -- must be done here explicitly.
4919 if Is_Overloaded
(Arg_Expr
) then
4920 Generate_Reference
(Arg_Id
, N
);
4923 Set_Has_Pragma_Unreferenced
(Arg_Id
);
4926 Set_Has_Pragma_Unused
(Arg_Id
);
4929 -- A pragma that applies to a Ghost entity becomes Ghost
4930 -- for the purposes of legality checks and removal of
4931 -- ignored Ghost code.
4933 Mark_Ghost_Pragma
(N
, Arg_Id
);
4935 -- Capture the entity of the first Ghost name being
4936 -- processed for error detection purposes.
4938 if Is_Ghost_Entity
(Arg_Id
) then
4939 if No
(Ghost_Id
) then
4943 -- Otherwise the name is non-Ghost. It is illegal to mix
4944 -- references to Ghost and non-Ghost entities
4947 elsif Present
(Ghost_Id
)
4948 and then not Ghost_Error_Posted
4950 Ghost_Error_Posted
:= True;
4952 Error_Msg_Name_1
:= Pname
;
4954 ("pragma % cannot mention ghost and non-ghost "
4957 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4959 ("\& # declared as ghost", N
, Ghost_Id
);
4961 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4963 ("\& # declared as non-ghost", N
, Arg_Id
);
4971 end Analyze_Unreferenced_Or_Unused
;
4973 --------------------------
4974 -- Check_Ada_83_Warning --
4975 --------------------------
4977 procedure Check_Ada_83_Warning
is
4979 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4980 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4982 end Check_Ada_83_Warning
;
4984 ---------------------
4985 -- Check_Arg_Count --
4986 ---------------------
4988 procedure Check_Arg_Count
(Required
: Nat
) is
4990 if Arg_Count
/= Required
then
4991 Error_Pragma
("wrong number of arguments for pragma%");
4993 end Check_Arg_Count
;
4995 --------------------------------
4996 -- Check_Arg_Is_External_Name --
4997 --------------------------------
4999 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
5000 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5003 if Nkind
(Argx
) = N_Identifier
then
5007 Analyze_And_Resolve
(Argx
, Standard_String
);
5009 if Is_OK_Static_Expression
(Argx
) then
5012 elsif Etype
(Argx
) = Any_Type
then
5015 -- An interesting special case, if we have a string literal and
5016 -- we are in Ada 83 mode, then we allow it even though it will
5017 -- not be flagged as static. This allows expected Ada 83 mode
5018 -- use of external names which are string literals, even though
5019 -- technically these are not static in Ada 83.
5021 elsif Ada_Version
= Ada_83
5022 and then Nkind
(Argx
) = N_String_Literal
5026 -- Here we have a real error (non-static expression)
5029 Error_Msg_Name_1
:= Pname
;
5030 Flag_Non_Static_Expr
5031 (Fix_Error
("argument for pragma% must be a identifier or "
5032 & "static string expression!"), Argx
);
5037 end Check_Arg_Is_External_Name
;
5039 -----------------------------
5040 -- Check_Arg_Is_Identifier --
5041 -----------------------------
5043 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
5044 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5046 if Nkind
(Argx
) /= N_Identifier
then
5047 Error_Pragma_Arg
("argument for pragma% must be identifier", Argx
);
5049 end Check_Arg_Is_Identifier
;
5051 ----------------------------------
5052 -- Check_Arg_Is_Integer_Literal --
5053 ----------------------------------
5055 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
5056 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5058 if Nkind
(Argx
) /= N_Integer_Literal
then
5060 ("argument for pragma% must be integer literal", Argx
);
5062 end Check_Arg_Is_Integer_Literal
;
5064 -------------------------------------------
5065 -- Check_Arg_Is_Library_Level_Local_Name --
5066 -------------------------------------------
5070 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5071 -- | library_unit_NAME
5073 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
5075 Check_Arg_Is_Local_Name
(Arg
);
5077 -- If it came from an aspect, we want to give the error just as if it
5078 -- came from source.
5080 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
5081 and then (Comes_From_Source
(N
)
5082 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
5085 ("argument for pragma% must be library level entity", Arg
);
5087 end Check_Arg_Is_Library_Level_Local_Name
;
5089 -----------------------------
5090 -- Check_Arg_Is_Local_Name --
5091 -----------------------------
5095 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
5096 -- | library_unit_NAME
5098 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
5099 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5102 -- If this pragma came from an aspect specification, we don't want to
5103 -- check for this error, because that would cause spurious errors, in
5104 -- case a type is frozen in a scope more nested than the type. The
5105 -- aspect itself of course can't be anywhere but on the declaration
5108 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5109 if From_Aspect_Specification
(Parent
(Arg
)) then
5113 -- Arg is the Expression of an N_Pragma_Argument_Association
5116 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5123 if Nkind
(Argx
) not in N_Direct_Name
5124 and then (Nkind
(Argx
) /= N_Attribute_Reference
5125 or else Present
(Expressions
(Argx
))
5126 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5127 and then (not Is_Entity_Name
(Argx
)
5128 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5130 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5133 -- No further check required if not an entity name
5135 if not Is_Entity_Name
(Argx
) then
5141 Ent
: constant Entity_Id
:= Entity
(Argx
);
5142 Scop
: constant Entity_Id
:= Scope
(Ent
);
5145 -- Case of a pragma applied to a compilation unit: pragma must
5146 -- occur immediately after the program unit in the compilation.
5148 if Is_Compilation_Unit
(Ent
) then
5150 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5153 -- Case of pragma placed immediately after spec
5155 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5158 -- Case of pragma placed immediately after body
5160 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5161 and then Present
(Corresponding_Body
(Decl
))
5165 (Parent
(Unit_Declaration_Node
5166 (Corresponding_Body
(Decl
))));
5168 -- All other cases are illegal
5175 -- Special restricted placement rule from 10.2.1(11.8/2)
5177 elsif Is_Generic_Formal
(Ent
)
5178 and then Prag_Id
= Pragma_Preelaborable_Initialization
5180 OK
:= List_Containing
(N
) =
5181 Generic_Formal_Declarations
5182 (Unit_Declaration_Node
(Scop
));
5184 -- If this is an aspect applied to a subprogram body, the
5185 -- pragma is inserted in its declarative part.
5187 elsif From_Aspect_Specification
(N
)
5188 and then Ent
= Current_Scope
5190 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5194 -- If the aspect is a predicate (possibly others ???) and the
5195 -- context is a record type, this is a discriminant expression
5196 -- within a type declaration, that freezes the predicated
5199 elsif From_Aspect_Specification
(N
)
5200 and then Prag_Id
= Pragma_Predicate
5201 and then Ekind
(Current_Scope
) = E_Record_Type
5202 and then Scop
= Scope
(Current_Scope
)
5206 -- Default case, just check that the pragma occurs in the scope
5207 -- of the entity denoted by the name.
5210 OK
:= Current_Scope
= Scop
;
5215 ("pragma% argument must be in same declarative part", Arg
);
5219 end Check_Arg_Is_Local_Name
;
5221 ---------------------------------
5222 -- Check_Arg_Is_Locking_Policy --
5223 ---------------------------------
5225 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5226 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5229 Check_Arg_Is_Identifier
(Argx
);
5231 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5232 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5234 end Check_Arg_Is_Locking_Policy
;
5236 -----------------------------------------------
5237 -- Check_Arg_Is_Partition_Elaboration_Policy --
5238 -----------------------------------------------
5240 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5241 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5244 Check_Arg_Is_Identifier
(Argx
);
5246 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5248 ("& is not a valid partition elaboration policy name", Argx
);
5250 end Check_Arg_Is_Partition_Elaboration_Policy
;
5252 -------------------------
5253 -- Check_Arg_Is_One_Of --
5254 -------------------------
5256 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5257 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5260 Check_Arg_Is_Identifier
(Argx
);
5262 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5263 Error_Msg_Name_2
:= N1
;
5264 Error_Msg_Name_3
:= N2
;
5265 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5267 end Check_Arg_Is_One_Of
;
5269 procedure Check_Arg_Is_One_Of
5271 N1
, N2
, N3
: Name_Id
)
5273 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5276 Check_Arg_Is_Identifier
(Argx
);
5278 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5279 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5281 end Check_Arg_Is_One_Of
;
5283 procedure Check_Arg_Is_One_Of
5285 N1
, N2
, N3
, N4
: Name_Id
)
5287 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5290 Check_Arg_Is_Identifier
(Argx
);
5292 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5293 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5295 end Check_Arg_Is_One_Of
;
5297 procedure Check_Arg_Is_One_Of
5299 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5301 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5304 Check_Arg_Is_Identifier
(Argx
);
5306 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5307 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5309 end Check_Arg_Is_One_Of
;
5311 ---------------------------------
5312 -- Check_Arg_Is_Queuing_Policy --
5313 ---------------------------------
5315 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5316 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5319 Check_Arg_Is_Identifier
(Argx
);
5321 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5322 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5324 end Check_Arg_Is_Queuing_Policy
;
5326 ---------------------------------------
5327 -- Check_Arg_Is_OK_Static_Expression --
5328 ---------------------------------------
5330 procedure Check_Arg_Is_OK_Static_Expression
5332 Typ
: Entity_Id
:= Empty
)
5335 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5336 end Check_Arg_Is_OK_Static_Expression
;
5338 ------------------------------------------
5339 -- Check_Arg_Is_Task_Dispatching_Policy --
5340 ------------------------------------------
5342 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5343 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5346 Check_Arg_Is_Identifier
(Argx
);
5348 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5350 ("& is not an allowed task dispatching policy name", Argx
);
5352 end Check_Arg_Is_Task_Dispatching_Policy
;
5354 ---------------------
5355 -- Check_Arg_Order --
5356 ---------------------
5358 procedure Check_Arg_Order
(Names
: Name_List
) is
5361 Highest_So_Far
: Natural := 0;
5362 -- Highest index in Names seen do far
5366 for J
in 1 .. Arg_Count
loop
5367 if Chars
(Arg
) /= No_Name
then
5368 for K
in Names
'Range loop
5369 if Chars
(Arg
) = Names
(K
) then
5370 if K
< Highest_So_Far
then
5371 Error_Msg_Name_1
:= Pname
;
5373 ("parameters out of order for pragma%", Arg
);
5374 Error_Msg_Name_1
:= Names
(K
);
5375 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5376 Error_Msg_N
("\% must appear before %", Arg
);
5380 Highest_So_Far
:= K
;
5388 end Check_Arg_Order
;
5390 --------------------------------
5391 -- Check_At_Least_N_Arguments --
5392 --------------------------------
5394 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5396 if Arg_Count
< N
then
5397 Error_Pragma
("too few arguments for pragma%");
5399 end Check_At_Least_N_Arguments
;
5401 -------------------------------
5402 -- Check_At_Most_N_Arguments --
5403 -------------------------------
5405 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5408 if Arg_Count
> N
then
5410 for J
in 1 .. N
loop
5412 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5415 end Check_At_Most_N_Arguments
;
5417 ---------------------
5418 -- Check_Component --
5419 ---------------------
5421 procedure Check_Component
5424 In_Variant_Part
: Boolean := False)
5426 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5427 Sindic
: constant Node_Id
:=
5428 Subtype_Indication
(Component_Definition
(Comp
));
5429 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5432 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5433 -- object constraint, then the component type shall be an Unchecked_
5436 if Nkind
(Sindic
) = N_Subtype_Indication
5437 and then Has_Per_Object_Constraint
(Comp_Id
)
5438 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5441 ("component subtype subject to per-object constraint "
5442 & "must be an Unchecked_Union", Comp
);
5444 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5445 -- the body of a generic unit, or within the body of any of its
5446 -- descendant library units, no part of the type of a component
5447 -- declared in a variant_part of the unchecked union type shall be of
5448 -- a formal private type or formal private extension declared within
5449 -- the formal part of the generic unit.
5451 elsif Ada_Version
>= Ada_2012
5452 and then In_Generic_Body
(UU_Typ
)
5453 and then In_Variant_Part
5454 and then Is_Private_Type
(Typ
)
5455 and then Is_Generic_Type
(Typ
)
5458 ("component of unchecked union cannot be of generic type", Comp
);
5460 elsif Needs_Finalization
(Typ
) then
5462 ("component of unchecked union cannot be controlled", Comp
);
5464 elsif Has_Task
(Typ
) then
5466 ("component of unchecked union cannot have tasks", Comp
);
5468 end Check_Component
;
5470 ----------------------------
5471 -- Check_Duplicate_Pragma --
5472 ----------------------------
5474 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5475 Id
: Entity_Id
:= E
;
5479 -- Nothing to do if this pragma comes from an aspect specification,
5480 -- since we could not be duplicating a pragma, and we dealt with the
5481 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5483 if From_Aspect_Specification
(N
) then
5487 -- Otherwise current pragma may duplicate previous pragma or a
5488 -- previously given aspect specification or attribute definition
5489 -- clause for the same pragma.
5491 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5495 -- If the entity is a type, then we have to make sure that the
5496 -- ostensible duplicate is not for a parent type from which this
5500 if Nkind
(P
) = N_Pragma
then
5502 Args
: constant List_Id
:=
5503 Pragma_Argument_Associations
(P
);
5506 and then Is_Entity_Name
(Expression
(First
(Args
)))
5507 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5508 and then Entity
(Expression
(First
(Args
))) /= E
5514 elsif Nkind
(P
) = N_Aspect_Specification
5515 and then Is_Type
(Entity
(P
))
5516 and then Entity
(P
) /= E
5522 -- Here we have a definite duplicate
5524 Error_Msg_Name_1
:= Pragma_Name
(N
);
5525 Error_Msg_Sloc
:= Sloc
(P
);
5527 -- For a single protected or a single task object, the error is
5528 -- issued on the original entity.
5530 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5531 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5534 if Nkind
(P
) = N_Aspect_Specification
5535 or else From_Aspect_Specification
(P
)
5537 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5539 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5544 end Check_Duplicate_Pragma
;
5546 ----------------------------------
5547 -- Check_Duplicated_Export_Name --
5548 ----------------------------------
5550 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5551 String_Val
: constant String_Id
:= Strval
(Nam
);
5554 -- We are only interested in the export case, and in the case of
5555 -- generics, it is the instance, not the template, that is the
5556 -- problem (the template will generate a warning in any case).
5558 if not Inside_A_Generic
5559 and then (Prag_Id
= Pragma_Export
5561 Prag_Id
= Pragma_Export_Procedure
5563 Prag_Id
= Pragma_Export_Valued_Procedure
5565 Prag_Id
= Pragma_Export_Function
)
5567 for J
in Externals
.First
.. Externals
.Last
loop
5568 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5569 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5570 Error_Msg_N
("external name duplicates name given#", Nam
);
5575 Externals
.Append
(Nam
);
5577 end Check_Duplicated_Export_Name
;
5579 ----------------------------------------
5580 -- Check_Expr_Is_OK_Static_Expression --
5581 ----------------------------------------
5583 procedure Check_Expr_Is_OK_Static_Expression
5585 Typ
: Entity_Id
:= Empty
)
5588 if Present
(Typ
) then
5589 Analyze_And_Resolve
(Expr
, Typ
);
5591 Analyze_And_Resolve
(Expr
);
5594 -- An expression cannot be considered static if its resolution failed
5595 -- or if it's erroneous. Stop the analysis of the related pragma.
5597 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5600 elsif Is_OK_Static_Expression
(Expr
) then
5603 -- An interesting special case, if we have a string literal and we
5604 -- are in Ada 83 mode, then we allow it even though it will not be
5605 -- flagged as static. This allows the use of Ada 95 pragmas like
5606 -- Import in Ada 83 mode. They will of course be flagged with
5607 -- warnings as usual, but will not cause errors.
5609 elsif Ada_Version
= Ada_83
5610 and then Nkind
(Expr
) = N_String_Literal
5614 -- Finally, we have a real error
5617 Error_Msg_Name_1
:= Pname
;
5618 Flag_Non_Static_Expr
5619 (Fix_Error
("argument for pragma% must be a static expression!"),
5623 end Check_Expr_Is_OK_Static_Expression
;
5625 -------------------------
5626 -- Check_First_Subtype --
5627 -------------------------
5629 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5630 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5631 Ent
: constant Entity_Id
:= Entity
(Argx
);
5634 if Is_First_Subtype
(Ent
) then
5637 elsif Is_Type
(Ent
) then
5639 ("pragma% cannot apply to subtype", Argx
);
5641 elsif Is_Object
(Ent
) then
5643 ("pragma% cannot apply to object, requires a type", Argx
);
5647 ("pragma% cannot apply to&, requires a type", Argx
);
5649 end Check_First_Subtype
;
5651 ----------------------
5652 -- Check_Identifier --
5653 ----------------------
5655 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5658 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5660 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5661 Error_Msg_Name_1
:= Pname
;
5662 Error_Msg_Name_2
:= Id
;
5663 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5667 end Check_Identifier
;
5669 --------------------------------
5670 -- Check_Identifier_Is_One_Of --
5671 --------------------------------
5673 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5676 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5678 if Chars
(Arg
) = No_Name
then
5679 Error_Msg_Name_1
:= Pname
;
5680 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5683 elsif Chars
(Arg
) /= N1
5684 and then Chars
(Arg
) /= N2
5686 Error_Msg_Name_1
:= Pname
;
5687 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5691 end Check_Identifier_Is_One_Of
;
5693 ---------------------------
5694 -- Check_In_Main_Program --
5695 ---------------------------
5697 procedure Check_In_Main_Program
is
5698 P
: constant Node_Id
:= Parent
(N
);
5701 -- Must be in subprogram body
5703 if Nkind
(P
) /= N_Subprogram_Body
then
5704 Error_Pragma
("% pragma allowed only in subprogram");
5706 -- Otherwise warn if obviously not main program
5708 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5709 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5711 Error_Msg_Name_1
:= Pname
;
5713 ("??pragma% is only effective in main program", N
);
5715 end Check_In_Main_Program
;
5717 ---------------------------------------
5718 -- Check_Interrupt_Or_Attach_Handler --
5719 ---------------------------------------
5721 procedure Check_Interrupt_Or_Attach_Handler
is
5722 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5723 Handler_Proc
, Proc_Scope
: Entity_Id
;
5728 if Prag_Id
= Pragma_Interrupt_Handler
then
5729 Check_Restriction
(No_Dynamic_Attachment
, N
);
5732 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5733 Proc_Scope
:= Scope
(Handler_Proc
);
5735 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5737 ("argument of pragma% must be protected procedure", Arg1
);
5740 -- For pragma case (as opposed to access case), check placement.
5741 -- We don't need to do that for aspects, because we have the
5742 -- check that they aspect applies an appropriate procedure.
5744 if not From_Aspect_Specification
(N
)
5745 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5747 Error_Pragma
("pragma% must be in protected definition");
5750 if not Is_Library_Level_Entity
(Proc_Scope
) then
5752 ("argument for pragma% must be library level entity", Arg1
);
5755 -- AI05-0033: A pragma cannot appear within a generic body, because
5756 -- instance can be in a nested scope. The check that protected type
5757 -- is itself a library-level declaration is done elsewhere.
5759 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5760 -- handle code prior to AI-0033. Analysis tools typically are not
5761 -- interested in this pragma in any case, so no need to worry too
5762 -- much about its placement.
5764 if Inside_A_Generic
then
5765 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5766 and then In_Package_Body
(Scope
(Current_Scope
))
5767 and then not Relaxed_RM_Semantics
5769 Error_Pragma
("pragma% cannot be used inside a generic");
5772 end Check_Interrupt_Or_Attach_Handler
;
5774 ---------------------------------
5775 -- Check_Loop_Pragma_Placement --
5776 ---------------------------------
5778 procedure Check_Loop_Pragma_Placement
is
5779 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5780 -- Verify whether the current pragma is properly grouped with other
5781 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5782 -- related loop where the pragma appears.
5784 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5785 -- Determine whether an arbitrary statement Stmt denotes pragma
5786 -- Loop_Invariant or Loop_Variant.
5788 procedure Placement_Error
(Constr
: Node_Id
);
5789 pragma No_Return
(Placement_Error
);
5790 -- Node Constr denotes the last loop restricted construct before we
5791 -- encountered an illegal relation between enclosing constructs. Emit
5792 -- an error depending on what Constr was.
5794 --------------------------------
5795 -- Check_Loop_Pragma_Grouping --
5796 --------------------------------
5798 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5799 Stop_Search
: exception;
5800 -- This exception is used to terminate the recursive descent of
5801 -- routine Check_Grouping.
5803 procedure Check_Grouping
(L
: List_Id
);
5804 -- Find the first group of pragmas in list L and if successful,
5805 -- ensure that the current pragma is part of that group. The
5806 -- routine raises Stop_Search once such a check is performed to
5807 -- halt the recursive descent.
5809 procedure Grouping_Error
(Prag
: Node_Id
);
5810 pragma No_Return
(Grouping_Error
);
5811 -- Emit an error concerning the current pragma indicating that it
5812 -- should be placed after pragma Prag.
5814 --------------------
5815 -- Check_Grouping --
5816 --------------------
5818 procedure Check_Grouping
(L
: List_Id
) is
5821 Prag
: Node_Id
:= Empty
; -- init to avoid warning
5824 -- Inspect the list of declarations or statements looking for
5825 -- the first grouping of pragmas:
5828 -- pragma Loop_Invariant ...;
5829 -- pragma Loop_Variant ...;
5831 -- pragma Loop_Variant ...; -- current pragma
5833 -- If the current pragma is not in the grouping, then it must
5834 -- either appear in a different declarative or statement list
5835 -- or the construct at (1) is separating the pragma from the
5839 while Present
(Stmt
) loop
5841 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5842 -- inside a loop or a block housed inside a loop. Inspect
5843 -- the declarations and statements of the block as they may
5844 -- contain the first grouping.
5846 if Nkind
(Stmt
) = N_Block_Statement
then
5847 HSS
:= Handled_Statement_Sequence
(Stmt
);
5849 Check_Grouping
(Declarations
(Stmt
));
5851 if Present
(HSS
) then
5852 Check_Grouping
(Statements
(HSS
));
5855 -- First pragma of the first topmost grouping has been found
5857 elsif Is_Loop_Pragma
(Stmt
) then
5859 -- The group and the current pragma are not in the same
5860 -- declarative or statement list.
5862 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5863 Grouping_Error
(Stmt
);
5865 -- Try to reach the current pragma from the first pragma
5866 -- of the grouping while skipping other members:
5868 -- pragma Loop_Invariant ...; -- first pragma
5869 -- pragma Loop_Variant ...; -- member
5871 -- pragma Loop_Variant ...; -- current pragma
5874 while Present
(Stmt
) loop
5875 -- The current pragma is either the first pragma
5876 -- of the group or is a member of the group.
5877 -- Stop the search as the placement is legal.
5882 -- Skip group members, but keep track of the
5883 -- last pragma in the group.
5885 elsif Is_Loop_Pragma
(Stmt
) then
5888 -- Skip declarations and statements generated by
5889 -- the compiler during expansion.
5891 elsif not Comes_From_Source
(Stmt
) then
5894 -- A non-pragma is separating the group from the
5895 -- current pragma, the placement is illegal.
5898 Grouping_Error
(Prag
);
5904 -- If the traversal did not reach the current pragma,
5905 -- then the list must be malformed.
5907 raise Program_Error
;
5915 --------------------
5916 -- Grouping_Error --
5917 --------------------
5919 procedure Grouping_Error
(Prag
: Node_Id
) is
5921 Error_Msg_Sloc
:= Sloc
(Prag
);
5922 Error_Pragma
("pragma% must appear next to pragma#");
5925 -- Start of processing for Check_Loop_Pragma_Grouping
5928 -- Inspect the statements of the loop or nested blocks housed
5929 -- within to determine whether the current pragma is part of the
5930 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5932 Check_Grouping
(Statements
(Loop_Stmt
));
5935 when Stop_Search
=> null;
5936 end Check_Loop_Pragma_Grouping
;
5938 --------------------
5939 -- Is_Loop_Pragma --
5940 --------------------
5942 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5944 -- Inspect the original node as Loop_Invariant and Loop_Variant
5945 -- pragmas are rewritten to null when assertions are disabled.
5947 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5949 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
5950 Name_Loop_Invariant
,
5957 ---------------------
5958 -- Placement_Error --
5959 ---------------------
5961 procedure Placement_Error
(Constr
: Node_Id
) is
5962 LA
: constant String := " with Loop_Entry";
5965 if Prag_Id
= Pragma_Assert
then
5966 Error_Msg_String
(1 .. LA
'Length) := LA
;
5967 Error_Msg_Strlen
:= LA
'Length;
5969 Error_Msg_Strlen
:= 0;
5972 if Nkind
(Constr
) = N_Pragma
then
5974 ("pragma %~ must appear immediately within the statements "
5978 ("block containing pragma %~ must appear immediately within "
5979 & "the statements of a loop", Constr
);
5981 end Placement_Error
;
5983 -- Local declarations
5988 -- Start of processing for Check_Loop_Pragma_Placement
5991 -- Check that pragma appears immediately within a loop statement,
5992 -- ignoring intervening block statements.
5996 while Present
(Stmt
) loop
5998 -- The pragma or previous block must appear immediately within the
5999 -- current block's declarative or statement part.
6001 if Nkind
(Stmt
) = N_Block_Statement
then
6002 if (No
(Declarations
(Stmt
))
6003 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
6005 List_Containing
(Prev
) /=
6006 Statements
(Handled_Statement_Sequence
(Stmt
))
6008 Placement_Error
(Prev
);
6011 -- Keep inspecting the parents because we are now within a
6012 -- chain of nested blocks.
6016 Stmt
:= Parent
(Stmt
);
6019 -- The pragma or previous block must appear immediately within the
6020 -- statements of the loop.
6022 elsif Nkind
(Stmt
) = N_Loop_Statement
then
6023 if List_Containing
(Prev
) /= Statements
(Stmt
) then
6024 Placement_Error
(Prev
);
6027 -- Stop the traversal because we reached the innermost loop
6028 -- regardless of whether we encountered an error or not.
6032 -- Ignore a handled statement sequence. Note that this node may
6033 -- be related to a subprogram body in which case we will emit an
6034 -- error on the next iteration of the search.
6036 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
6037 Stmt
:= Parent
(Stmt
);
6039 -- Any other statement breaks the chain from the pragma to the
6043 Placement_Error
(Prev
);
6048 -- Check that the current pragma Loop_Invariant or Loop_Variant is
6049 -- grouped together with other such pragmas.
6051 if Is_Loop_Pragma
(N
) then
6053 -- The previous check should have located the related loop
6055 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
6056 Check_Loop_Pragma_Grouping
(Stmt
);
6058 end Check_Loop_Pragma_Placement
;
6060 -------------------------------------------
6061 -- Check_Is_In_Decl_Part_Or_Package_Spec --
6062 -------------------------------------------
6064 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
6073 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
6076 elsif Nkind_In
(P
, N_Package_Specification
,
6081 -- Note: the following tests seem a little peculiar, because
6082 -- they test for bodies, but if we were in the statement part
6083 -- of the body, we would already have hit the handled statement
6084 -- sequence, so the only way we get here is by being in the
6085 -- declarative part of the body.
6087 elsif Nkind_In
(P
, N_Subprogram_Body
,
6098 Error_Pragma
("pragma% is not in declarative part or package spec");
6099 end Check_Is_In_Decl_Part_Or_Package_Spec
;
6101 -------------------------
6102 -- Check_No_Identifier --
6103 -------------------------
6105 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6107 if Nkind
(Arg
) = N_Pragma_Argument_Association
6108 and then Chars
(Arg
) /= No_Name
6110 Error_Pragma_Arg_Ident
6111 ("pragma% does not permit identifier& here", Arg
);
6113 end Check_No_Identifier
;
6115 --------------------------
6116 -- Check_No_Identifiers --
6117 --------------------------
6119 procedure Check_No_Identifiers
is
6123 for J
in 1 .. Arg_Count
loop
6124 Check_No_Identifier
(Arg_Node
);
6127 end Check_No_Identifiers
;
6129 ------------------------
6130 -- Check_No_Link_Name --
6131 ------------------------
6133 procedure Check_No_Link_Name
is
6135 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6139 if Present
(Arg4
) then
6141 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6143 end Check_No_Link_Name
;
6145 -------------------------------
6146 -- Check_Optional_Identifier --
6147 -------------------------------
6149 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6152 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6153 and then Chars
(Arg
) /= No_Name
6155 if Chars
(Arg
) /= Id
then
6156 Error_Msg_Name_1
:= Pname
;
6157 Error_Msg_Name_2
:= Id
;
6158 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6162 end Check_Optional_Identifier
;
6164 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6166 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6167 end Check_Optional_Identifier
;
6169 -------------------------------------
6170 -- Check_Static_Boolean_Expression --
6171 -------------------------------------
6173 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6175 if Present
(Expr
) then
6176 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6178 if not Is_OK_Static_Expression
(Expr
) then
6180 ("expression of pragma % must be static", Expr
);
6183 end Check_Static_Boolean_Expression
;
6185 -----------------------------
6186 -- Check_Static_Constraint --
6187 -----------------------------
6189 -- Note: for convenience in writing this procedure, in addition to
6190 -- the officially (i.e. by spec) allowed argument which is always a
6191 -- constraint, it also allows ranges and discriminant associations.
6192 -- Above is not clear ???
6194 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6196 procedure Require_Static
(E
: Node_Id
);
6197 -- Require given expression to be static expression
6199 --------------------
6200 -- Require_Static --
6201 --------------------
6203 procedure Require_Static
(E
: Node_Id
) is
6205 if not Is_OK_Static_Expression
(E
) then
6206 Flag_Non_Static_Expr
6207 ("non-static constraint not allowed in Unchecked_Union!", E
);
6212 -- Start of processing for Check_Static_Constraint
6215 case Nkind
(Constr
) is
6216 when N_Discriminant_Association
=>
6217 Require_Static
(Expression
(Constr
));
6220 Require_Static
(Low_Bound
(Constr
));
6221 Require_Static
(High_Bound
(Constr
));
6223 when N_Attribute_Reference
=>
6224 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6225 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6227 when N_Range_Constraint
=>
6228 Check_Static_Constraint
(Range_Expression
(Constr
));
6230 when N_Index_Or_Discriminant_Constraint
=>
6234 IDC
:= First
(Constraints
(Constr
));
6235 while Present
(IDC
) loop
6236 Check_Static_Constraint
(IDC
);
6244 end Check_Static_Constraint
;
6246 --------------------------------------
6247 -- Check_Valid_Configuration_Pragma --
6248 --------------------------------------
6250 -- A configuration pragma must appear in the context clause of a
6251 -- compilation unit, and only other pragmas may precede it. Note that
6252 -- the test also allows use in a configuration pragma file.
6254 procedure Check_Valid_Configuration_Pragma
is
6256 if not Is_Configuration_Pragma
then
6257 Error_Pragma
("incorrect placement for configuration pragma%");
6259 end Check_Valid_Configuration_Pragma
;
6261 -------------------------------------
6262 -- Check_Valid_Library_Unit_Pragma --
6263 -------------------------------------
6265 procedure Check_Valid_Library_Unit_Pragma
is
6267 Parent_Node
: Node_Id
;
6268 Unit_Name
: Entity_Id
;
6269 Unit_Kind
: Node_Kind
;
6270 Unit_Node
: Node_Id
;
6271 Sindex
: Source_File_Index
;
6274 if not Is_List_Member
(N
) then
6278 Plist
:= List_Containing
(N
);
6279 Parent_Node
:= Parent
(Plist
);
6281 if Parent_Node
= Empty
then
6284 -- Case of pragma appearing after a compilation unit. In this case
6285 -- it must have an argument with the corresponding name and must
6286 -- be part of the following pragmas of its parent.
6288 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6289 if Plist
/= Pragmas_After
(Parent_Node
) then
6292 elsif Arg_Count
= 0 then
6294 ("argument required if outside compilation unit");
6297 Check_No_Identifiers
;
6298 Check_Arg_Count
(1);
6299 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6300 Unit_Kind
:= Nkind
(Unit_Node
);
6302 Analyze
(Get_Pragma_Arg
(Arg1
));
6304 if Unit_Kind
= N_Generic_Subprogram_Declaration
6305 or else Unit_Kind
= N_Subprogram_Declaration
6307 Unit_Name
:= Defining_Entity
(Unit_Node
);
6309 elsif Unit_Kind
in N_Generic_Instantiation
then
6310 Unit_Name
:= Defining_Entity
(Unit_Node
);
6313 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6316 if Chars
(Unit_Name
) /=
6317 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6320 ("pragma% argument is not current unit name", Arg1
);
6323 if Ekind
(Unit_Name
) = E_Package
6324 and then Present
(Renamed_Entity
(Unit_Name
))
6326 Error_Pragma
("pragma% not allowed for renamed package");
6330 -- Pragma appears other than after a compilation unit
6333 -- Here we check for the generic instantiation case and also
6334 -- for the case of processing a generic formal package. We
6335 -- detect these cases by noting that the Sloc on the node
6336 -- does not belong to the current compilation unit.
6338 Sindex
:= Source_Index
(Current_Sem_Unit
);
6340 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6341 Rewrite
(N
, Make_Null_Statement
(Loc
));
6344 -- If before first declaration, the pragma applies to the
6345 -- enclosing unit, and the name if present must be this name.
6347 elsif Is_Before_First_Decl
(N
, Plist
) then
6348 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6349 Unit_Kind
:= Nkind
(Unit_Node
);
6351 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6354 elsif Unit_Kind
= N_Subprogram_Body
6355 and then not Acts_As_Spec
(Unit_Node
)
6359 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6362 elsif Nkind
(Parent_Node
) = N_Package_Specification
6363 and then Plist
= Private_Declarations
(Parent_Node
)
6367 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6368 or else Nkind
(Parent_Node
) =
6369 N_Generic_Subprogram_Declaration
)
6370 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6374 elsif Arg_Count
> 0 then
6375 Analyze
(Get_Pragma_Arg
(Arg1
));
6377 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6379 ("name in pragma% must be enclosing unit", Arg1
);
6382 -- It is legal to have no argument in this context
6388 -- Error if not before first declaration. This is because a
6389 -- library unit pragma argument must be the name of a library
6390 -- unit (RM 10.1.5(7)), but the only names permitted in this
6391 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6392 -- generic subprogram declarations or generic instantiations.
6396 ("pragma% misplaced, must be before first declaration");
6400 end Check_Valid_Library_Unit_Pragma
;
6406 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6407 Clist
: constant Node_Id
:= Component_List
(Variant
);
6411 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
6412 while Present
(Comp
) loop
6413 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6414 Next_Non_Pragma
(Comp
);
6418 ---------------------------
6419 -- Ensure_Aggregate_Form --
6420 ---------------------------
6422 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6423 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6424 Expr
: constant Node_Id
:= Expression
(Arg
);
6425 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6426 Comps
: List_Id
:= No_List
;
6427 Exprs
: List_Id
:= No_List
;
6428 Nam
: Name_Id
:= No_Name
;
6429 Nam_Loc
: Source_Ptr
;
6432 -- The pragma argument is in positional form:
6434 -- pragma Depends (Nam => ...)
6438 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6439 -- argument association.
6441 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6443 Nam_Loc
:= Sloc
(Arg
);
6445 -- Remove the pragma argument name as this will be captured in the
6448 Set_Chars
(Arg
, No_Name
);
6451 -- The argument is already in aggregate form, but the presence of a
6452 -- name causes this to be interpreted as named association which in
6453 -- turn must be converted into an aggregate.
6455 -- pragma Global (In_Out => (A, B, C))
6459 -- pragma Global ((In_Out => (A, B, C)))
6461 -- aggregate aggregate
6463 if Nkind
(Expr
) = N_Aggregate
then
6464 if Nam
= No_Name
then
6468 -- Do not transform a null argument into an aggregate as N_Null has
6469 -- special meaning in formal verification pragmas.
6471 elsif Nkind
(Expr
) = N_Null
then
6475 -- Everything comes from source if the original comes from source
6477 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6479 -- Positional argument is transformed into an aggregate with an
6480 -- Expressions list.
6482 if Nam
= No_Name
then
6483 Exprs
:= New_List
(Relocate_Node
(Expr
));
6485 -- An associative argument is transformed into an aggregate with
6486 -- Component_Associations.
6490 Make_Component_Association
(Loc
,
6491 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6492 Expression
=> Relocate_Node
(Expr
)));
6495 Set_Expression
(Arg
,
6496 Make_Aggregate
(Loc
,
6497 Component_Associations
=> Comps
,
6498 Expressions
=> Exprs
));
6500 -- Restore Comes_From_Source default
6502 Set_Comes_From_Source_Default
(CFSD
);
6503 end Ensure_Aggregate_Form
;
6509 procedure Error_Pragma
(Msg
: String) is
6511 Error_Msg_Name_1
:= Pname
;
6512 Error_Msg_N
(Fix_Error
(Msg
), N
);
6516 ----------------------
6517 -- Error_Pragma_Arg --
6518 ----------------------
6520 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6522 Error_Msg_Name_1
:= Pname
;
6523 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6525 end Error_Pragma_Arg
;
6527 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6529 Error_Msg_Name_1
:= Pname
;
6530 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6531 Error_Pragma_Arg
(Msg2
, Arg
);
6532 end Error_Pragma_Arg
;
6534 ----------------------------
6535 -- Error_Pragma_Arg_Ident --
6536 ----------------------------
6538 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6540 Error_Msg_Name_1
:= Pname
;
6541 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6543 end Error_Pragma_Arg_Ident
;
6545 ----------------------
6546 -- Error_Pragma_Ref --
6547 ----------------------
6549 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6551 Error_Msg_Name_1
:= Pname
;
6552 Error_Msg_Sloc
:= Sloc
(Ref
);
6553 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6555 end Error_Pragma_Ref
;
6557 ------------------------
6558 -- Find_Lib_Unit_Name --
6559 ------------------------
6561 function Find_Lib_Unit_Name
return Entity_Id
is
6563 -- Return inner compilation unit entity, for case of nested
6564 -- categorization pragmas. This happens in generic unit.
6566 if Nkind
(Parent
(N
)) = N_Package_Specification
6567 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6569 return Defining_Entity
(Parent
(N
));
6571 return Current_Scope
;
6573 end Find_Lib_Unit_Name
;
6575 ----------------------------
6576 -- Find_Program_Unit_Name --
6577 ----------------------------
6579 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6580 Unit_Name
: Entity_Id
;
6581 Unit_Kind
: Node_Kind
;
6582 P
: constant Node_Id
:= Parent
(N
);
6585 if Nkind
(P
) = N_Compilation_Unit
then
6586 Unit_Kind
:= Nkind
(Unit
(P
));
6588 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6589 N_Package_Declaration
)
6590 or else Unit_Kind
in N_Generic_Declaration
6592 Unit_Name
:= Defining_Entity
(Unit
(P
));
6594 if Chars
(Id
) = Chars
(Unit_Name
) then
6595 Set_Entity
(Id
, Unit_Name
);
6596 Set_Etype
(Id
, Etype
(Unit_Name
));
6598 Set_Etype
(Id
, Any_Type
);
6600 ("cannot find program unit referenced by pragma%");
6604 Set_Etype
(Id
, Any_Type
);
6605 Error_Pragma
("pragma% inapplicable to this unit");
6611 end Find_Program_Unit_Name
;
6613 -----------------------------------------
6614 -- Find_Unique_Parameterless_Procedure --
6615 -----------------------------------------
6617 function Find_Unique_Parameterless_Procedure
6619 Arg
: Node_Id
) return Entity_Id
6621 Proc
: Entity_Id
:= Empty
;
6624 -- The body of this procedure needs some comments ???
6626 if not Is_Entity_Name
(Name
) then
6628 ("argument of pragma% must be entity name", Arg
);
6630 elsif not Is_Overloaded
(Name
) then
6631 Proc
:= Entity
(Name
);
6633 if Ekind
(Proc
) /= E_Procedure
6634 or else Present
(First_Formal
(Proc
))
6637 ("argument of pragma% must be parameterless procedure", Arg
);
6642 Found
: Boolean := False;
6644 Index
: Interp_Index
;
6647 Get_First_Interp
(Name
, Index
, It
);
6648 while Present
(It
.Nam
) loop
6651 if Ekind
(Proc
) = E_Procedure
6652 and then No
(First_Formal
(Proc
))
6656 Set_Entity
(Name
, Proc
);
6657 Set_Is_Overloaded
(Name
, False);
6660 ("ambiguous handler name for pragma% ", Arg
);
6664 Get_Next_Interp
(Index
, It
);
6669 ("argument of pragma% must be parameterless procedure",
6672 Proc
:= Entity
(Name
);
6678 end Find_Unique_Parameterless_Procedure
;
6684 function Fix_Error
(Msg
: String) return String is
6685 Res
: String (Msg
'Range) := Msg
;
6686 Res_Last
: Natural := Msg
'Last;
6690 -- If we have a rewriting of another pragma, go to that pragma
6692 if Is_Rewrite_Substitution
(N
)
6693 and then Nkind
(Original_Node
(N
)) = N_Pragma
6695 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6698 -- Case where pragma comes from an aspect specification
6700 if From_Aspect_Specification
(N
) then
6702 -- Change appearence of "pragma" in message to "aspect"
6705 while J
<= Res_Last
- 5 loop
6706 if Res
(J
.. J
+ 5) = "pragma" then
6707 Res
(J
.. J
+ 5) := "aspect";
6715 -- Change "argument of" at start of message to "entity for"
6718 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6720 Res
(Res
'First .. Res
'First + 9) := "entity for";
6721 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6722 Res
(Res
'First + 11 .. Res_Last
);
6723 Res_Last
:= Res_Last
- 1;
6726 -- Change "argument" at start of message to "entity"
6729 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6731 Res
(Res
'First .. Res
'First + 5) := "entity";
6732 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6733 Res
(Res
'First + 8 .. Res_Last
);
6734 Res_Last
:= Res_Last
- 2;
6737 -- Get name from corresponding aspect
6739 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6742 -- Return possibly modified message
6744 return Res
(Res
'First .. Res_Last
);
6747 -------------------------
6748 -- Gather_Associations --
6749 -------------------------
6751 procedure Gather_Associations
6753 Args
: out Args_List
)
6758 -- Initialize all parameters to Empty
6760 for J
in Args
'Range loop
6764 -- That's all we have to do if there are no argument associations
6766 if No
(Pragma_Argument_Associations
(N
)) then
6770 -- Otherwise first deal with any positional parameters present
6772 Arg
:= First
(Pragma_Argument_Associations
(N
));
6773 for Index
in Args
'Range loop
6774 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6775 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6779 -- Positional parameters all processed, if any left, then we
6780 -- have too many positional parameters.
6782 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6784 ("too many positional associations for pragma%", Arg
);
6787 -- Process named parameters if any are present
6789 while Present
(Arg
) loop
6790 if Chars
(Arg
) = No_Name
then
6792 ("positional association cannot follow named association",
6796 for Index
in Names
'Range loop
6797 if Names
(Index
) = Chars
(Arg
) then
6798 if Present
(Args
(Index
)) then
6800 ("duplicate argument association for pragma%", Arg
);
6802 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6807 if Index
= Names
'Last then
6808 Error_Msg_Name_1
:= Pname
;
6809 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6811 -- Check for possible misspelling
6813 for Index1
in Names
'Range loop
6814 if Is_Bad_Spelling_Of
6815 (Chars
(Arg
), Names
(Index1
))
6817 Error_Msg_Name_1
:= Names
(Index1
);
6818 Error_Msg_N
-- CODEFIX
6819 ("\possible misspelling of%", Arg
);
6831 end Gather_Associations
;
6837 procedure GNAT_Pragma
is
6839 -- We need to check the No_Implementation_Pragmas restriction for
6840 -- the case of a pragma from source. Note that the case of aspects
6841 -- generating corresponding pragmas marks these pragmas as not being
6842 -- from source, so this test also catches that case.
6844 if Comes_From_Source
(N
) then
6845 Check_Restriction
(No_Implementation_Pragmas
, N
);
6849 --------------------------
6850 -- Is_Before_First_Decl --
6851 --------------------------
6853 function Is_Before_First_Decl
6854 (Pragma_Node
: Node_Id
;
6855 Decls
: List_Id
) return Boolean
6857 Item
: Node_Id
:= First
(Decls
);
6860 -- Only other pragmas can come before this pragma
6863 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6866 elsif Item
= Pragma_Node
then
6872 end Is_Before_First_Decl
;
6874 -----------------------------
6875 -- Is_Configuration_Pragma --
6876 -----------------------------
6878 -- A configuration pragma must appear in the context clause of a
6879 -- compilation unit, and only other pragmas may precede it. Note that
6880 -- the test below also permits use in a configuration pragma file.
6882 function Is_Configuration_Pragma
return Boolean is
6883 Lis
: constant List_Id
:= List_Containing
(N
);
6884 Par
: constant Node_Id
:= Parent
(N
);
6888 -- If no parent, then we are in the configuration pragma file,
6889 -- so the placement is definitely appropriate.
6894 -- Otherwise we must be in the context clause of a compilation unit
6895 -- and the only thing allowed before us in the context list is more
6896 -- configuration pragmas.
6898 elsif Nkind
(Par
) = N_Compilation_Unit
6899 and then Context_Items
(Par
) = Lis
6906 elsif Nkind
(Prg
) /= N_Pragma
then
6916 end Is_Configuration_Pragma
;
6918 --------------------------
6919 -- Is_In_Context_Clause --
6920 --------------------------
6922 function Is_In_Context_Clause
return Boolean is
6924 Parent_Node
: Node_Id
;
6927 if not Is_List_Member
(N
) then
6931 Plist
:= List_Containing
(N
);
6932 Parent_Node
:= Parent
(Plist
);
6934 if Parent_Node
= Empty
6935 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6936 or else Context_Items
(Parent_Node
) /= Plist
6943 end Is_In_Context_Clause
;
6945 ---------------------------------
6946 -- Is_Static_String_Expression --
6947 ---------------------------------
6949 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6950 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6951 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6954 Analyze_And_Resolve
(Argx
);
6956 -- Special case Ada 83, where the expression will never be static,
6957 -- but we will return true if we had a string literal to start with.
6959 if Ada_Version
= Ada_83
then
6962 -- Normal case, true only if we end up with a string literal that
6963 -- is marked as being the result of evaluating a static expression.
6966 return Is_OK_Static_Expression
(Argx
)
6967 and then Nkind
(Argx
) = N_String_Literal
;
6970 end Is_Static_String_Expression
;
6972 ----------------------
6973 -- Pragma_Misplaced --
6974 ----------------------
6976 procedure Pragma_Misplaced
is
6978 Error_Pragma
("incorrect placement of pragma%");
6979 end Pragma_Misplaced
;
6981 ------------------------------------------------
6982 -- Process_Atomic_Independent_Shared_Volatile --
6983 ------------------------------------------------
6985 procedure Process_Atomic_Independent_Shared_Volatile
is
6986 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
);
6987 -- Apply additional checks for the GNAT pragma Volatile_Full_Access
6989 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
);
6990 -- Appropriately set flags on the given entity (either an array or
6991 -- record component, or an object declaration) according to the
6994 procedure Set_Atomic_VFA
(Ent
: Entity_Id
);
6995 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6996 -- no explicit alignment was given, set alignment to unknown, since
6997 -- back end knows what the alignment requirements are for atomic and
6998 -- full access arrays. Note: this is necessary for derived types.
7000 -------------------------
7001 -- Check_VFA_Conflicts --
7002 -------------------------
7004 procedure Check_VFA_Conflicts
(Ent
: Entity_Id
) is
7008 VFA_And_Atomic
: Boolean := False;
7009 -- Set True if atomic component present
7011 VFA_And_Aliased
: Boolean := False;
7012 -- Set True if aliased component present
7015 -- Fetch the type in case we are dealing with an object or
7018 if Is_Type
(Ent
) then
7021 pragma Assert
(Is_Object
(Ent
)
7023 Nkind
(Declaration_Node
(Ent
)) = N_Component_Declaration
);
7028 -- Check Atomic and VFA used together
7030 if Prag_Id
= Pragma_Volatile_Full_Access
7031 or else Is_Volatile_Full_Access
(Ent
)
7033 if Prag_Id
= Pragma_Atomic
7034 or else Prag_Id
= Pragma_Shared
7035 or else Is_Atomic
(Ent
)
7037 VFA_And_Atomic
:= True;
7039 elsif Is_Array_Type
(Typ
) then
7040 VFA_And_Atomic
:= Has_Atomic_Components
(Typ
);
7042 -- Note: Has_Atomic_Components is not used below, as this flag
7043 -- represents the pragma of the same name, Atomic_Components,
7044 -- which only applies to arrays.
7046 elsif Is_Record_Type
(Typ
) then
7047 -- Attributes cannot be applied to discriminants, only
7048 -- regular record components.
7050 Comp
:= First_Component
(Typ
);
7051 while Present
(Comp
) loop
7053 or else Is_Atomic
(Typ
)
7055 VFA_And_Atomic
:= True;
7060 Next_Component
(Comp
);
7064 if VFA_And_Atomic
then
7066 ("cannot have Volatile_Full_Access and Atomic for same "
7071 -- Check for the application of VFA to an entity that has aliased
7074 if Prag_Id
= Pragma_Volatile_Full_Access
then
7075 if Is_Array_Type
(Typ
)
7076 and then Has_Aliased_Components
(Typ
)
7078 VFA_And_Aliased
:= True;
7080 -- Note: Has_Aliased_Components, like Has_Atomic_Components,
7081 -- and Has_Independent_Components, applies only to arrays.
7082 -- However, this flag does not have a corresponding pragma, so
7083 -- perhaps it should be possible to apply it to record types as
7084 -- well. Should this be done ???
7086 elsif Is_Record_Type
(Typ
) then
7087 -- It is possible to have an aliased discriminant, so they
7088 -- must be checked along with normal components.
7090 Comp
:= First_Component_Or_Discriminant
(Typ
);
7091 while Present
(Comp
) loop
7092 if Is_Aliased
(Comp
)
7093 or else Is_Aliased
(Etype
(Comp
))
7095 VFA_And_Aliased
:= True;
7096 Check_SPARK_05_Restriction
7097 ("aliased is not allowed", Comp
);
7102 Next_Component_Or_Discriminant
(Comp
);
7106 if VFA_And_Aliased
then
7108 ("cannot apply Volatile_Full_Access (aliased component "
7112 end Check_VFA_Conflicts
;
7114 ------------------------------
7115 -- Mark_Component_Or_Object --
7116 ------------------------------
7118 procedure Mark_Component_Or_Object
(Ent
: Entity_Id
) is
7120 if Prag_Id
= Pragma_Atomic
7121 or else Prag_Id
= Pragma_Shared
7122 or else Prag_Id
= Pragma_Volatile_Full_Access
7124 if Prag_Id
= Pragma_Volatile_Full_Access
then
7125 Set_Is_Volatile_Full_Access
(Ent
);
7127 Set_Is_Atomic
(Ent
);
7130 -- If the object declaration has an explicit initialization, a
7131 -- temporary may have to be created to hold the expression, to
7132 -- ensure that access to the object remains atomic.
7134 if Nkind
(Parent
(Ent
)) = N_Object_Declaration
7135 and then Present
(Expression
(Parent
(Ent
)))
7137 Set_Has_Delayed_Freeze
(Ent
);
7141 -- Atomic/Shared/Volatile_Full_Access imply Independent
7143 if Prag_Id
/= Pragma_Volatile
then
7144 Set_Is_Independent
(Ent
);
7146 if Prag_Id
= Pragma_Independent
then
7147 Record_Independence_Check
(N
, Ent
);
7151 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7153 if Prag_Id
/= Pragma_Independent
then
7154 Set_Is_Volatile
(Ent
);
7155 Set_Treat_As_Volatile
(Ent
);
7157 end Mark_Component_Or_Object
;
7159 --------------------
7160 -- Set_Atomic_VFA --
7161 --------------------
7163 procedure Set_Atomic_VFA
(Ent
: Entity_Id
) is
7165 if Prag_Id
= Pragma_Volatile_Full_Access
then
7166 Set_Is_Volatile_Full_Access
(Ent
);
7168 Set_Is_Atomic
(Ent
);
7171 if not Has_Alignment_Clause
(Ent
) then
7172 Set_Alignment
(Ent
, Uint_0
);
7182 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
7185 Check_Ada_83_Warning
;
7186 Check_No_Identifiers
;
7187 Check_Arg_Count
(1);
7188 Check_Arg_Is_Local_Name
(Arg1
);
7189 E_Arg
:= Get_Pragma_Arg
(Arg1
);
7191 if Etype
(E_Arg
) = Any_Type
then
7195 E
:= Entity
(E_Arg
);
7197 -- A pragma that applies to a Ghost entity becomes Ghost for the
7198 -- purposes of legality checks and removal of ignored Ghost code.
7200 Mark_Ghost_Pragma
(N
, E
);
7202 -- Check duplicate before we chain ourselves
7204 Check_Duplicate_Pragma
(E
);
7206 -- Check appropriateness of the entity
7208 Decl
:= Declaration_Node
(E
);
7210 -- Deal with the case where the pragma/attribute is applied to a type
7213 if Rep_Item_Too_Early
(E
, N
)
7214 or else Rep_Item_Too_Late
(E
, N
)
7218 Check_First_Subtype
(Arg1
);
7221 -- Attribute belongs on the base type. If the view of the type is
7222 -- currently private, it also belongs on the underlying type.
7224 if Prag_Id
= Pragma_Atomic
7225 or else Prag_Id
= Pragma_Shared
7226 or else Prag_Id
= Pragma_Volatile_Full_Access
7229 Set_Atomic_VFA
(Base_Type
(E
));
7230 Set_Atomic_VFA
(Underlying_Type
(E
));
7233 -- Atomic/Shared/Volatile_Full_Access imply Independent
7235 if Prag_Id
/= Pragma_Volatile
then
7236 Set_Is_Independent
(E
);
7237 Set_Is_Independent
(Base_Type
(E
));
7238 Set_Is_Independent
(Underlying_Type
(E
));
7240 if Prag_Id
= Pragma_Independent
then
7241 Record_Independence_Check
(N
, Base_Type
(E
));
7245 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7247 if Prag_Id
/= Pragma_Independent
then
7248 Set_Is_Volatile
(E
);
7249 Set_Is_Volatile
(Base_Type
(E
));
7250 Set_Is_Volatile
(Underlying_Type
(E
));
7252 Set_Treat_As_Volatile
(E
);
7253 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7256 -- Apply Volatile to the composite type's individual components,
7259 if Prag_Id
= Pragma_Volatile
7260 and then Is_Record_Type
(Etype
(E
))
7265 Comp
:= First_Component
(E
);
7266 while Present
(Comp
) loop
7267 Mark_Component_Or_Object
(Comp
);
7269 Next_Component
(Comp
);
7274 -- Deal with the case where the pragma/attribute applies to a
7275 -- component or object declaration.
7277 elsif Nkind
(Decl
) = N_Object_Declaration
7278 or else (Nkind
(Decl
) = N_Component_Declaration
7279 and then Original_Record_Component
(E
) = E
)
7281 if Rep_Item_Too_Late
(E
, N
) then
7285 Mark_Component_Or_Object
(E
);
7287 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7290 -- Perform the checks needed to assure the proper use of the GNAT
7291 -- pragma Volatile_Full_Access.
7293 Check_VFA_Conflicts
(E
);
7295 -- The following check is only relevant when SPARK_Mode is on as
7296 -- this is not a standard Ada legality rule. Pragma Volatile can
7297 -- only apply to a full type declaration or an object declaration
7298 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7299 -- untagged derived types that are rewritten as subtypes of their
7300 -- respective root types.
7303 and then Prag_Id
= Pragma_Volatile
7305 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
7306 N_Object_Declaration
)
7309 ("argument of pragma % must denote a full type or object "
7310 & "declaration", Arg1
);
7312 end Process_Atomic_Independent_Shared_Volatile
;
7314 -------------------------------------------
7315 -- Process_Compile_Time_Warning_Or_Error --
7316 -------------------------------------------
7318 procedure Process_Compile_Time_Warning_Or_Error
is
7319 Validation_Needed
: Boolean := False;
7321 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7322 -- Tree visitor that checks if N is an attribute reference that can
7323 -- be statically computed by the back end. Validation_Needed is set
7324 -- to True if found.
7330 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7332 if Nkind
(N
) = N_Attribute_Reference
7333 and then Is_Entity_Name
(Prefix
(N
))
7336 Attr_Id
: constant Attribute_Id
:=
7337 Get_Attribute_Id
(Attribute_Name
(N
));
7339 if Attr_Id
= Attribute_Alignment
7340 or else Attr_Id
= Attribute_Size
7342 Validation_Needed
:= True;
7350 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7354 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7356 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7359 Check_Arg_Count
(2);
7360 Check_No_Identifiers
;
7361 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7362 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7364 if Compile_Time_Known_Value
(Arg1x
) then
7365 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7367 -- Register the expression for its validation after the back end has
7368 -- been called if it has occurrences of attributes Size or Alignment
7369 -- (because they may be statically computed by the back end and hence
7370 -- the whole expression needs to be reevaluated).
7373 Check_Expression
(Arg1x
);
7375 if Validation_Needed
then
7376 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7379 end Process_Compile_Time_Warning_Or_Error
;
7381 ------------------------
7382 -- Process_Convention --
7383 ------------------------
7385 procedure Process_Convention
7386 (C
: out Convention_Id
;
7387 Ent
: out Entity_Id
)
7391 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7392 -- Called if we have more than one Export/Import/Convention pragma.
7393 -- This is generally illegal, but we have a special case of allowing
7394 -- Import and Interface to coexist if they specify the convention in
7395 -- a consistent manner. We are allowed to do this, since Interface is
7396 -- an implementation defined pragma, and we choose to do it since we
7397 -- know Rational allows this combination. S is the entity id of the
7398 -- subprogram in question. This procedure also sets the special flag
7399 -- Import_Interface_Present in both pragmas in the case where we do
7400 -- have matching Import and Interface pragmas.
7402 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7403 -- Set convention in entity E, and also flag that the entity has a
7404 -- convention pragma. If entity is for a private or incomplete type,
7405 -- also set convention and flag on underlying type. This procedure
7406 -- also deals with the special case of C_Pass_By_Copy convention,
7407 -- and error checks for inappropriate convention specification.
7409 -------------------------------
7410 -- Diagnose_Multiple_Pragmas --
7411 -------------------------------
7413 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7414 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7418 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7419 -- Decl is a pragma node. This function returns True if this
7420 -- pragma has a first argument that is an identifier with a
7421 -- Chars field corresponding to the Convention_Id C.
7423 function Same_Name
(Decl
: Node_Id
) return Boolean;
7424 -- Decl is a pragma node. This function returns True if this
7425 -- pragma has a second argument that is an identifier with a
7426 -- Chars field that matches the Chars of the current subprogram.
7428 ---------------------
7429 -- Same_Convention --
7430 ---------------------
7432 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7433 Arg1
: constant Node_Id
:=
7434 First
(Pragma_Argument_Associations
(Decl
));
7437 if Present
(Arg1
) then
7439 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7441 if Nkind
(Arg
) = N_Identifier
7442 and then Is_Convention_Name
(Chars
(Arg
))
7443 and then Get_Convention_Id
(Chars
(Arg
)) = C
7451 end Same_Convention
;
7457 function Same_Name
(Decl
: Node_Id
) return Boolean is
7458 Arg1
: constant Node_Id
:=
7459 First
(Pragma_Argument_Associations
(Decl
));
7467 Arg2
:= Next
(Arg1
);
7474 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7476 if Nkind
(Arg
) = N_Identifier
7477 and then Chars
(Arg
) = Chars
(S
)
7486 -- Start of processing for Diagnose_Multiple_Pragmas
7491 -- Definitely give message if we have Convention/Export here
7493 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7496 -- If we have an Import or Export, scan back from pragma to
7497 -- find any previous pragma applying to the same procedure.
7498 -- The scan will be terminated by the start of the list, or
7499 -- hitting the subprogram declaration. This won't allow one
7500 -- pragma to appear in the public part and one in the private
7501 -- part, but that seems very unlikely in practice.
7505 while Present
(Decl
) and then Decl
/= Pdec
loop
7507 -- Look for pragma with same name as us
7509 if Nkind
(Decl
) = N_Pragma
7510 and then Same_Name
(Decl
)
7512 -- Give error if same as our pragma or Export/Convention
7514 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7517 Pragma_Name_Unmapped
(N
))
7521 -- Case of Import/Interface or the other way round
7523 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7524 Name_Interface
, Name_Import
)
7526 -- Here we know that we have Import and Interface. It
7527 -- doesn't matter which way round they are. See if
7528 -- they specify the same convention. If so, all OK,
7529 -- and set special flags to stop other messages
7531 if Same_Convention
(Decl
) then
7532 Set_Import_Interface_Present
(N
);
7533 Set_Import_Interface_Present
(Decl
);
7536 -- If different conventions, special message
7539 Error_Msg_Sloc
:= Sloc
(Decl
);
7541 ("convention differs from that given#", Arg1
);
7551 -- Give message if needed if we fall through those tests
7552 -- except on Relaxed_RM_Semantics where we let go: either this
7553 -- is a case accepted/ignored by other Ada compilers (e.g.
7554 -- a mix of Convention and Import), or another error will be
7555 -- generated later (e.g. using both Import and Export).
7557 if Err
and not Relaxed_RM_Semantics
then
7559 ("at most one Convention/Export/Import pragma is allowed",
7562 end Diagnose_Multiple_Pragmas
;
7564 --------------------------------
7565 -- Set_Convention_From_Pragma --
7566 --------------------------------
7568 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7570 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7571 -- for an overridden dispatching operation. Technically this is
7572 -- an amendment and should only be done in Ada 2005 mode. However,
7573 -- this is clearly a mistake, since the problem that is addressed
7574 -- by this AI is that there is a clear gap in the RM.
7576 if Is_Dispatching_Operation
(E
)
7577 and then Present
(Overridden_Operation
(E
))
7578 and then C
/= Convention
(Overridden_Operation
(E
))
7581 ("cannot change convention for overridden dispatching "
7582 & "operation", Arg1
);
7585 -- Special checks for Convention_Stdcall
7587 if C
= Convention_Stdcall
then
7589 -- A dispatching call is not allowed. A dispatching subprogram
7590 -- cannot be used to interface to the Win32 API, so in fact
7591 -- this check does not impose any effective restriction.
7593 if Is_Dispatching_Operation
(E
) then
7594 Error_Msg_Sloc
:= Sloc
(E
);
7596 -- Note: make this unconditional so that if there is more
7597 -- than one call to which the pragma applies, we get a
7598 -- message for each call. Also don't use Error_Pragma,
7599 -- so that we get multiple messages.
7602 ("dispatching subprogram# cannot use Stdcall convention!",
7605 -- Several allowed cases
7607 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7611 or else Ekind
(E
) = E_Variable
7613 -- A component as well. The entity does not have its Ekind
7614 -- set until the enclosing record declaration is fully
7617 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7619 -- An access to subprogram is also allowed
7623 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7625 -- Allow internal call to set convention of subprogram type
7627 or else Ekind
(E
) = E_Subprogram_Type
7633 ("second argument of pragma% must be subprogram (type)",
7638 -- Set the convention
7640 Set_Convention
(E
, C
);
7641 Set_Has_Convention_Pragma
(E
);
7643 -- For the case of a record base type, also set the convention of
7644 -- any anonymous access types declared in the record which do not
7645 -- currently have a specified convention.
7647 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7652 Comp
:= First_Component
(E
);
7653 while Present
(Comp
) loop
7654 if Present
(Etype
(Comp
))
7655 and then Ekind_In
(Etype
(Comp
),
7656 E_Anonymous_Access_Type
,
7657 E_Anonymous_Access_Subprogram_Type
)
7658 and then not Has_Convention_Pragma
(Comp
)
7660 Set_Convention
(Comp
, C
);
7663 Next_Component
(Comp
);
7668 -- Deal with incomplete/private type case, where underlying type
7669 -- is available, so set convention of that underlying type.
7671 if Is_Incomplete_Or_Private_Type
(E
)
7672 and then Present
(Underlying_Type
(E
))
7674 Set_Convention
(Underlying_Type
(E
), C
);
7675 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7678 -- A class-wide type should inherit the convention of the specific
7679 -- root type (although this isn't specified clearly by the RM).
7681 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7682 Set_Convention
(Class_Wide_Type
(E
), C
);
7685 -- If the entity is a record type, then check for special case of
7686 -- C_Pass_By_Copy, which is treated the same as C except that the
7687 -- special record flag is set. This convention is only permitted
7688 -- on record types (see AI95-00131).
7690 if Cname
= Name_C_Pass_By_Copy
then
7691 if Is_Record_Type
(E
) then
7692 Set_C_Pass_By_Copy
(Base_Type
(E
));
7693 elsif Is_Incomplete_Or_Private_Type
(E
)
7694 and then Is_Record_Type
(Underlying_Type
(E
))
7696 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7699 ("C_Pass_By_Copy convention allowed only for record type",
7704 -- If the entity is a derived boolean type, check for the special
7705 -- case of convention C, C++, or Fortran, where we consider any
7706 -- nonzero value to represent true.
7708 if Is_Discrete_Type
(E
)
7709 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7715 C
= Convention_Fortran
)
7717 Set_Nonzero_Is_True
(Base_Type
(E
));
7719 end Set_Convention_From_Pragma
;
7723 Comp_Unit
: Unit_Number_Type
;
7728 -- Start of processing for Process_Convention
7731 Check_At_Least_N_Arguments
(2);
7732 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7733 Check_Arg_Is_Identifier
(Arg1
);
7734 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7736 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7737 -- tested again below to set the critical flag).
7739 if Cname
= Name_C_Pass_By_Copy
then
7742 -- Otherwise we must have something in the standard convention list
7744 elsif Is_Convention_Name
(Cname
) then
7745 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7747 -- Otherwise warn on unrecognized convention
7750 if Warn_On_Export_Import
then
7752 ("??unrecognized convention name, C assumed",
7753 Get_Pragma_Arg
(Arg1
));
7759 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7760 Check_Arg_Is_Local_Name
(Arg2
);
7762 Id
:= Get_Pragma_Arg
(Arg2
);
7765 if not Is_Entity_Name
(Id
) then
7766 Error_Pragma_Arg
("entity name required", Arg2
);
7771 -- Set entity to return
7775 -- Ada_Pass_By_Copy special checking
7777 if C
= Convention_Ada_Pass_By_Copy
then
7778 if not Is_First_Subtype
(E
) then
7780 ("convention `Ada_Pass_By_Copy` only allowed for types",
7784 if Is_By_Reference_Type
(E
) then
7786 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7790 -- Ada_Pass_By_Reference special checking
7792 elsif C
= Convention_Ada_Pass_By_Reference
then
7793 if not Is_First_Subtype
(E
) then
7795 ("convention `Ada_Pass_By_Reference` only allowed for types",
7799 if Is_By_Copy_Type
(E
) then
7801 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7806 -- Go to renamed subprogram if present, since convention applies to
7807 -- the actual renamed entity, not to the renaming entity. If the
7808 -- subprogram is inherited, go to parent subprogram.
7810 if Is_Subprogram
(E
)
7811 and then Present
(Alias
(E
))
7813 if Nkind
(Parent
(Declaration_Node
(E
))) =
7814 N_Subprogram_Renaming_Declaration
7816 if Scope
(E
) /= Scope
(Alias
(E
)) then
7818 ("cannot apply pragma% to non-local entity&#", E
);
7823 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7824 N_Private_Extension_Declaration
)
7825 and then Scope
(E
) = Scope
(Alias
(E
))
7829 -- Return the parent subprogram the entity was inherited from
7835 -- Check that we are not applying this to a specless body. Relax this
7836 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7838 if Is_Subprogram
(E
)
7839 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7840 and then not Relaxed_RM_Semantics
7843 ("pragma% requires separate spec and must come before body");
7846 -- Check that we are not applying this to a named constant
7848 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7849 Error_Msg_Name_1
:= Pname
;
7851 ("cannot apply pragma% to named constant!",
7852 Get_Pragma_Arg
(Arg2
));
7854 ("\supply appropriate type for&!", Arg2
);
7857 if Ekind
(E
) = E_Enumeration_Literal
then
7858 Error_Pragma
("enumeration literal not allowed for pragma%");
7861 -- Check for rep item appearing too early or too late
7863 if Etype
(E
) = Any_Type
7864 or else Rep_Item_Too_Early
(E
, N
)
7868 elsif Present
(Underlying_Type
(E
)) then
7869 E
:= Underlying_Type
(E
);
7872 if Rep_Item_Too_Late
(E
, N
) then
7876 if Has_Convention_Pragma
(E
) then
7877 Diagnose_Multiple_Pragmas
(E
);
7879 elsif Convention
(E
) = Convention_Protected
7880 or else Ekind
(Scope
(E
)) = E_Protected_Type
7883 ("a protected operation cannot be given a different convention",
7887 -- For Intrinsic, a subprogram is required
7889 if C
= Convention_Intrinsic
7890 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7892 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7894 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7896 ("second argument of pragma% must be a subprogram", Arg2
);
7900 -- Deal with non-subprogram cases
7902 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7903 Set_Convention_From_Pragma
(E
);
7907 -- The pragma must apply to a first subtype, but it can also
7908 -- apply to a generic type in a generic formal part, in which
7909 -- case it will also appear in the corresponding instance.
7911 if Is_Generic_Type
(E
) or else In_Instance
then
7914 Check_First_Subtype
(Arg2
);
7917 Set_Convention_From_Pragma
(Base_Type
(E
));
7919 -- For access subprograms, we must set the convention on the
7920 -- internally generated directly designated type as well.
7922 if Ekind
(E
) = E_Access_Subprogram_Type
then
7923 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7927 -- For the subprogram case, set proper convention for all homonyms
7928 -- in same scope and the same declarative part, i.e. the same
7929 -- compilation unit.
7932 Comp_Unit
:= Get_Source_Unit
(E
);
7933 Set_Convention_From_Pragma
(E
);
7935 -- Treat a pragma Import as an implicit body, and pragma import
7936 -- as implicit reference (for navigation in GPS).
7938 if Prag_Id
= Pragma_Import
then
7939 Generate_Reference
(E
, Id
, 'b');
7941 -- For exported entities we restrict the generation of references
7942 -- to entities exported to foreign languages since entities
7943 -- exported to Ada do not provide further information to GPS and
7944 -- add undesired references to the output of the gnatxref tool.
7946 elsif Prag_Id
= Pragma_Export
7947 and then Convention
(E
) /= Convention_Ada
7949 Generate_Reference
(E
, Id
, 'i');
7952 -- If the pragma comes from an aspect, it only applies to the
7953 -- given entity, not its homonyms.
7955 if From_Aspect_Specification
(N
) then
7956 if C
= Convention_Intrinsic
7957 and then Nkind
(Ent
) = N_Defining_Operator_Symbol
7959 if Is_Fixed_Point_Type
(Etype
(Ent
))
7960 or else Is_Fixed_Point_Type
(Etype
(First_Entity
(Ent
)))
7961 or else Is_Fixed_Point_Type
(Etype
(Last_Entity
(Ent
)))
7964 ("no intrinsic operator available for this fixed-point "
7967 ("\use expression functions with the desired "
7968 & "conversions made explicit", N
);
7975 -- Otherwise Loop through the homonyms of the pragma argument's
7976 -- entity, an apply convention to those in the current scope.
7982 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7984 -- Ignore entry for which convention is already set
7986 if Has_Convention_Pragma
(E1
) then
7990 if Is_Subprogram
(E1
)
7991 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
7993 and then not Relaxed_RM_Semantics
7995 Set_Has_Completion
(E
); -- to prevent cascaded error
7997 ("pragma% requires separate spec and must come before "
8001 -- Do not set the pragma on inherited operations or on formal
8004 if Comes_From_Source
(E1
)
8005 and then Comp_Unit
= Get_Source_Unit
(E1
)
8006 and then not Is_Formal_Subprogram
(E1
)
8007 and then Nkind
(Original_Node
(Parent
(E1
))) /=
8008 N_Full_Type_Declaration
8010 if Present
(Alias
(E1
))
8011 and then Scope
(E1
) /= Scope
(Alias
(E1
))
8014 ("cannot apply pragma% to non-local entity& declared#",
8018 Set_Convention_From_Pragma
(E1
);
8020 if Prag_Id
= Pragma_Import
then
8021 Generate_Reference
(E1
, Id
, 'b');
8029 end Process_Convention
;
8031 ----------------------------------------
8032 -- Process_Disable_Enable_Atomic_Sync --
8033 ----------------------------------------
8035 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
8037 Check_No_Identifiers
;
8038 Check_At_Most_N_Arguments
(1);
8040 -- Modeled internally as
8041 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
8046 Pragma_Argument_Associations
=> New_List
(
8047 Make_Pragma_Argument_Association
(Loc
,
8049 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
8051 if Present
(Arg1
) then
8052 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
8056 end Process_Disable_Enable_Atomic_Sync
;
8058 -------------------------------------------------
8059 -- Process_Extended_Import_Export_Internal_Arg --
8060 -------------------------------------------------
8062 procedure Process_Extended_Import_Export_Internal_Arg
8063 (Arg_Internal
: Node_Id
:= Empty
)
8066 if No
(Arg_Internal
) then
8067 Error_Pragma
("Internal parameter required for pragma%");
8070 if Nkind
(Arg_Internal
) = N_Identifier
then
8073 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
8074 and then (Prag_Id
= Pragma_Import_Function
8076 Prag_Id
= Pragma_Export_Function
)
8082 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
8085 Check_Arg_Is_Local_Name
(Arg_Internal
);
8086 end Process_Extended_Import_Export_Internal_Arg
;
8088 --------------------------------------------------
8089 -- Process_Extended_Import_Export_Object_Pragma --
8090 --------------------------------------------------
8092 procedure Process_Extended_Import_Export_Object_Pragma
8093 (Arg_Internal
: Node_Id
;
8094 Arg_External
: Node_Id
;
8100 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8101 Def_Id
:= Entity
(Arg_Internal
);
8103 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
8105 ("pragma% must designate an object", Arg_Internal
);
8108 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
8110 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
8113 ("previous Common/Psect_Object applies, pragma % not permitted",
8117 if Rep_Item_Too_Late
(Def_Id
, N
) then
8121 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
8123 if Present
(Arg_Size
) then
8124 Check_Arg_Is_External_Name
(Arg_Size
);
8127 -- Export_Object case
8129 if Prag_Id
= Pragma_Export_Object
then
8130 if not Is_Library_Level_Entity
(Def_Id
) then
8132 ("argument for pragma% must be library level entity",
8136 if Ekind
(Current_Scope
) = E_Generic_Package
then
8137 Error_Pragma
("pragma& cannot appear in a generic unit");
8140 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
8142 ("exported object must have compile time known size",
8146 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
8147 Error_Msg_N
("??duplicate Export_Object pragma", N
);
8149 Set_Exported
(Def_Id
, Arg_Internal
);
8152 -- Import_Object case
8155 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
8157 ("cannot use pragma% for task/protected object",
8161 if Ekind
(Def_Id
) = E_Constant
then
8163 ("cannot import a constant", Arg_Internal
);
8166 if Warn_On_Export_Import
8167 and then Has_Discriminants
(Etype
(Def_Id
))
8170 ("imported value must be initialized??", Arg_Internal
);
8173 if Warn_On_Export_Import
8174 and then Is_Access_Type
(Etype
(Def_Id
))
8177 ("cannot import object of an access type??", Arg_Internal
);
8180 if Warn_On_Export_Import
8181 and then Is_Imported
(Def_Id
)
8183 Error_Msg_N
("??duplicate Import_Object pragma", N
);
8185 -- Check for explicit initialization present. Note that an
8186 -- initialization generated by the code generator, e.g. for an
8187 -- access type, does not count here.
8189 elsif Present
(Expression
(Parent
(Def_Id
)))
8192 (Original_Node
(Expression
(Parent
(Def_Id
))))
8194 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8196 ("imported entities cannot be initialized (RM B.1(24))",
8197 "\no initialization allowed for & declared#", Arg1
);
8199 Set_Imported
(Def_Id
);
8200 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
8203 end Process_Extended_Import_Export_Object_Pragma
;
8205 ------------------------------------------------------
8206 -- Process_Extended_Import_Export_Subprogram_Pragma --
8207 ------------------------------------------------------
8209 procedure Process_Extended_Import_Export_Subprogram_Pragma
8210 (Arg_Internal
: Node_Id
;
8211 Arg_External
: Node_Id
;
8212 Arg_Parameter_Types
: Node_Id
;
8213 Arg_Result_Type
: Node_Id
:= Empty
;
8214 Arg_Mechanism
: Node_Id
;
8215 Arg_Result_Mechanism
: Node_Id
:= Empty
)
8221 Ambiguous
: Boolean;
8224 function Same_Base_Type
8226 Formal
: Entity_Id
) return Boolean;
8227 -- Determines if Ptype references the type of Formal. Note that only
8228 -- the base types need to match according to the spec. Ptype here is
8229 -- the argument from the pragma, which is either a type name, or an
8230 -- access attribute.
8232 --------------------
8233 -- Same_Base_Type --
8234 --------------------
8236 function Same_Base_Type
8238 Formal
: Entity_Id
) return Boolean
8240 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8244 -- Case where pragma argument is typ'Access
8246 if Nkind
(Ptype
) = N_Attribute_Reference
8247 and then Attribute_Name
(Ptype
) = Name_Access
8249 Pref
:= Prefix
(Ptype
);
8252 if not Is_Entity_Name
(Pref
)
8253 or else Entity
(Pref
) = Any_Type
8258 -- We have a match if the corresponding argument is of an
8259 -- anonymous access type, and its designated type matches the
8260 -- type of the prefix of the access attribute
8262 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8263 and then Base_Type
(Entity
(Pref
)) =
8264 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8266 -- Case where pragma argument is a type name
8271 if not Is_Entity_Name
(Ptype
)
8272 or else Entity
(Ptype
) = Any_Type
8277 -- We have a match if the corresponding argument is of the type
8278 -- given in the pragma (comparing base types)
8280 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8284 -- Start of processing for
8285 -- Process_Extended_Import_Export_Subprogram_Pragma
8288 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8292 -- Loop through homonyms (overloadings) of the entity
8294 Hom_Id
:= Entity
(Arg_Internal
);
8295 while Present
(Hom_Id
) loop
8296 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8298 -- We need a subprogram in the current scope
8300 if not Is_Subprogram
(Def_Id
)
8301 or else Scope
(Def_Id
) /= Current_Scope
8308 -- Pragma cannot apply to subprogram body
8310 if Is_Subprogram
(Def_Id
)
8311 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8315 ("pragma% requires separate spec and must come before "
8319 -- Test result type if given, note that the result type
8320 -- parameter can only be present for the function cases.
8322 if Present
(Arg_Result_Type
)
8323 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8327 elsif Etype
(Def_Id
) /= Standard_Void_Type
8328 and then Nam_In
(Pname
, Name_Export_Procedure
,
8329 Name_Import_Procedure
)
8333 -- Test parameter types if given. Note that this parameter has
8334 -- not been analyzed (and must not be, since it is semantic
8335 -- nonsense), so we get it as the parser left it.
8337 elsif Present
(Arg_Parameter_Types
) then
8338 Check_Matching_Types
: declare
8343 Formal
:= First_Formal
(Def_Id
);
8345 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8346 if Present
(Formal
) then
8350 -- A list of one type, e.g. (List) is parsed as a
8351 -- parenthesized expression.
8353 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8354 and then Paren_Count
(Arg_Parameter_Types
) = 1
8357 or else Present
(Next_Formal
(Formal
))
8362 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8365 -- A list of more than one type is parsed as a aggregate
8367 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8368 and then Paren_Count
(Arg_Parameter_Types
) = 0
8370 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8371 while Present
(Ptype
) or else Present
(Formal
) loop
8374 or else not Same_Base_Type
(Ptype
, Formal
)
8379 Next_Formal
(Formal
);
8384 -- Anything else is of the wrong form
8388 ("wrong form for Parameter_Types parameter",
8389 Arg_Parameter_Types
);
8391 end Check_Matching_Types
;
8394 -- Match is now False if the entry we found did not match
8395 -- either a supplied Parameter_Types or Result_Types argument
8401 -- Ambiguous case, the flag Ambiguous shows if we already
8402 -- detected this and output the initial messages.
8405 if not Ambiguous
then
8407 Error_Msg_Name_1
:= Pname
;
8409 ("pragma% does not uniquely identify subprogram!",
8411 Error_Msg_Sloc
:= Sloc
(Ent
);
8412 Error_Msg_N
("matching subprogram #!", N
);
8416 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8417 Error_Msg_N
("matching subprogram #!", N
);
8422 Hom_Id
:= Homonym
(Hom_Id
);
8425 -- See if we found an entry
8428 if not Ambiguous
then
8429 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8431 ("pragma% cannot be given for generic subprogram");
8434 ("pragma% does not identify local subprogram");
8441 -- Import pragmas must be for imported entities
8443 if Prag_Id
= Pragma_Import_Function
8445 Prag_Id
= Pragma_Import_Procedure
8447 Prag_Id
= Pragma_Import_Valued_Procedure
8449 if not Is_Imported
(Ent
) then
8451 ("pragma Import or Interface must precede pragma%");
8454 -- Here we have the Export case which can set the entity as exported
8456 -- But does not do so if the specified external name is null, since
8457 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8458 -- compatible) to request no external name.
8460 elsif Nkind
(Arg_External
) = N_String_Literal
8461 and then String_Length
(Strval
(Arg_External
)) = 0
8465 -- In all other cases, set entity as exported
8468 Set_Exported
(Ent
, Arg_Internal
);
8471 -- Special processing for Valued_Procedure cases
8473 if Prag_Id
= Pragma_Import_Valued_Procedure
8475 Prag_Id
= Pragma_Export_Valued_Procedure
8477 Formal
:= First_Formal
(Ent
);
8480 Error_Pragma
("at least one parameter required for pragma%");
8482 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8483 Error_Pragma
("first parameter must have mode out for pragma%");
8486 Set_Is_Valued_Procedure
(Ent
);
8490 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8492 -- Process Result_Mechanism argument if present. We have already
8493 -- checked that this is only allowed for the function case.
8495 if Present
(Arg_Result_Mechanism
) then
8496 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8499 -- Process Mechanism parameter if present. Note that this parameter
8500 -- is not analyzed, and must not be analyzed since it is semantic
8501 -- nonsense, so we get it in exactly as the parser left it.
8503 if Present
(Arg_Mechanism
) then
8511 -- A single mechanism association without a formal parameter
8512 -- name is parsed as a parenthesized expression. All other
8513 -- cases are parsed as aggregates, so we rewrite the single
8514 -- parameter case as an aggregate for consistency.
8516 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8517 and then Paren_Count
(Arg_Mechanism
) = 1
8519 Rewrite
(Arg_Mechanism
,
8520 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8521 Expressions
=> New_List
(
8522 Relocate_Node
(Arg_Mechanism
))));
8525 -- Case of only mechanism name given, applies to all formals
8527 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8528 Formal
:= First_Formal
(Ent
);
8529 while Present
(Formal
) loop
8530 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8531 Next_Formal
(Formal
);
8534 -- Case of list of mechanism associations given
8537 if Null_Record_Present
(Arg_Mechanism
) then
8539 ("inappropriate form for Mechanism parameter",
8543 -- Deal with positional ones first
8545 Formal
:= First_Formal
(Ent
);
8547 if Present
(Expressions
(Arg_Mechanism
)) then
8548 Mname
:= First
(Expressions
(Arg_Mechanism
));
8549 while Present
(Mname
) loop
8552 ("too many mechanism associations", Mname
);
8555 Set_Mechanism_Value
(Formal
, Mname
);
8556 Next_Formal
(Formal
);
8561 -- Deal with named entries
8563 if Present
(Component_Associations
(Arg_Mechanism
)) then
8564 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8565 while Present
(Massoc
) loop
8566 Choice
:= First
(Choices
(Massoc
));
8568 if Nkind
(Choice
) /= N_Identifier
8569 or else Present
(Next
(Choice
))
8572 ("incorrect form for mechanism association",
8576 Formal
:= First_Formal
(Ent
);
8580 ("parameter name & not present", Choice
);
8583 if Chars
(Choice
) = Chars
(Formal
) then
8585 (Formal
, Expression
(Massoc
));
8587 -- Set entity on identifier (needed by ASIS)
8589 Set_Entity
(Choice
, Formal
);
8594 Next_Formal
(Formal
);
8603 end Process_Extended_Import_Export_Subprogram_Pragma
;
8605 --------------------------
8606 -- Process_Generic_List --
8607 --------------------------
8609 procedure Process_Generic_List
is
8614 Check_No_Identifiers
;
8615 Check_At_Least_N_Arguments
(1);
8617 -- Check all arguments are names of generic units or instances
8620 while Present
(Arg
) loop
8621 Exp
:= Get_Pragma_Arg
(Arg
);
8624 if not Is_Entity_Name
(Exp
)
8626 (not Is_Generic_Instance
(Entity
(Exp
))
8628 not Is_Generic_Unit
(Entity
(Exp
)))
8631 ("pragma% argument must be name of generic unit/instance",
8637 end Process_Generic_List
;
8639 ------------------------------------
8640 -- Process_Import_Predefined_Type --
8641 ------------------------------------
8643 procedure Process_Import_Predefined_Type
is
8644 Loc
: constant Source_Ptr
:= Sloc
(N
);
8646 Ftyp
: Node_Id
:= Empty
;
8652 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8654 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8655 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8659 Ftyp
:= Node
(Elmt
);
8661 if Present
(Ftyp
) then
8663 -- Don't build a derived type declaration, because predefined C
8664 -- types have no declaration anywhere, so cannot really be named.
8665 -- Instead build a full type declaration, starting with an
8666 -- appropriate type definition is built
8668 if Is_Floating_Point_Type
(Ftyp
) then
8669 Def
:= Make_Floating_Point_Definition
(Loc
,
8670 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8671 Make_Real_Range_Specification
(Loc
,
8672 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8673 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8675 -- Should never have a predefined type we cannot handle
8678 raise Program_Error
;
8681 -- Build and insert a Full_Type_Declaration, which will be
8682 -- analyzed as soon as this list entry has been analyzed.
8684 Decl
:= Make_Full_Type_Declaration
(Loc
,
8685 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8686 Type_Definition
=> Def
);
8688 Insert_After
(N
, Decl
);
8689 Mark_Rewrite_Insertion
(Decl
);
8692 Error_Pragma_Arg
("no matching type found for pragma%",
8695 end Process_Import_Predefined_Type
;
8697 ---------------------------------
8698 -- Process_Import_Or_Interface --
8699 ---------------------------------
8701 procedure Process_Import_Or_Interface
is
8707 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8708 -- pragma Import (Entity, "external name");
8710 if Relaxed_RM_Semantics
8711 and then Arg_Count
= 2
8712 and then Prag_Id
= Pragma_Import
8713 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8716 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8719 if not Is_Entity_Name
(Def_Id
) then
8720 Error_Pragma_Arg
("entity name required", Arg1
);
8723 Def_Id
:= Entity
(Def_Id
);
8724 Kill_Size_Check_Code
(Def_Id
);
8725 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8728 Process_Convention
(C
, Def_Id
);
8730 -- A pragma that applies to a Ghost entity becomes Ghost for the
8731 -- purposes of legality checks and removal of ignored Ghost code.
8733 Mark_Ghost_Pragma
(N
, Def_Id
);
8734 Kill_Size_Check_Code
(Def_Id
);
8735 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8738 -- Various error checks
8740 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8742 -- We do not permit Import to apply to a renaming declaration
8744 if Present
(Renamed_Object
(Def_Id
)) then
8746 ("pragma% not allowed for object renaming", Arg2
);
8748 -- User initialization is not allowed for imported object, but
8749 -- the object declaration may contain a default initialization,
8750 -- that will be discarded. Note that an explicit initialization
8751 -- only counts if it comes from source, otherwise it is simply
8752 -- the code generator making an implicit initialization explicit.
8754 elsif Present
(Expression
(Parent
(Def_Id
)))
8755 and then Comes_From_Source
8756 (Original_Node
(Expression
(Parent
(Def_Id
))))
8758 -- Set imported flag to prevent cascaded errors
8760 Set_Is_Imported
(Def_Id
);
8762 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8764 ("no initialization allowed for declaration of& #",
8765 "\imported entities cannot be initialized (RM B.1(24))",
8769 -- If the pragma comes from an aspect specification the
8770 -- Is_Imported flag has already been set.
8772 if not From_Aspect_Specification
(N
) then
8773 Set_Imported
(Def_Id
);
8776 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8778 -- Note that we do not set Is_Public here. That's because we
8779 -- only want to set it if there is no address clause, and we
8780 -- don't know that yet, so we delay that processing till
8783 -- pragma Import completes deferred constants
8785 if Ekind
(Def_Id
) = E_Constant
then
8786 Set_Has_Completion
(Def_Id
);
8789 -- It is not possible to import a constant of an unconstrained
8790 -- array type (e.g. string) because there is no simple way to
8791 -- write a meaningful subtype for it.
8793 if Is_Array_Type
(Etype
(Def_Id
))
8794 and then not Is_Constrained
(Etype
(Def_Id
))
8797 ("imported constant& must have a constrained subtype",
8802 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8804 -- If the name is overloaded, pragma applies to all of the denoted
8805 -- entities in the same declarative part, unless the pragma comes
8806 -- from an aspect specification or was generated by the compiler
8807 -- (such as for pragma Provide_Shift_Operators).
8810 while Present
(Hom_Id
) loop
8812 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8814 -- Ignore inherited subprograms because the pragma will apply
8815 -- to the parent operation, which is the one called.
8817 if Is_Overloadable
(Def_Id
)
8818 and then Present
(Alias
(Def_Id
))
8822 -- If it is not a subprogram, it must be in an outer scope and
8823 -- pragma does not apply.
8825 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8828 -- The pragma does not apply to primitives of interfaces
8830 elsif Is_Dispatching_Operation
(Def_Id
)
8831 and then Present
(Find_Dispatching_Type
(Def_Id
))
8832 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8836 -- Verify that the homonym is in the same declarative part (not
8837 -- just the same scope). If the pragma comes from an aspect
8838 -- specification we know that it is part of the declaration.
8840 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8841 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8842 and then not From_Aspect_Specification
(N
)
8847 -- If the pragma comes from an aspect specification the
8848 -- Is_Imported flag has already been set.
8850 if not From_Aspect_Specification
(N
) then
8851 Set_Imported
(Def_Id
);
8854 -- Reject an Import applied to an abstract subprogram
8856 if Is_Subprogram
(Def_Id
)
8857 and then Is_Abstract_Subprogram
(Def_Id
)
8859 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8861 ("cannot import abstract subprogram& declared#",
8865 -- Special processing for Convention_Intrinsic
8867 if C
= Convention_Intrinsic
then
8869 -- Link_Name argument not allowed for intrinsic
8873 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8875 -- If no external name is present, then check that this
8876 -- is a valid intrinsic subprogram. If an external name
8877 -- is present, then this is handled by the back end.
8880 Check_Intrinsic_Subprogram
8881 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8885 -- Verify that the subprogram does not have a completion
8886 -- through a renaming declaration. For other completions the
8887 -- pragma appears as a too late representation.
8890 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8894 and then Nkind
(Decl
) = N_Subprogram_Declaration
8895 and then Present
(Corresponding_Body
(Decl
))
8896 and then Nkind
(Unit_Declaration_Node
8897 (Corresponding_Body
(Decl
))) =
8898 N_Subprogram_Renaming_Declaration
8900 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8902 ("cannot import&, renaming already provided for "
8903 & "declaration #", N
, Def_Id
);
8907 -- If the pragma comes from an aspect specification, there
8908 -- must be an Import aspect specified as well. In the rare
8909 -- case where Import is set to False, the suprogram needs to
8910 -- have a local completion.
8913 Imp_Aspect
: constant Node_Id
:=
8914 Find_Aspect
(Def_Id
, Aspect_Import
);
8918 if Present
(Imp_Aspect
)
8919 and then Present
(Expression
(Imp_Aspect
))
8921 Expr
:= Expression
(Imp_Aspect
);
8922 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8924 if Is_Entity_Name
(Expr
)
8925 and then Entity
(Expr
) = Standard_True
8927 Set_Has_Completion
(Def_Id
);
8930 -- If there is no expression, the default is True, as for
8931 -- all boolean aspects. Same for the older pragma.
8934 Set_Has_Completion
(Def_Id
);
8938 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8941 if Is_Compilation_Unit
(Hom_Id
) then
8943 -- Its possible homonyms are not affected by the pragma.
8944 -- Such homonyms might be present in the context of other
8945 -- units being compiled.
8949 elsif From_Aspect_Specification
(N
) then
8952 -- If the pragma was created by the compiler, then we don't
8953 -- want it to apply to other homonyms. This kind of case can
8954 -- occur when using pragma Provide_Shift_Operators, which
8955 -- generates implicit shift and rotate operators with Import
8956 -- pragmas that might apply to earlier explicit or implicit
8957 -- declarations marked with Import (for example, coming from
8958 -- an earlier pragma Provide_Shift_Operators for another type),
8959 -- and we don't generally want other homonyms being treated
8960 -- as imported or the pragma flagged as an illegal duplicate.
8962 elsif not Comes_From_Source
(N
) then
8966 Hom_Id
:= Homonym
(Hom_Id
);
8970 -- Import a CPP class
8972 elsif C
= Convention_CPP
8973 and then (Is_Record_Type
(Def_Id
)
8974 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8976 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8977 if Present
(Full_View
(Def_Id
)) then
8978 Def_Id
:= Full_View
(Def_Id
);
8982 ("cannot import 'C'P'P type before full declaration seen",
8983 Get_Pragma_Arg
(Arg2
));
8985 -- Although we have reported the error we decorate it as
8986 -- CPP_Class to avoid reporting spurious errors
8988 Set_Is_CPP_Class
(Def_Id
);
8993 -- Types treated as CPP classes must be declared limited (note:
8994 -- this used to be a warning but there is no real benefit to it
8995 -- since we did effectively intend to treat the type as limited
8998 if not Is_Limited_Type
(Def_Id
) then
9000 ("imported 'C'P'P type must be limited",
9001 Get_Pragma_Arg
(Arg2
));
9004 if Etype
(Def_Id
) /= Def_Id
9005 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
9007 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
9010 Set_Is_CPP_Class
(Def_Id
);
9012 -- Imported CPP types must not have discriminants (because C++
9013 -- classes do not have discriminants).
9015 if Has_Discriminants
(Def_Id
) then
9017 ("imported 'C'P'P type cannot have discriminants",
9018 First
(Discriminant_Specifications
9019 (Declaration_Node
(Def_Id
))));
9022 -- Check that components of imported CPP types do not have default
9023 -- expressions. For private types this check is performed when the
9024 -- full view is analyzed (see Process_Full_View).
9026 if not Is_Private_Type
(Def_Id
) then
9027 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
9030 -- Import a CPP exception
9032 elsif C
= Convention_CPP
9033 and then Ekind
(Def_Id
) = E_Exception
9037 ("'External_'Name arguments is required for 'Cpp exception",
9040 -- As only a string is allowed, Check_Arg_Is_External_Name
9043 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9046 if Present
(Arg4
) then
9048 ("Link_Name argument not allowed for imported Cpp exception",
9052 -- Do not call Set_Interface_Name as the name of the exception
9053 -- shouldn't be modified (and in particular it shouldn't be
9054 -- the External_Name). For exceptions, the External_Name is the
9055 -- name of the RTTI structure.
9057 -- ??? Emit an error if pragma Import/Export_Exception is present
9059 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
9061 Check_Arg_Count
(3);
9062 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
9064 Process_Import_Predefined_Type
;
9068 ("second argument of pragma% must be object, subprogram "
9069 & "or incomplete type",
9073 -- If this pragma applies to a compilation unit, then the unit, which
9074 -- is a subprogram, does not require (or allow) a body. We also do
9075 -- not need to elaborate imported procedures.
9077 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
9079 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
9081 Set_Body_Required
(Cunit
, False);
9084 end Process_Import_Or_Interface
;
9086 --------------------
9087 -- Process_Inline --
9088 --------------------
9090 procedure Process_Inline
(Status
: Inline_Status
) is
9097 Ghost_Error_Posted
: Boolean := False;
9098 -- Flag set when an error concerning the illegal mix of Ghost and
9099 -- non-Ghost subprograms is emitted.
9101 Ghost_Id
: Entity_Id
:= Empty
;
9102 -- The entity of the first Ghost subprogram encountered while
9103 -- processing the arguments of the pragma.
9105 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
);
9106 -- Verify the placement of pragma Inline_Always with respect to the
9107 -- initial declaration of subprogram Spec_Id.
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 procedure Make_Inline
(Subp
: Entity_Id
);
9120 -- Subp is the defining unit name of the subprogram declaration. If
9121 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
9122 -- the corresponding body, if there is one present.
9124 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
9125 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
9126 -- Also set or clear Is_Inlined flag on Subp depending on Status.
9128 -----------------------------------
9129 -- Check_Inline_Always_Placement --
9130 -----------------------------------
9132 procedure Check_Inline_Always_Placement
(Spec_Id
: Entity_Id
) is
9133 Spec_Decl
: constant Node_Id
:= Unit_Declaration_Node
(Spec_Id
);
9135 function Compilation_Unit_OK
return Boolean;
9136 pragma Inline
(Compilation_Unit_OK
);
9137 -- Determine whether pragma Inline_Always applies to a compatible
9138 -- compilation unit denoted by Spec_Id.
9140 function Declarative_List_OK
return Boolean;
9141 pragma Inline
(Declarative_List_OK
);
9142 -- Determine whether the initial declaration of subprogram Spec_Id
9143 -- and the pragma appear in compatible declarative lists.
9145 function Subprogram_Body_OK
return Boolean;
9146 pragma Inline
(Subprogram_Body_OK
);
9147 -- Determine whether pragma Inline_Always applies to a compatible
9148 -- subprogram body denoted by Spec_Id.
9150 -------------------------
9151 -- Compilation_Unit_OK --
9152 -------------------------
9154 function Compilation_Unit_OK
return Boolean is
9155 Comp_Unit
: constant Node_Id
:= Parent
(Spec_Decl
);
9158 -- The pragma appears after the initial declaration of a
9159 -- compilation unit.
9161 -- procedure Comp_Unit;
9162 -- pragma Inline_Always (Comp_Unit);
9164 -- Note that for compatibility reasons, the following case is
9167 -- procedure Stand_Alone_Body_Comp_Unit is
9169 -- end Stand_Alone_Body_Comp_Unit;
9170 -- pragma Inline_Always (Stand_Alone_Body_Comp_Unit);
9173 Nkind
(Comp_Unit
) = N_Compilation_Unit
9174 and then Present
(Aux_Decls_Node
(Comp_Unit
))
9175 and then Is_List_Member
(N
)
9176 and then List_Containing
(N
) =
9177 Pragmas_After
(Aux_Decls_Node
(Comp_Unit
));
9178 end Compilation_Unit_OK
;
9180 -------------------------
9181 -- Declarative_List_OK --
9182 -------------------------
9184 function Declarative_List_OK
return Boolean is
9185 Context
: constant Node_Id
:= Parent
(Spec_Decl
);
9187 Init_Decl
: Node_Id
;
9188 Init_List
: List_Id
;
9189 Prag_List
: List_Id
;
9192 -- Determine the proper initial declaration. In general this is
9193 -- the declaration node of the subprogram except when the input
9194 -- denotes a generic instantiation.
9196 -- procedure Inst is new Gen;
9197 -- pragma Inline_Always (Inst);
9199 -- In this case the original subprogram is moved inside an
9200 -- anonymous package while pragma Inline_Always remains at the
9201 -- level of the anonymous package. Use the declaration of the
9202 -- package because it reflects the placement of the original
9205 -- package Anon_Pack is
9206 -- procedure Inst is ... end Inst; -- original
9209 -- procedure Inst renames Anon_Pack.Inst;
9210 -- pragma Inline_Always (Inst);
9212 if Is_Generic_Instance
(Spec_Id
) then
9213 Init_Decl
:= Parent
(Parent
(Spec_Decl
));
9214 pragma Assert
(Nkind
(Init_Decl
) = N_Package_Declaration
);
9216 Init_Decl
:= Spec_Decl
;
9219 if Is_List_Member
(Init_Decl
) and then Is_List_Member
(N
) then
9220 Init_List
:= List_Containing
(Init_Decl
);
9221 Prag_List
:= List_Containing
(N
);
9223 -- The pragma and then initial declaration appear within the
9224 -- same declarative list.
9226 if Init_List
= Prag_List
then
9229 -- A special case of the above is when both the pragma and
9230 -- the initial declaration appear in different lists of a
9231 -- package spec, protected definition, or a task definition.
9236 -- pragma Inline_Always (Proc);
9239 elsif Nkind_In
(Context
, N_Package_Specification
,
9240 N_Protected_Definition
,
9242 and then Init_List
= Visible_Declarations
(Context
)
9243 and then Prag_List
= Private_Declarations
(Context
)
9250 end Declarative_List_OK
;
9252 ------------------------
9253 -- Subprogram_Body_OK --
9254 ------------------------
9256 function Subprogram_Body_OK
return Boolean is
9257 Body_Decl
: Node_Id
;
9260 -- The pragma appears within the declarative list of a stand-
9261 -- alone subprogram body.
9263 -- procedure Stand_Alone_Body is
9264 -- pragma Inline_Always (Stand_Alone_Body);
9267 -- end Stand_Alone_Body;
9269 -- The compiler creates a dummy spec in this case, however the
9270 -- pragma remains within the declarative list of the body.
9272 if Nkind
(Spec_Decl
) = N_Subprogram_Declaration
9273 and then not Comes_From_Source
(Spec_Decl
)
9274 and then Present
(Corresponding_Body
(Spec_Decl
))
9277 Unit_Declaration_Node
(Corresponding_Body
(Spec_Decl
));
9279 if Present
(Declarations
(Body_Decl
))
9280 and then Is_List_Member
(N
)
9281 and then List_Containing
(N
) = Declarations
(Body_Decl
)
9288 end Subprogram_Body_OK
;
9290 -- Start of processing for Check_Inline_Always_Placement
9293 -- This check is relevant only for pragma Inline_Always
9295 if Pname
/= Name_Inline_Always
then
9298 -- Nothing to do when the pragma is internally generated on the
9299 -- assumption that it is properly placed.
9301 elsif not Comes_From_Source
(N
) then
9304 -- Nothing to do for internally generated subprograms that act
9305 -- as accidental homonyms of a source subprogram being inlined.
9307 elsif not Comes_From_Source
(Spec_Id
) then
9310 -- Nothing to do for generic formal subprograms that act as
9311 -- homonyms of another source subprogram being inlined.
9313 elsif Is_Formal_Subprogram
(Spec_Id
) then
9316 elsif Compilation_Unit_OK
9317 or else Declarative_List_OK
9318 or else Subprogram_Body_OK
9323 -- At this point it is known that the pragma applies to or appears
9324 -- within a completing body, a completing stub, or a subunit.
9326 Error_Msg_Name_1
:= Pname
;
9327 Error_Msg_Name_2
:= Chars
(Spec_Id
);
9328 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
9331 ("pragma % must appear on initial declaration of subprogram "
9332 & "% defined #", N
);
9333 end Check_Inline_Always_Placement
;
9335 ---------------------------
9336 -- Inlining_Not_Possible --
9337 ---------------------------
9339 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
9340 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
9344 if Nkind
(Decl
) = N_Subprogram_Body
then
9345 Stats
:= Handled_Statement_Sequence
(Decl
);
9346 return Present
(Exception_Handlers
(Stats
))
9347 or else Present
(At_End_Proc
(Stats
));
9349 elsif Nkind
(Decl
) = N_Subprogram_Declaration
9350 and then Present
(Corresponding_Body
(Decl
))
9352 if Analyzed
(Corresponding_Body
(Decl
)) then
9353 Error_Msg_N
("pragma appears too late, ignored??", N
);
9356 -- If the subprogram is a renaming as body, the body is just a
9357 -- call to the renamed subprogram, and inlining is trivially
9361 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
9362 N_Subprogram_Renaming_Declaration
9368 Handled_Statement_Sequence
9369 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
9372 Present
(Exception_Handlers
(Stats
))
9373 or else Present
(At_End_Proc
(Stats
));
9377 -- If body is not available, assume the best, the check is
9378 -- performed again when compiling enclosing package bodies.
9382 end Inlining_Not_Possible
;
9388 procedure Make_Inline
(Subp
: Entity_Id
) is
9389 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
9390 Inner_Subp
: Entity_Id
:= Subp
;
9393 -- Ignore if bad type, avoid cascaded error
9395 if Etype
(Subp
) = Any_Type
then
9399 -- If inlining is not possible, for now do not treat as an error
9401 elsif Status
/= Suppressed
9402 and then Front_End_Inlining
9403 and then Inlining_Not_Possible
(Subp
)
9408 -- Here we have a candidate for inlining, but we must exclude
9409 -- derived operations. Otherwise we would end up trying to inline
9410 -- a phantom declaration, and the result would be to drag in a
9411 -- body which has no direct inlining associated with it. That
9412 -- would not only be inefficient but would also result in the
9413 -- backend doing cross-unit inlining in cases where it was
9414 -- definitely inappropriate to do so.
9416 -- However, a simple Comes_From_Source test is insufficient, since
9417 -- we do want to allow inlining of generic instances which also do
9418 -- not come from source. We also need to recognize specs generated
9419 -- by the front-end for bodies that carry the pragma. Finally,
9420 -- predefined operators do not come from source but are not
9421 -- inlineable either.
9423 elsif Is_Generic_Instance
(Subp
)
9424 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
9428 elsif not Comes_From_Source
(Subp
)
9429 and then Scope
(Subp
) /= Standard_Standard
9435 -- The referenced entity must either be the enclosing entity, or
9436 -- an entity declared within the current open scope.
9438 if Present
(Scope
(Subp
))
9439 and then Scope
(Subp
) /= Current_Scope
9440 and then Subp
/= Current_Scope
9443 ("argument of% must be entity in current scope", Assoc
);
9447 -- Processing for procedure, operator or function. If subprogram
9448 -- is aliased (as for an instance) indicate that the renamed
9449 -- entity (if declared in the same unit) is inlined.
9450 -- If this is the anonymous subprogram created for a subprogram
9451 -- instance, the inlining applies to it directly. Otherwise we
9452 -- retrieve it as the alias of the visible subprogram instance.
9454 if Is_Subprogram
(Subp
) then
9456 -- Ensure that pragma Inline_Always is associated with the
9457 -- initial declaration of the subprogram.
9459 Check_Inline_Always_Placement
(Subp
);
9461 if Is_Wrapper_Package
(Scope
(Subp
)) then
9464 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9467 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9468 Set_Inline_Flags
(Inner_Subp
);
9470 Decl
:= Parent
(Parent
(Inner_Subp
));
9472 if Nkind
(Decl
) = N_Subprogram_Declaration
9473 and then Present
(Corresponding_Body
(Decl
))
9475 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9477 elsif Is_Generic_Instance
(Subp
)
9478 and then Comes_From_Source
(Subp
)
9480 -- Indicate that the body needs to be created for
9481 -- inlining subsequent calls. The instantiation node
9482 -- follows the declaration of the wrapper package
9483 -- created for it. The subprogram that requires the
9484 -- body is the anonymous one in the wrapper package.
9486 if Scope
(Subp
) /= Standard_Standard
9488 Need_Subprogram_Instance_Body
9489 (Next
(Unit_Declaration_Node
9490 (Scope
(Alias
(Subp
)))), Subp
)
9495 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9496 -- appear in a formal part to apply to a formal subprogram.
9497 -- Do not apply check within an instance or a formal package
9498 -- the test will have been applied to the original generic.
9500 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9501 and then List_Containing
(Decl
) = List_Containing
(N
)
9502 and then not In_Instance
9505 ("Inline cannot apply to a formal subprogram", N
);
9507 -- If Subp is a renaming, it is the renamed entity that
9508 -- will appear in any call, and be inlined. However, for
9509 -- ASIS uses it is convenient to indicate that the renaming
9510 -- itself is an inlined subprogram, so that some gnatcheck
9511 -- rules can be applied in the absence of expansion.
9513 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9514 Set_Inline_Flags
(Subp
);
9520 -- For a generic subprogram set flag as well, for use at the point
9521 -- of instantiation, to determine whether the body should be
9524 elsif Is_Generic_Subprogram
(Subp
) then
9525 Set_Inline_Flags
(Subp
);
9528 -- Literals are by definition inlined
9530 elsif Kind
= E_Enumeration_Literal
then
9533 -- Anything else is an error
9537 ("expect subprogram name for pragma%", Assoc
);
9541 ----------------------
9542 -- Set_Inline_Flags --
9543 ----------------------
9545 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9547 -- First set the Has_Pragma_XXX flags and issue the appropriate
9548 -- errors and warnings for suspicious combinations.
9550 if Prag_Id
= Pragma_No_Inline
then
9551 if Has_Pragma_Inline_Always
(Subp
) then
9553 ("Inline_Always and No_Inline are mutually exclusive", N
);
9554 elsif Has_Pragma_Inline
(Subp
) then
9556 ("Inline and No_Inline both specified for& ??",
9557 N
, Entity
(Subp_Id
));
9560 Set_Has_Pragma_No_Inline
(Subp
);
9562 if Prag_Id
= Pragma_Inline_Always
then
9563 if Has_Pragma_No_Inline
(Subp
) then
9565 ("Inline_Always and No_Inline are mutually exclusive",
9569 Set_Has_Pragma_Inline_Always
(Subp
);
9571 if Has_Pragma_No_Inline
(Subp
) then
9573 ("Inline and No_Inline both specified for& ??",
9574 N
, Entity
(Subp_Id
));
9578 Set_Has_Pragma_Inline
(Subp
);
9581 -- Then adjust the Is_Inlined flag. It can never be set if the
9582 -- subprogram is subject to pragma No_Inline.
9586 Set_Is_Inlined
(Subp
, False);
9592 if not Has_Pragma_No_Inline
(Subp
) then
9593 Set_Is_Inlined
(Subp
, True);
9597 -- A pragma that applies to a Ghost entity becomes Ghost for the
9598 -- purposes of legality checks and removal of ignored Ghost code.
9600 Mark_Ghost_Pragma
(N
, Subp
);
9602 -- Capture the entity of the first Ghost subprogram being
9603 -- processed for error detection purposes.
9605 if Is_Ghost_Entity
(Subp
) then
9606 if No
(Ghost_Id
) then
9610 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9611 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9613 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9614 Ghost_Error_Posted
:= True;
9616 Error_Msg_Name_1
:= Pname
;
9618 ("pragma % cannot mention ghost and non-ghost subprograms",
9621 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9622 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9624 Error_Msg_Sloc
:= Sloc
(Subp
);
9625 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9627 end Set_Inline_Flags
;
9629 -- Start of processing for Process_Inline
9632 Check_No_Identifiers
;
9633 Check_At_Least_N_Arguments
(1);
9635 if Status
= Enabled
then
9636 Inline_Processing_Required
:= True;
9640 while Present
(Assoc
) loop
9641 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9645 if Is_Entity_Name
(Subp_Id
) then
9646 Subp
:= Entity
(Subp_Id
);
9648 if Subp
= Any_Id
then
9650 -- If previous error, avoid cascaded errors
9652 Check_Error_Detected
;
9658 -- For the pragma case, climb homonym chain. This is
9659 -- what implements allowing the pragma in the renaming
9660 -- case, with the result applying to the ancestors, and
9661 -- also allows Inline to apply to all previous homonyms.
9663 if not From_Aspect_Specification
(N
) then
9664 while Present
(Homonym
(Subp
))
9665 and then Scope
(Homonym
(Subp
)) = Current_Scope
9667 Make_Inline
(Homonym
(Subp
));
9668 Subp
:= Homonym
(Subp
);
9675 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9681 -- If the context is a package declaration, the pragma indicates
9682 -- that inlining will require the presence of the corresponding
9683 -- body. (this may be further refined).
9686 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9687 N_Package_Declaration
9689 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9693 ----------------------------
9694 -- Process_Interface_Name --
9695 ----------------------------
9697 procedure Process_Interface_Name
9698 (Subprogram_Def
: Entity_Id
;
9705 String_Val
: String_Id
;
9707 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9708 -- SN is a string literal node for an interface name. This routine
9709 -- performs some minimal checks that the name is reasonable. In
9710 -- particular that no spaces or other obviously incorrect characters
9711 -- appear. This is only a warning, since any characters are allowed.
9713 ----------------------------------
9714 -- Check_Form_Of_Interface_Name --
9715 ----------------------------------
9717 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9718 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9719 SL
: constant Nat
:= String_Length
(S
);
9724 Error_Msg_N
("interface name cannot be null string", SN
);
9727 for J
in 1 .. SL
loop
9728 C
:= Get_String_Char
(S
, J
);
9730 -- Look for dubious character and issue unconditional warning.
9731 -- Definitely dubious if not in character range.
9733 if not In_Character_Range
(C
)
9735 -- Commas, spaces and (back)slashes are dubious
9737 or else Get_Character
(C
) = ','
9738 or else Get_Character
(C
) = '\'
9739 or else Get_Character
(C
) = ' '
9740 or else Get_Character
(C
) = '/'
9743 ("??interface name contains illegal character",
9744 Sloc
(SN
) + Source_Ptr
(J
));
9747 end Check_Form_Of_Interface_Name
;
9749 -- Start of processing for Process_Interface_Name
9752 -- If we are looking at a pragma that comes from an aspect then it
9753 -- needs to have its corresponding aspect argument expressions
9754 -- analyzed in addition to the generated pragma so that aspects
9755 -- within generic units get properly resolved.
9757 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9759 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9767 -- Obtain all interfacing aspects used to construct the pragma
9769 Get_Interfacing_Aspects
9770 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9772 -- Analyze the expression of aspect External_Name
9774 if Present
(EN
) then
9775 Analyze
(Expression
(EN
));
9778 -- Analyze the expressio of aspect Link_Name
9780 if Present
(LN
) then
9781 Analyze
(Expression
(LN
));
9786 if No
(Link_Arg
) then
9787 if No
(Ext_Arg
) then
9790 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9792 Link_Nam
:= Expression
(Ext_Arg
);
9795 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9796 Ext_Nam
:= Expression
(Ext_Arg
);
9801 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9802 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9803 Ext_Nam
:= Expression
(Ext_Arg
);
9804 Link_Nam
:= Expression
(Link_Arg
);
9807 -- Check expressions for external name and link name are static
9809 if Present
(Ext_Nam
) then
9810 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9811 Check_Form_Of_Interface_Name
(Ext_Nam
);
9813 -- Verify that external name is not the name of a local entity,
9814 -- which would hide the imported one and could lead to run-time
9815 -- surprises. The problem can only arise for entities declared in
9816 -- a package body (otherwise the external name is fully qualified
9817 -- and will not conflict).
9825 if Prag_Id
= Pragma_Import
then
9826 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
9827 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9829 if Nam
/= Chars
(Subprogram_Def
)
9830 and then Present
(E
)
9831 and then not Is_Overloadable
(E
)
9832 and then Is_Immediately_Visible
(E
)
9833 and then not Is_Imported
(E
)
9834 and then Ekind
(Scope
(E
)) = E_Package
9837 while Present
(Par
) loop
9838 if Nkind
(Par
) = N_Package_Body
then
9839 Error_Msg_Sloc
:= Sloc
(E
);
9841 ("imported entity is hidden by & declared#",
9846 Par
:= Parent
(Par
);
9853 if Present
(Link_Nam
) then
9854 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9855 Check_Form_Of_Interface_Name
(Link_Nam
);
9858 -- If there is no link name, just set the external name
9860 if No
(Link_Nam
) then
9861 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9863 -- For the Link_Name case, the given literal is preceded by an
9864 -- asterisk, which indicates to GCC that the given name should be
9865 -- taken literally, and in particular that no prepending of
9866 -- underlines should occur, even in systems where this is the
9871 Store_String_Char
(Get_Char_Code
('*'));
9872 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9873 Store_String_Chars
(String_Val
);
9875 Make_String_Literal
(Sloc
(Link_Nam
),
9876 Strval
=> End_String
);
9879 -- Set the interface name. If the entity is a generic instance, use
9880 -- its alias, which is the callable entity.
9882 if Is_Generic_Instance
(Subprogram_Def
) then
9883 Set_Encoded_Interface_Name
9884 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9886 Set_Encoded_Interface_Name
9887 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9890 Check_Duplicated_Export_Name
(Link_Nam
);
9891 end Process_Interface_Name
;
9893 -----------------------------------------
9894 -- Process_Interrupt_Or_Attach_Handler --
9895 -----------------------------------------
9897 procedure Process_Interrupt_Or_Attach_Handler
is
9898 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9899 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9902 -- A pragma that applies to a Ghost entity becomes Ghost for the
9903 -- purposes of legality checks and removal of ignored Ghost code.
9905 Mark_Ghost_Pragma
(N
, Handler
);
9906 Set_Is_Interrupt_Handler
(Handler
);
9908 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
9910 Record_Rep_Item
(Prot_Typ
, N
);
9912 -- Chain the pragma on the contract for completeness
9914 Add_Contract_Item
(N
, Handler
);
9915 end Process_Interrupt_Or_Attach_Handler
;
9917 --------------------------------------------------
9918 -- Process_Restrictions_Or_Restriction_Warnings --
9919 --------------------------------------------------
9921 -- Note: some of the simple identifier cases were handled in par-prag,
9922 -- but it is harmless (and more straightforward) to simply handle all
9923 -- cases here, even if it means we repeat a bit of work in some cases.
9925 procedure Process_Restrictions_Or_Restriction_Warnings
9929 R_Id
: Restriction_Id
;
9935 -- Ignore all Restrictions pragmas in CodePeer mode
9937 if CodePeer_Mode
then
9941 Check_Ada_83_Warning
;
9942 Check_At_Least_N_Arguments
(1);
9943 Check_Valid_Configuration_Pragma
;
9946 while Present
(Arg
) loop
9948 Expr
:= Get_Pragma_Arg
(Arg
);
9950 -- Case of no restriction identifier present
9952 if Id
= No_Name
then
9953 if Nkind
(Expr
) /= N_Identifier
then
9955 ("invalid form for restriction", Arg
);
9960 (Process_Restriction_Synonyms
(Expr
));
9962 if R_Id
not in All_Boolean_Restrictions
then
9963 Error_Msg_Name_1
:= Pname
;
9965 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9967 -- Check for possible misspelling
9969 for J
in Restriction_Id
loop
9971 Rnm
: constant String := Restriction_Id
'Image (J
);
9974 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9975 Name_Len
:= Rnm
'Length;
9976 Set_Casing
(All_Lower_Case
);
9978 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9981 (Source_Index
(Current_Sem_Unit
)));
9982 Error_Msg_String
(1 .. Rnm
'Length) :=
9983 Name_Buffer
(1 .. Name_Len
);
9984 Error_Msg_Strlen
:= Rnm
'Length;
9985 Error_Msg_N
-- CODEFIX
9986 ("\possible misspelling of ""~""",
9987 Get_Pragma_Arg
(Arg
));
9996 if Implementation_Restriction
(R_Id
) then
9997 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
10000 -- Special processing for No_Elaboration_Code restriction
10002 if R_Id
= No_Elaboration_Code
then
10004 -- Restriction is only recognized within a configuration
10005 -- pragma file, or within a unit of the main extended
10006 -- program. Note: the test for Main_Unit is needed to
10007 -- properly include the case of configuration pragma files.
10009 if not (Current_Sem_Unit
= Main_Unit
10010 or else In_Extended_Main_Source_Unit
(N
))
10014 -- Don't allow in a subunit unless already specified in
10017 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
10018 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
10019 and then not Restriction_Active
(No_Elaboration_Code
)
10022 ("invalid specification of ""No_Elaboration_Code""",
10025 ("\restriction cannot be specified in a subunit", N
);
10027 ("\unless also specified in body or spec", N
);
10030 -- If we accept a No_Elaboration_Code restriction, then it
10031 -- needs to be added to the configuration restriction set so
10032 -- that we get proper application to other units in the main
10033 -- extended source as required.
10036 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
10040 -- If this is a warning, then set the warning unless we already
10041 -- have a real restriction active (we never want a warning to
10042 -- override a real restriction).
10045 if not Restriction_Active
(R_Id
) then
10046 Set_Restriction
(R_Id
, N
);
10047 Restriction_Warnings
(R_Id
) := True;
10050 -- If real restriction case, then set it and make sure that the
10051 -- restriction warning flag is off, since a real restriction
10052 -- always overrides a warning.
10055 Set_Restriction
(R_Id
, N
);
10056 Restriction_Warnings
(R_Id
) := False;
10059 -- Check for obsolescent restrictions in Ada 2005 mode
10062 and then Ada_Version
>= Ada_2005
10063 and then (R_Id
= No_Asynchronous_Control
10065 R_Id
= No_Unchecked_Deallocation
10067 R_Id
= No_Unchecked_Conversion
)
10069 Check_Restriction
(No_Obsolescent_Features
, N
);
10072 -- A very special case that must be processed here: pragma
10073 -- Restrictions (No_Exceptions) turns off all run-time
10074 -- checking. This is a bit dubious in terms of the formal
10075 -- language definition, but it is what is intended by RM
10076 -- H.4(12). Restriction_Warnings never affects generated code
10077 -- so this is done only in the real restriction case.
10079 -- Atomic_Synchronization is not a real check, so it is not
10080 -- affected by this processing).
10082 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
10083 -- run-time checks in CodePeer and GNATprove modes: we want to
10084 -- generate checks for analysis purposes, as set respectively
10085 -- by -gnatC and -gnatd.F
10088 and then not (CodePeer_Mode
or GNATprove_Mode
)
10089 and then R_Id
= No_Exceptions
10091 for J
in Scope_Suppress
.Suppress
'Range loop
10092 if J
/= Atomic_Synchronization
then
10093 Scope_Suppress
.Suppress
(J
) := True;
10098 -- Case of No_Dependence => unit-name. Note that the parser
10099 -- already made the necessary entry in the No_Dependence table.
10101 elsif Id
= Name_No_Dependence
then
10102 if not OK_No_Dependence_Unit_Name
(Expr
) then
10106 -- Case of No_Specification_Of_Aspect => aspect-identifier
10108 elsif Id
= Name_No_Specification_Of_Aspect
then
10113 if Nkind
(Expr
) /= N_Identifier
then
10116 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
10119 if A_Id
= No_Aspect
then
10120 Error_Pragma_Arg
("invalid restriction name", Arg
);
10122 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
10126 -- Case of No_Use_Of_Attribute => attribute-identifier
10128 elsif Id
= Name_No_Use_Of_Attribute
then
10129 if Nkind
(Expr
) /= N_Identifier
10130 or else not Is_Attribute_Name
(Chars
(Expr
))
10132 Error_Msg_N
("unknown attribute name??", Expr
);
10135 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
10138 -- Case of No_Use_Of_Entity => fully-qualified-name
10140 elsif Id
= Name_No_Use_Of_Entity
then
10142 -- Restriction is only recognized within a configuration
10143 -- pragma file, or within a unit of the main extended
10144 -- program. Note: the test for Main_Unit is needed to
10145 -- properly include the case of configuration pragma files.
10147 if Current_Sem_Unit
= Main_Unit
10148 or else In_Extended_Main_Source_Unit
(N
)
10150 if not OK_No_Dependence_Unit_Name
(Expr
) then
10151 Error_Msg_N
("wrong form for entity name", Expr
);
10153 Set_Restriction_No_Use_Of_Entity
10154 (Expr
, Warn
, No_Profile
);
10158 -- Case of No_Use_Of_Pragma => pragma-identifier
10160 elsif Id
= Name_No_Use_Of_Pragma
then
10161 if Nkind
(Expr
) /= N_Identifier
10162 or else not Is_Pragma_Name
(Chars
(Expr
))
10164 Error_Msg_N
("unknown pragma name??", Expr
);
10166 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
10169 -- All other cases of restriction identifier present
10172 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
10173 Analyze_And_Resolve
(Expr
, Any_Integer
);
10175 if R_Id
not in All_Parameter_Restrictions
then
10177 ("invalid restriction parameter identifier", Arg
);
10179 elsif not Is_OK_Static_Expression
(Expr
) then
10180 Flag_Non_Static_Expr
10181 ("value must be static expression!", Expr
);
10184 elsif not Is_Integer_Type
(Etype
(Expr
))
10185 or else Expr_Value
(Expr
) < 0
10188 ("value must be non-negative integer", Arg
);
10191 -- Restriction pragma is active
10193 Val
:= Expr_Value
(Expr
);
10195 if not UI_Is_In_Int_Range
(Val
) then
10197 ("pragma ignored, value too large??", Arg
);
10200 -- Warning case. If the real restriction is active, then we
10201 -- ignore the request, since warning never overrides a real
10202 -- restriction. Otherwise we set the proper warning. Note that
10203 -- this circuit sets the warning again if it is already set,
10204 -- which is what we want, since the constant may have changed.
10207 if not Restriction_Active
(R_Id
) then
10209 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
10210 Restriction_Warnings
(R_Id
) := True;
10213 -- Real restriction case, set restriction and make sure warning
10214 -- flag is off since real restriction always overrides warning.
10217 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
10218 Restriction_Warnings
(R_Id
) := False;
10224 end Process_Restrictions_Or_Restriction_Warnings
;
10226 ---------------------------------
10227 -- Process_Suppress_Unsuppress --
10228 ---------------------------------
10230 -- Note: this procedure makes entries in the check suppress data
10231 -- structures managed by Sem. See spec of package Sem for full
10232 -- details on how we handle recording of check suppression.
10234 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
10239 In_Package_Spec
: constant Boolean :=
10240 Is_Package_Or_Generic_Package
(Current_Scope
)
10241 and then not In_Package_Body
(Current_Scope
);
10243 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
10244 -- Used to suppress a single check on the given entity
10246 --------------------------------
10247 -- Suppress_Unsuppress_Echeck --
10248 --------------------------------
10250 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
10252 -- Check for error of trying to set atomic synchronization for
10253 -- a non-atomic variable.
10255 if C
= Atomic_Synchronization
10256 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
10259 ("pragma & requires atomic type or variable",
10260 Pragma_Identifier
(Original_Node
(N
)));
10263 Set_Checks_May_Be_Suppressed
(E
);
10265 if In_Package_Spec
then
10266 Push_Global_Suppress_Stack_Entry
10269 Suppress
=> Suppress_Case
);
10271 Push_Local_Suppress_Stack_Entry
10274 Suppress
=> Suppress_Case
);
10277 -- If this is a first subtype, and the base type is distinct,
10278 -- then also set the suppress flags on the base type.
10280 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
10281 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
10283 end Suppress_Unsuppress_Echeck
;
10285 -- Start of processing for Process_Suppress_Unsuppress
10288 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
10289 -- on user code: we want to generate checks for analysis purposes, as
10290 -- set respectively by -gnatC and -gnatd.F
10292 if Comes_From_Source
(N
)
10293 and then (CodePeer_Mode
or GNATprove_Mode
)
10298 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
10299 -- declarative part or a package spec (RM 11.5(5)).
10301 if not Is_Configuration_Pragma
then
10302 Check_Is_In_Decl_Part_Or_Package_Spec
;
10305 Check_At_Least_N_Arguments
(1);
10306 Check_At_Most_N_Arguments
(2);
10307 Check_No_Identifier
(Arg1
);
10308 Check_Arg_Is_Identifier
(Arg1
);
10310 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
10312 if C
= No_Check_Id
then
10314 ("argument of pragma% is not valid check name", Arg1
);
10317 -- Warn that suppress of Elaboration_Check has no effect in SPARK
10319 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
10321 ("Suppress of Elaboration_Check ignored in SPARK??",
10322 "\elaboration checking rules are statically enforced "
10323 & "(SPARK RM 7.7)", Arg1
);
10326 -- One-argument case
10328 if Arg_Count
= 1 then
10330 -- Make an entry in the local scope suppress table. This is the
10331 -- table that directly shows the current value of the scope
10332 -- suppress check for any check id value.
10334 if C
= All_Checks
then
10336 -- For All_Checks, we set all specific predefined checks with
10337 -- the exception of Elaboration_Check, which is handled
10338 -- specially because of not wanting All_Checks to have the
10339 -- effect of deactivating static elaboration order processing.
10340 -- Atomic_Synchronization is also not affected, since this is
10341 -- not a real check.
10343 for J
in Scope_Suppress
.Suppress
'Range loop
10344 if J
/= Elaboration_Check
10346 J
/= Atomic_Synchronization
10348 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
10352 -- If not All_Checks, and predefined check, then set appropriate
10353 -- scope entry. Note that we will set Elaboration_Check if this
10354 -- is explicitly specified. Atomic_Synchronization is allowed
10355 -- only if internally generated and entity is atomic.
10357 elsif C
in Predefined_Check_Id
10358 and then (not Comes_From_Source
(N
)
10359 or else C
/= Atomic_Synchronization
)
10361 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
10364 -- Also make an entry in the Local_Entity_Suppress table
10366 Push_Local_Suppress_Stack_Entry
10369 Suppress
=> Suppress_Case
);
10371 -- Case of two arguments present, where the check is suppressed for
10372 -- a specified entity (given as the second argument of the pragma)
10375 -- This is obsolescent in Ada 2005 mode
10377 if Ada_Version
>= Ada_2005
then
10378 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
10381 Check_Optional_Identifier
(Arg2
, Name_On
);
10382 E_Id
:= Get_Pragma_Arg
(Arg2
);
10385 if not Is_Entity_Name
(E_Id
) then
10387 ("second argument of pragma% must be entity name", Arg2
);
10390 E
:= Entity
(E_Id
);
10396 -- A pragma that applies to a Ghost entity becomes Ghost for the
10397 -- purposes of legality checks and removal of ignored Ghost code.
10399 Mark_Ghost_Pragma
(N
, E
);
10401 -- Enforce RM 11.5(7) which requires that for a pragma that
10402 -- appears within a package spec, the named entity must be
10403 -- within the package spec. We allow the package name itself
10404 -- to be mentioned since that makes sense, although it is not
10405 -- strictly allowed by 11.5(7).
10408 and then E
/= Current_Scope
10409 and then Scope
(E
) /= Current_Scope
10412 ("entity in pragma% is not in package spec (RM 11.5(7))",
10416 -- Loop through homonyms. As noted below, in the case of a package
10417 -- spec, only homonyms within the package spec are considered.
10420 Suppress_Unsuppress_Echeck
(E
, C
);
10422 if Is_Generic_Instance
(E
)
10423 and then Is_Subprogram
(E
)
10424 and then Present
(Alias
(E
))
10426 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
10429 -- Move to next homonym if not aspect spec case
10431 exit when From_Aspect_Specification
(N
);
10435 -- If we are within a package specification, the pragma only
10436 -- applies to homonyms in the same scope.
10438 exit when In_Package_Spec
10439 and then Scope
(E
) /= Current_Scope
;
10442 end Process_Suppress_Unsuppress
;
10444 -------------------------------
10445 -- Record_Independence_Check --
10446 -------------------------------
10448 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10449 pragma Unreferenced
(N
, E
);
10451 -- For GCC back ends the validation is done a priori
10452 -- ??? This code is dead, might be useful in the future
10454 -- if not AAMP_On_Target then
10458 -- Independence_Checks.Append ((N, E));
10461 end Record_Independence_Check
;
10467 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10469 if Is_Imported
(E
) then
10471 ("cannot export entity& that was previously imported", Arg
);
10473 elsif Present
(Address_Clause
(E
))
10474 and then not Relaxed_RM_Semantics
10477 ("cannot export entity& that has an address clause", Arg
);
10480 Set_Is_Exported
(E
);
10482 -- Generate a reference for entity explicitly, because the
10483 -- identifier may be overloaded and name resolution will not
10486 Generate_Reference
(E
, Arg
);
10488 -- Deal with exporting non-library level entity
10490 if not Is_Library_Level_Entity
(E
) then
10492 -- Not allowed at all for subprograms
10494 if Is_Subprogram
(E
) then
10495 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10497 -- Otherwise set public and statically allocated
10501 Set_Is_Statically_Allocated
(E
);
10503 -- Warn if the corresponding W flag is set
10505 if Warn_On_Export_Import
10507 -- Only do this for something that was in the source. Not
10508 -- clear if this can be False now (there used for sure to be
10509 -- cases on some systems where it was False), but anyway the
10510 -- test is harmless if not needed, so it is retained.
10512 and then Comes_From_Source
(Arg
)
10515 ("?x?& has been made static as a result of Export",
10518 ("\?x?this usage is non-standard and non-portable",
10524 if Warn_On_Export_Import
and then Is_Type
(E
) then
10525 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10528 if Warn_On_Export_Import
and Inside_A_Generic
then
10530 ("all instances of& will have the same external name?x?",
10535 ----------------------------------------------
10536 -- Set_Extended_Import_Export_External_Name --
10537 ----------------------------------------------
10539 procedure Set_Extended_Import_Export_External_Name
10540 (Internal_Ent
: Entity_Id
;
10541 Arg_External
: Node_Id
)
10543 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10544 New_Name
: Node_Id
;
10547 if No
(Arg_External
) then
10551 Check_Arg_Is_External_Name
(Arg_External
);
10553 if Nkind
(Arg_External
) = N_String_Literal
then
10554 if String_Length
(Strval
(Arg_External
)) = 0 then
10557 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10560 elsif Nkind
(Arg_External
) = N_Identifier
then
10561 New_Name
:= Get_Default_External_Name
(Arg_External
);
10563 -- Check_Arg_Is_External_Name should let through only identifiers and
10564 -- string literals or static string expressions (which are folded to
10565 -- string literals).
10568 raise Program_Error
;
10571 -- If we already have an external name set (by a prior normal Import
10572 -- or Export pragma), then the external names must match
10574 if Present
(Interface_Name
(Internal_Ent
)) then
10576 -- Ignore mismatching names in CodePeer mode, to support some
10577 -- old compilers which would export the same procedure under
10578 -- different names, e.g:
10580 -- pragma Export_Procedure (P, "a");
10581 -- pragma Export_Procedure (P, "b");
10583 if CodePeer_Mode
then
10587 Check_Matching_Internal_Names
: declare
10588 S1
: constant String_Id
:= Strval
(Old_Name
);
10589 S2
: constant String_Id
:= Strval
(New_Name
);
10591 procedure Mismatch
;
10592 pragma No_Return
(Mismatch
);
10593 -- Called if names do not match
10599 procedure Mismatch
is
10601 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10603 ("external name does not match that given #",
10607 -- Start of processing for Check_Matching_Internal_Names
10610 if String_Length
(S1
) /= String_Length
(S2
) then
10614 for J
in 1 .. String_Length
(S1
) loop
10615 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10620 end Check_Matching_Internal_Names
;
10622 -- Otherwise set the given name
10625 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10626 Check_Duplicated_Export_Name
(New_Name
);
10628 end Set_Extended_Import_Export_External_Name
;
10634 procedure Set_Imported
(E
: Entity_Id
) is
10636 -- Error message if already imported or exported
10638 if Is_Exported
(E
) or else Is_Imported
(E
) then
10640 -- Error if being set Exported twice
10642 if Is_Exported
(E
) then
10643 Error_Msg_NE
("entity& was previously exported", N
, E
);
10645 -- Ignore error in CodePeer mode where we treat all imported
10646 -- subprograms as unknown.
10648 elsif CodePeer_Mode
then
10651 -- OK if Import/Interface case
10653 elsif Import_Interface_Present
(N
) then
10656 -- Error if being set Imported twice
10659 Error_Msg_NE
("entity& was previously imported", N
, E
);
10662 Error_Msg_Name_1
:= Pname
;
10664 ("\(pragma% applies to all previous entities)", N
);
10666 Error_Msg_Sloc
:= Sloc
(E
);
10667 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10669 -- Here if not previously imported or exported, OK to import
10672 Set_Is_Imported
(E
);
10674 -- For subprogram, set Import_Pragma field
10676 if Is_Subprogram
(E
) then
10677 Set_Import_Pragma
(E
, N
);
10680 -- If the entity is an object that is not at the library level,
10681 -- then it is statically allocated. We do not worry about objects
10682 -- with address clauses in this context since they are not really
10683 -- imported in the linker sense.
10686 and then not Is_Library_Level_Entity
(E
)
10687 and then No
(Address_Clause
(E
))
10689 Set_Is_Statically_Allocated
(E
);
10696 -------------------------
10697 -- Set_Mechanism_Value --
10698 -------------------------
10700 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10701 -- analyzed, since it is semantic nonsense), so we get it in the exact
10702 -- form created by the parser.
10704 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10705 procedure Bad_Mechanism
;
10706 pragma No_Return
(Bad_Mechanism
);
10707 -- Signal bad mechanism name
10709 -------------------------
10710 -- Bad_Mechanism_Value --
10711 -------------------------
10713 procedure Bad_Mechanism
is
10715 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10718 -- Start of processing for Set_Mechanism_Value
10721 if Mechanism
(Ent
) /= Default_Mechanism
then
10723 ("mechanism for & has already been set", Mech_Name
, Ent
);
10726 -- MECHANISM_NAME ::= value | reference
10728 if Nkind
(Mech_Name
) = N_Identifier
then
10729 if Chars
(Mech_Name
) = Name_Value
then
10730 Set_Mechanism
(Ent
, By_Copy
);
10733 elsif Chars
(Mech_Name
) = Name_Reference
then
10734 Set_Mechanism
(Ent
, By_Reference
);
10737 elsif Chars
(Mech_Name
) = Name_Copy
then
10739 ("bad mechanism name, Value assumed", Mech_Name
);
10748 end Set_Mechanism_Value
;
10750 --------------------------
10751 -- Set_Rational_Profile --
10752 --------------------------
10754 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10755 -- extension to the semantics of renaming declarations.
10757 procedure Set_Rational_Profile
is
10759 Implicit_Packing
:= True;
10760 Overriding_Renamings
:= True;
10761 Use_VADS_Size
:= True;
10762 end Set_Rational_Profile
;
10764 ---------------------------
10765 -- Set_Ravenscar_Profile --
10766 ---------------------------
10768 -- The tasks to be done here are
10770 -- Set required policies
10772 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10773 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10774 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10775 -- (For GNAT_Ravenscar_EDF profile)
10776 -- pragma Locking_Policy (Ceiling_Locking)
10778 -- Set Detect_Blocking mode
10780 -- Set required restrictions (see System.Rident for detailed list)
10782 -- Set the No_Dependence rules
10783 -- No_Dependence => Ada.Asynchronous_Task_Control
10784 -- No_Dependence => Ada.Calendar
10785 -- No_Dependence => Ada.Execution_Time.Group_Budget
10786 -- No_Dependence => Ada.Execution_Time.Timers
10787 -- No_Dependence => Ada.Task_Attributes
10788 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10790 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10791 procedure Set_Error_Msg_To_Profile_Name
;
10792 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10795 -----------------------------------
10796 -- Set_Error_Msg_To_Profile_Name --
10797 -----------------------------------
10799 procedure Set_Error_Msg_To_Profile_Name
is
10800 Prof_Nam
: constant Node_Id
:=
10802 (First
(Pragma_Argument_Associations
(N
)));
10805 Get_Name_String
(Chars
(Prof_Nam
));
10806 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10807 Error_Msg_Strlen
:= Name_Len
;
10808 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10809 end Set_Error_Msg_To_Profile_Name
;
10818 Profile_Dispatching_Policy
: Character;
10820 -- Start of processing for Set_Ravenscar_Profile
10823 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10825 if Profile
= GNAT_Ravenscar_EDF
then
10826 Profile_Dispatching_Policy
:= 'E';
10828 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10831 Profile_Dispatching_Policy
:= 'F';
10834 if Task_Dispatching_Policy
/= ' '
10835 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
10837 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10838 Set_Error_Msg_To_Profile_Name
;
10839 Error_Pragma
("Profile (~) incompatible with policy#");
10841 -- Set the FIFO_Within_Priorities policy, but always preserve
10842 -- System_Location since we like the error message with the run time
10846 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
10848 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10849 Task_Dispatching_Policy_Sloc
:= Loc
;
10853 -- pragma Locking_Policy (Ceiling_Locking)
10855 if Locking_Policy
/= ' '
10856 and then Locking_Policy
/= 'C'
10858 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10859 Set_Error_Msg_To_Profile_Name
;
10860 Error_Pragma
("Profile (~) incompatible with policy#");
10862 -- Set the Ceiling_Locking policy, but preserve System_Location since
10863 -- we like the error message with the run time name.
10866 Locking_Policy
:= 'C';
10868 if Locking_Policy_Sloc
/= System_Location
then
10869 Locking_Policy_Sloc
:= Loc
;
10873 -- pragma Detect_Blocking
10875 Detect_Blocking
:= True;
10877 -- Set the corresponding restrictions
10879 Set_Profile_Restrictions
10880 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10882 -- Set the No_Dependence restrictions
10884 -- The following No_Dependence restrictions:
10885 -- No_Dependence => Ada.Asynchronous_Task_Control
10886 -- No_Dependence => Ada.Calendar
10887 -- No_Dependence => Ada.Task_Attributes
10888 -- are already set by previous call to Set_Profile_Restrictions.
10890 -- Set the following restrictions which were added to Ada 2005:
10891 -- No_Dependence => Ada.Execution_Time.Group_Budget
10892 -- No_Dependence => Ada.Execution_Time.Timers
10894 if Ada_Version
>= Ada_2005
then
10895 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
10896 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
10899 Make_Selected_Component
10902 Selector_Name
=> Sel_Id
);
10904 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
10907 Make_Selected_Component
10910 Selector_Name
=> Sel_Id
);
10912 Set_Restriction_No_Dependence
10914 Warn
=> Treat_Restrictions_As_Warnings
,
10915 Profile
=> Ravenscar
);
10917 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
10920 Make_Selected_Component
10923 Selector_Name
=> Sel_Id
);
10925 Set_Restriction_No_Dependence
10927 Warn
=> Treat_Restrictions_As_Warnings
,
10928 Profile
=> Ravenscar
);
10931 -- Set the following restriction which was added to Ada 2012 (see
10933 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10935 if Ada_Version
>= Ada_2012
then
10936 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
10937 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
10940 Make_Selected_Component
10943 Selector_Name
=> Sel_Id
);
10945 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
10948 Make_Selected_Component
10951 Selector_Name
=> Sel_Id
);
10953 Set_Restriction_No_Dependence
10955 Warn
=> Treat_Restrictions_As_Warnings
,
10956 Profile
=> Ravenscar
);
10958 end Set_Ravenscar_Profile
;
10960 -- Start of processing for Analyze_Pragma
10963 -- The following code is a defense against recursion. Not clear that
10964 -- this can happen legitimately, but perhaps some error situations can
10965 -- cause it, and we did see this recursion during testing.
10967 if Analyzed
(N
) then
10973 Check_Restriction_No_Use_Of_Pragma
(N
);
10975 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10976 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10978 if Should_Ignore_Pragma_Sem
(N
)
10979 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
10980 and then Ignore_Rep_Clauses
)
10985 -- Deal with unrecognized pragma
10987 if not Is_Pragma_Name
(Pname
) then
10988 if Warn_On_Unrecognized_Pragma
then
10989 Error_Msg_Name_1
:= Pname
;
10990 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10992 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10993 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10994 Error_Msg_Name_1
:= PN
;
10995 Error_Msg_N
-- CODEFIX
10996 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
11005 -- Here to start processing for recognized pragma
11007 Pname
:= Original_Aspect_Pragma_Name
(N
);
11009 -- Capture setting of Opt.Uneval_Old
11011 case Opt
.Uneval_Old
is
11013 Set_Uneval_Old_Accept
(N
);
11019 Set_Uneval_Old_Warn
(N
);
11022 raise Program_Error
;
11025 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
11026 -- is already set, indicating that we have already checked the policy
11027 -- at the right point. This happens for example in the case of a pragma
11028 -- that is derived from an Aspect.
11030 if Is_Ignored
(N
) or else Is_Checked
(N
) then
11033 -- For a pragma that is a rewriting of another pragma, copy the
11034 -- Is_Checked/Is_Ignored status from the rewritten pragma.
11036 elsif Is_Rewrite_Substitution
(N
)
11037 and then Nkind
(Original_Node
(N
)) = N_Pragma
11038 and then Original_Node
(N
) /= N
11040 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
11041 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
11043 -- Otherwise query the applicable policy at this point
11046 Check_Applicable_Policy
(N
);
11048 -- If pragma is disabled, rewrite as NULL and skip analysis
11050 if Is_Disabled
(N
) then
11051 Rewrite
(N
, Make_Null_Statement
(Loc
));
11057 -- Preset arguments
11065 if Present
(Pragma_Argument_Associations
(N
)) then
11066 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
11067 Arg1
:= First
(Pragma_Argument_Associations
(N
));
11069 if Present
(Arg1
) then
11070 Arg2
:= Next
(Arg1
);
11072 if Present
(Arg2
) then
11073 Arg3
:= Next
(Arg2
);
11075 if Present
(Arg3
) then
11076 Arg4
:= Next
(Arg3
);
11082 -- An enumeration type defines the pragmas that are supported by the
11083 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
11084 -- into the corresponding enumeration value for the following case.
11092 -- pragma Abort_Defer;
11094 when Pragma_Abort_Defer
=>
11096 Check_Arg_Count
(0);
11098 -- The only required semantic processing is to check the
11099 -- placement. This pragma must appear at the start of the
11100 -- statement sequence of a handled sequence of statements.
11102 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
11103 or else N
/= First
(Statements
(Parent
(N
)))
11108 --------------------
11109 -- Abstract_State --
11110 --------------------
11112 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
11114 -- ABSTRACT_STATE_LIST ::=
11116 -- | STATE_NAME_WITH_OPTIONS
11117 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
11119 -- STATE_NAME_WITH_OPTIONS ::=
11121 -- | (STATE_NAME with OPTION_LIST)
11123 -- OPTION_LIST ::= OPTION {, OPTION}
11127 -- | NAME_VALUE_OPTION
11129 -- SIMPLE_OPTION ::= Ghost | Synchronous
11131 -- NAME_VALUE_OPTION ::=
11132 -- Part_Of => ABSTRACT_STATE
11133 -- | External [=> EXTERNAL_PROPERTY_LIST]
11135 -- EXTERNAL_PROPERTY_LIST ::=
11136 -- EXTERNAL_PROPERTY
11137 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
11139 -- EXTERNAL_PROPERTY ::=
11140 -- Async_Readers [=> boolean_EXPRESSION]
11141 -- | Async_Writers [=> boolean_EXPRESSION]
11142 -- | Effective_Reads [=> boolean_EXPRESSION]
11143 -- | Effective_Writes [=> boolean_EXPRESSION]
11144 -- others => boolean_EXPRESSION
11146 -- STATE_NAME ::= defining_identifier
11148 -- ABSTRACT_STATE ::= name
11150 -- Characteristics:
11152 -- * Analysis - The annotation is fully analyzed immediately upon
11153 -- elaboration as it cannot forward reference entities.
11155 -- * Expansion - None.
11157 -- * Template - The annotation utilizes the generic template of the
11158 -- related package declaration.
11160 -- * Globals - The annotation cannot reference global entities.
11162 -- * Instance - The annotation is instantiated automatically when
11163 -- the related generic package is instantiated.
11165 when Pragma_Abstract_State
=> Abstract_State
: declare
11166 Missing_Parentheses
: Boolean := False;
11167 -- Flag set when a state declaration with options is not properly
11170 -- Flags used to verify the consistency of states
11172 Non_Null_Seen
: Boolean := False;
11173 Null_Seen
: Boolean := False;
11175 procedure Analyze_Abstract_State
11177 Pack_Id
: Entity_Id
);
11178 -- Verify the legality of a single state declaration. Create and
11179 -- decorate a state abstraction entity and introduce it into the
11180 -- visibility chain. Pack_Id denotes the entity or the related
11181 -- package where pragma Abstract_State appears.
11183 procedure Malformed_State_Error
(State
: Node_Id
);
11184 -- Emit an error concerning the illegal declaration of abstract
11185 -- state State. This routine diagnoses syntax errors that lead to
11186 -- a different parse tree. The error is issued regardless of the
11187 -- SPARK mode in effect.
11189 ----------------------------
11190 -- Analyze_Abstract_State --
11191 ----------------------------
11193 procedure Analyze_Abstract_State
11195 Pack_Id
: Entity_Id
)
11197 -- Flags used to verify the consistency of options
11199 AR_Seen
: Boolean := False;
11200 AW_Seen
: Boolean := False;
11201 ER_Seen
: Boolean := False;
11202 EW_Seen
: Boolean := False;
11203 External_Seen
: Boolean := False;
11204 Ghost_Seen
: Boolean := False;
11205 Others_Seen
: Boolean := False;
11206 Part_Of_Seen
: Boolean := False;
11207 Synchronous_Seen
: Boolean := False;
11209 -- Flags used to store the static value of all external states'
11212 AR_Val
: Boolean := False;
11213 AW_Val
: Boolean := False;
11214 ER_Val
: Boolean := False;
11215 EW_Val
: Boolean := False;
11217 State_Id
: Entity_Id
:= Empty
;
11218 -- The entity to be generated for the current state declaration
11220 procedure Analyze_External_Option
(Opt
: Node_Id
);
11221 -- Verify the legality of option External
11223 procedure Analyze_External_Property
11225 Expr
: Node_Id
:= Empty
);
11226 -- Verify the legailty of a single external property. Prop
11227 -- denotes the external property. Expr is the expression used
11228 -- to set the property.
11230 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
11231 -- Verify the legality of option Part_Of
11233 procedure Check_Duplicate_Option
11235 Status
: in out Boolean);
11236 -- Flag Status denotes whether a particular option has been
11237 -- seen while processing a state. This routine verifies that
11238 -- Opt is not a duplicate option and sets the flag Status
11239 -- (SPARK RM 7.1.4(1)).
11241 procedure Check_Duplicate_Property
11243 Status
: in out Boolean);
11244 -- Flag Status denotes whether a particular property has been
11245 -- seen while processing option External. This routine verifies
11246 -- that Prop is not a duplicate property and sets flag Status.
11247 -- Opt is not a duplicate property and sets the flag Status.
11248 -- (SPARK RM 7.1.4(2))
11250 procedure Check_Ghost_Synchronous
;
11251 -- Ensure that the abstract state is not subject to both Ghost
11252 -- and Synchronous simple options. Emit an error if this is the
11255 procedure Create_Abstract_State
11259 Is_Null
: Boolean);
11260 -- Generate an abstract state entity with name Nam and enter it
11261 -- into visibility. Decl is the "declaration" of the state as
11262 -- it appears in pragma Abstract_State. Loc is the location of
11263 -- the related state "declaration". Flag Is_Null should be set
11264 -- when the associated Abstract_State pragma defines a null
11267 -----------------------------
11268 -- Analyze_External_Option --
11269 -----------------------------
11271 procedure Analyze_External_Option
(Opt
: Node_Id
) is
11272 Errors
: constant Nat
:= Serious_Errors_Detected
;
11274 Props
: Node_Id
:= Empty
;
11277 if Nkind
(Opt
) = N_Component_Association
then
11278 Props
:= Expression
(Opt
);
11281 -- External state with properties
11283 if Present
(Props
) then
11285 -- Multiple properties appear as an aggregate
11287 if Nkind
(Props
) = N_Aggregate
then
11289 -- Simple property form
11291 Prop
:= First
(Expressions
(Props
));
11292 while Present
(Prop
) loop
11293 Analyze_External_Property
(Prop
);
11297 -- Property with expression form
11299 Prop
:= First
(Component_Associations
(Props
));
11300 while Present
(Prop
) loop
11301 Analyze_External_Property
11302 (Prop
=> First
(Choices
(Prop
)),
11303 Expr
=> Expression
(Prop
));
11311 Analyze_External_Property
(Props
);
11314 -- An external state defined without any properties defaults
11315 -- all properties to True.
11324 -- Once all external properties have been processed, verify
11325 -- their mutual interaction. Do not perform the check when
11326 -- at least one of the properties is illegal as this will
11327 -- produce a bogus error.
11329 if Errors
= Serious_Errors_Detected
then
11330 Check_External_Properties
11331 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
11333 end Analyze_External_Option
;
11335 -------------------------------
11336 -- Analyze_External_Property --
11337 -------------------------------
11339 procedure Analyze_External_Property
11341 Expr
: Node_Id
:= Empty
)
11343 Expr_Val
: Boolean;
11346 -- Check the placement of "others" (if available)
11348 if Nkind
(Prop
) = N_Others_Choice
then
11349 if Others_Seen
then
11351 ("only one others choice allowed in option External",
11354 Others_Seen
:= True;
11357 elsif Others_Seen
then
11359 ("others must be the last property in option External",
11362 -- The only remaining legal options are the four predefined
11363 -- external properties.
11365 elsif Nkind
(Prop
) = N_Identifier
11366 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
11367 Name_Async_Writers
,
11368 Name_Effective_Reads
,
11369 Name_Effective_Writes
)
11373 -- Otherwise the construct is not a valid property
11376 SPARK_Msg_N
("invalid external state property", Prop
);
11380 -- Ensure that the expression of the external state property
11381 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
11383 if Present
(Expr
) then
11384 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
11386 if Is_OK_Static_Expression
(Expr
) then
11387 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
11390 ("expression of external state property must be "
11395 -- The lack of expression defaults the property to True
11401 -- Named properties
11403 if Nkind
(Prop
) = N_Identifier
then
11404 if Chars
(Prop
) = Name_Async_Readers
then
11405 Check_Duplicate_Property
(Prop
, AR_Seen
);
11406 AR_Val
:= Expr_Val
;
11408 elsif Chars
(Prop
) = Name_Async_Writers
then
11409 Check_Duplicate_Property
(Prop
, AW_Seen
);
11410 AW_Val
:= Expr_Val
;
11412 elsif Chars
(Prop
) = Name_Effective_Reads
then
11413 Check_Duplicate_Property
(Prop
, ER_Seen
);
11414 ER_Val
:= Expr_Val
;
11417 Check_Duplicate_Property
(Prop
, EW_Seen
);
11418 EW_Val
:= Expr_Val
;
11421 -- The handling of property "others" must take into account
11422 -- all other named properties that have been encountered so
11423 -- far. Only those that have not been seen are affected by
11427 if not AR_Seen
then
11428 AR_Val
:= Expr_Val
;
11431 if not AW_Seen
then
11432 AW_Val
:= Expr_Val
;
11435 if not ER_Seen
then
11436 ER_Val
:= Expr_Val
;
11439 if not EW_Seen
then
11440 EW_Val
:= Expr_Val
;
11443 end Analyze_External_Property
;
11445 ----------------------------
11446 -- Analyze_Part_Of_Option --
11447 ----------------------------
11449 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11450 Encap
: constant Node_Id
:= Expression
(Opt
);
11451 Constits
: Elist_Id
;
11452 Encap_Id
: Entity_Id
;
11456 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11459 (Indic
=> First
(Choices
(Opt
)),
11460 Item_Id
=> State_Id
,
11462 Encap_Id
=> Encap_Id
,
11465 -- The Part_Of indicator transforms the abstract state into
11466 -- a constituent of the encapsulating state or single
11467 -- concurrent type.
11470 pragma Assert
(Present
(Encap_Id
));
11471 Constits
:= Part_Of_Constituents
(Encap_Id
);
11473 if No
(Constits
) then
11474 Constits
:= New_Elmt_List
;
11475 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
11478 Append_Elmt
(State_Id
, Constits
);
11479 Set_Encapsulating_State
(State_Id
, Encap_Id
);
11481 end Analyze_Part_Of_Option
;
11483 ----------------------------
11484 -- Check_Duplicate_Option --
11485 ----------------------------
11487 procedure Check_Duplicate_Option
11489 Status
: in out Boolean)
11493 SPARK_Msg_N
("duplicate state option", Opt
);
11497 end Check_Duplicate_Option
;
11499 ------------------------------
11500 -- Check_Duplicate_Property --
11501 ------------------------------
11503 procedure Check_Duplicate_Property
11505 Status
: in out Boolean)
11509 SPARK_Msg_N
("duplicate external property", Prop
);
11513 end Check_Duplicate_Property
;
11515 -----------------------------
11516 -- Check_Ghost_Synchronous --
11517 -----------------------------
11519 procedure Check_Ghost_Synchronous
is
11521 -- A synchronized abstract state cannot be Ghost and vice
11522 -- versa (SPARK RM 6.9(19)).
11524 if Ghost_Seen
and Synchronous_Seen
then
11525 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
11527 end Check_Ghost_Synchronous
;
11529 ---------------------------
11530 -- Create_Abstract_State --
11531 ---------------------------
11533 procedure Create_Abstract_State
11540 -- The abstract state may be semi-declared when the related
11541 -- package was withed through a limited with clause. In that
11542 -- case reuse the entity to fully declare the state.
11544 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
11545 State_Id
:= Entity
(Decl
);
11547 -- Otherwise the elaboration of pragma Abstract_State
11548 -- declares the state.
11551 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
11553 if Present
(Decl
) then
11554 Set_Entity
(Decl
, State_Id
);
11558 -- Null states never come from source
11560 Set_Comes_From_Source
(State_Id
, not Is_Null
);
11561 Set_Parent
(State_Id
, State
);
11562 Set_Ekind
(State_Id
, E_Abstract_State
);
11563 Set_Etype
(State_Id
, Standard_Void_Type
);
11564 Set_Encapsulating_State
(State_Id
, Empty
);
11566 -- An abstract state declared within a Ghost region becomes
11567 -- Ghost (SPARK RM 6.9(2)).
11569 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
11570 Set_Is_Ghost_Entity
(State_Id
);
11573 -- Establish a link between the state declaration and the
11574 -- abstract state entity. Note that a null state remains as
11575 -- N_Null and does not carry any linkages.
11577 if not Is_Null
then
11578 if Present
(Decl
) then
11579 Set_Entity
(Decl
, State_Id
);
11580 Set_Etype
(Decl
, Standard_Void_Type
);
11583 -- Every non-null state must be defined, nameable and
11586 Push_Scope
(Pack_Id
);
11587 Generate_Definition
(State_Id
);
11588 Enter_Name
(State_Id
);
11591 end Create_Abstract_State
;
11598 -- Start of processing for Analyze_Abstract_State
11601 -- A package with a null abstract state is not allowed to
11602 -- declare additional states.
11606 ("package & has null abstract state", State
, Pack_Id
);
11608 -- Null states appear as internally generated entities
11610 elsif Nkind
(State
) = N_Null
then
11611 Create_Abstract_State
11612 (Nam
=> New_Internal_Name
('S'),
11614 Loc
=> Sloc
(State
),
11618 -- Catch a case where a null state appears in a list of
11619 -- non-null states.
11621 if Non_Null_Seen
then
11623 ("package & has non-null abstract state",
11627 -- Simple state declaration
11629 elsif Nkind
(State
) = N_Identifier
then
11630 Create_Abstract_State
11631 (Nam
=> Chars
(State
),
11633 Loc
=> Sloc
(State
),
11635 Non_Null_Seen
:= True;
11637 -- State declaration with various options. This construct
11638 -- appears as an extension aggregate in the tree.
11640 elsif Nkind
(State
) = N_Extension_Aggregate
then
11641 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11642 Create_Abstract_State
11643 (Nam
=> Chars
(Ancestor_Part
(State
)),
11644 Decl
=> Ancestor_Part
(State
),
11645 Loc
=> Sloc
(Ancestor_Part
(State
)),
11647 Non_Null_Seen
:= True;
11650 ("state name must be an identifier",
11651 Ancestor_Part
(State
));
11654 -- Options External, Ghost and Synchronous appear as
11657 Opt
:= First
(Expressions
(State
));
11658 while Present
(Opt
) loop
11659 if Nkind
(Opt
) = N_Identifier
then
11663 if Chars
(Opt
) = Name_External
then
11664 Check_Duplicate_Option
(Opt
, External_Seen
);
11665 Analyze_External_Option
(Opt
);
11669 elsif Chars
(Opt
) = Name_Ghost
then
11670 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11671 Check_Ghost_Synchronous
;
11673 if Present
(State_Id
) then
11674 Set_Is_Ghost_Entity
(State_Id
);
11679 elsif Chars
(Opt
) = Name_Synchronous
then
11680 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11681 Check_Ghost_Synchronous
;
11683 -- Option Part_Of without an encapsulating state is
11684 -- illegal (SPARK RM 7.1.4(9)).
11686 elsif Chars
(Opt
) = Name_Part_Of
then
11688 ("indicator Part_Of must denote abstract state, "
11689 & "single protected type or single task type",
11692 -- Do not emit an error message when a previous state
11693 -- declaration with options was not parenthesized as
11694 -- the option is actually another state declaration.
11696 -- with Abstract_State
11697 -- (State_1 with ..., -- missing parentheses
11698 -- (State_2 with ...),
11699 -- State_3) -- ok state declaration
11701 elsif Missing_Parentheses
then
11704 -- Otherwise the option is not allowed. Note that it
11705 -- is not possible to distinguish between an option
11706 -- and a state declaration when a previous state with
11707 -- options not properly parentheses.
11709 -- with Abstract_State
11710 -- (State_1 with ..., -- missing parentheses
11711 -- State_2); -- could be an option
11715 ("simple option not allowed in state declaration",
11719 -- Catch a case where missing parentheses around a state
11720 -- declaration with options cause a subsequent state
11721 -- declaration with options to be treated as an option.
11723 -- with Abstract_State
11724 -- (State_1 with ..., -- missing parentheses
11725 -- (State_2 with ...))
11727 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11728 Missing_Parentheses
:= True;
11730 ("state declaration must be parenthesized",
11731 Ancestor_Part
(State
));
11733 -- Otherwise the option is malformed
11736 SPARK_Msg_N
("malformed option", Opt
);
11742 -- Options External and Part_Of appear as component
11745 Opt
:= First
(Component_Associations
(State
));
11746 while Present
(Opt
) loop
11747 Opt_Nam
:= First
(Choices
(Opt
));
11749 if Nkind
(Opt_Nam
) = N_Identifier
then
11750 if Chars
(Opt_Nam
) = Name_External
then
11751 Analyze_External_Option
(Opt
);
11753 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11754 Analyze_Part_Of_Option
(Opt
);
11757 SPARK_Msg_N
("invalid state option", Opt
);
11760 SPARK_Msg_N
("invalid state option", Opt
);
11766 -- Any other attempt to declare a state is illegal
11769 Malformed_State_Error
(State
);
11773 -- Guard against a junk state. In such cases no entity is
11774 -- generated and the subsequent checks cannot be applied.
11776 if Present
(State_Id
) then
11778 -- Verify whether the state does not introduce an illegal
11779 -- hidden state within a package subject to a null abstract
11782 Check_No_Hidden_State
(State_Id
);
11784 -- Check whether the lack of option Part_Of agrees with the
11785 -- placement of the abstract state with respect to the state
11788 if not Part_Of_Seen
then
11789 Check_Missing_Part_Of
(State_Id
);
11792 -- Associate the state with its related package
11794 if No
(Abstract_States
(Pack_Id
)) then
11795 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11798 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11800 end Analyze_Abstract_State
;
11802 ---------------------------
11803 -- Malformed_State_Error --
11804 ---------------------------
11806 procedure Malformed_State_Error
(State
: Node_Id
) is
11808 Error_Msg_N
("malformed abstract state declaration", State
);
11810 -- An abstract state with a simple option is being declared
11811 -- with "=>" rather than the legal "with". The state appears
11812 -- as a component association.
11814 if Nkind
(State
) = N_Component_Association
then
11815 Error_Msg_N
("\use WITH to specify simple option", State
);
11817 end Malformed_State_Error
;
11821 Pack_Decl
: Node_Id
;
11822 Pack_Id
: Entity_Id
;
11826 -- Start of processing for Abstract_State
11830 Check_No_Identifiers
;
11831 Check_Arg_Count
(1);
11833 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11835 -- Ensure the proper placement of the pragma. Abstract states must
11836 -- be associated with a package declaration.
11838 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11839 N_Package_Declaration
)
11843 -- Otherwise the pragma is associated with an illegal construct
11850 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11852 -- A pragma that applies to a Ghost entity becomes Ghost for the
11853 -- purposes of legality checks and removal of ignored Ghost code.
11855 Mark_Ghost_Pragma
(N
, Pack_Id
);
11856 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11858 -- Chain the pragma on the contract for completeness
11860 Add_Contract_Item
(N
, Pack_Id
);
11862 -- The legality checks of pragmas Abstract_State, Initializes, and
11863 -- Initial_Condition are affected by the SPARK mode in effect. In
11864 -- addition, these three pragmas are subject to an inherent order:
11866 -- 1) Abstract_State
11868 -- 3) Initial_Condition
11870 -- Analyze all these pragmas in the order outlined above
11872 Analyze_If_Present
(Pragma_SPARK_Mode
);
11873 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11875 -- Multiple non-null abstract states appear as an aggregate
11877 if Nkind
(States
) = N_Aggregate
then
11878 State
:= First
(Expressions
(States
));
11879 while Present
(State
) loop
11880 Analyze_Abstract_State
(State
, Pack_Id
);
11884 -- An abstract state with a simple option is being illegaly
11885 -- declared with "=>" rather than "with". In this case the
11886 -- state declaration appears as a component association.
11888 if Present
(Component_Associations
(States
)) then
11889 State
:= First
(Component_Associations
(States
));
11890 while Present
(State
) loop
11891 Malformed_State_Error
(State
);
11896 -- Various forms of a single abstract state. Note that these may
11897 -- include malformed state declarations.
11900 Analyze_Abstract_State
(States
, Pack_Id
);
11903 Analyze_If_Present
(Pragma_Initializes
);
11904 Analyze_If_Present
(Pragma_Initial_Condition
);
11905 end Abstract_State
;
11913 -- Note: this pragma also has some specific processing in Par.Prag
11914 -- because we want to set the Ada version mode during parsing.
11916 when Pragma_Ada_83
=>
11918 Check_Arg_Count
(0);
11920 -- We really should check unconditionally for proper configuration
11921 -- pragma placement, since we really don't want mixed Ada modes
11922 -- within a single unit, and the GNAT reference manual has always
11923 -- said this was a configuration pragma, but we did not check and
11924 -- are hesitant to add the check now.
11926 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11927 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11928 -- or Ada 2012 mode.
11930 if Ada_Version
>= Ada_2005
then
11931 Check_Valid_Configuration_Pragma
;
11934 -- Now set Ada 83 mode
11936 if Latest_Ada_Only
then
11937 Error_Pragma
("??pragma% ignored");
11939 Ada_Version
:= Ada_83
;
11940 Ada_Version_Explicit
:= Ada_83
;
11941 Ada_Version_Pragma
:= N
;
11950 -- Note: this pragma also has some specific processing in Par.Prag
11951 -- because we want to set the Ada 83 version mode during parsing.
11953 when Pragma_Ada_95
=>
11955 Check_Arg_Count
(0);
11957 -- We really should check unconditionally for proper configuration
11958 -- pragma placement, since we really don't want mixed Ada modes
11959 -- within a single unit, and the GNAT reference manual has always
11960 -- said this was a configuration pragma, but we did not check and
11961 -- are hesitant to add the check now.
11963 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11964 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11966 if Ada_Version
>= Ada_2005
then
11967 Check_Valid_Configuration_Pragma
;
11970 -- Now set Ada 95 mode
11972 if Latest_Ada_Only
then
11973 Error_Pragma
("??pragma% ignored");
11975 Ada_Version
:= Ada_95
;
11976 Ada_Version_Explicit
:= Ada_95
;
11977 Ada_Version_Pragma
:= N
;
11980 ---------------------
11981 -- Ada_05/Ada_2005 --
11982 ---------------------
11985 -- pragma Ada_05 (LOCAL_NAME);
11987 -- pragma Ada_2005;
11988 -- pragma Ada_2005 (LOCAL_NAME):
11990 -- Note: these pragmas also have some specific processing in Par.Prag
11991 -- because we want to set the Ada 2005 version mode during parsing.
11993 -- The one argument form is used for managing the transition from
11994 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11995 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11996 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11997 -- mode, a preference rule is established which does not choose
11998 -- such an entity unless it is unambiguously specified. This avoids
11999 -- extra subprograms marked this way from generating ambiguities in
12000 -- otherwise legal pre-Ada_2005 programs. The one argument form is
12001 -- intended for exclusive use in the GNAT run-time library.
12012 if Arg_Count
= 1 then
12013 Check_Arg_Is_Local_Name
(Arg1
);
12014 E_Id
:= Get_Pragma_Arg
(Arg1
);
12016 if Etype
(E_Id
) = Any_Type
then
12020 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
12021 Record_Rep_Item
(Entity
(E_Id
), N
);
12024 Check_Arg_Count
(0);
12026 -- For Ada_2005 we unconditionally enforce the documented
12027 -- configuration pragma placement, since we do not want to
12028 -- tolerate mixed modes in a unit involving Ada 2005. That
12029 -- would cause real difficulties for those cases where there
12030 -- are incompatibilities between Ada 95 and Ada 2005.
12032 Check_Valid_Configuration_Pragma
;
12034 -- Now set appropriate Ada mode
12036 if Latest_Ada_Only
then
12037 Error_Pragma
("??pragma% ignored");
12039 Ada_Version
:= Ada_2005
;
12040 Ada_Version_Explicit
:= Ada_2005
;
12041 Ada_Version_Pragma
:= N
;
12046 ---------------------
12047 -- Ada_12/Ada_2012 --
12048 ---------------------
12051 -- pragma Ada_12 (LOCAL_NAME);
12053 -- pragma Ada_2012;
12054 -- pragma Ada_2012 (LOCAL_NAME):
12056 -- Note: these pragmas also have some specific processing in Par.Prag
12057 -- because we want to set the Ada 2012 version mode during parsing.
12059 -- The one argument form is used for managing the transition from Ada
12060 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
12061 -- as Ada_2012 only, then referencing the entity in any pre-Ada_2012
12062 -- mode will generate a warning. In addition, in any pre-Ada_2012
12063 -- mode, a preference rule is established which does not choose
12064 -- such an entity unless it is unambiguously specified. This avoids
12065 -- extra subprograms marked this way from generating ambiguities in
12066 -- otherwise legal pre-Ada_2012 programs. The one argument form is
12067 -- intended for exclusive use in the GNAT run-time library.
12078 if Arg_Count
= 1 then
12079 Check_Arg_Is_Local_Name
(Arg1
);
12080 E_Id
:= Get_Pragma_Arg
(Arg1
);
12082 if Etype
(E_Id
) = Any_Type
then
12086 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
12087 Record_Rep_Item
(Entity
(E_Id
), N
);
12090 Check_Arg_Count
(0);
12092 -- For Ada_2012 we unconditionally enforce the documented
12093 -- configuration pragma placement, since we do not want to
12094 -- tolerate mixed modes in a unit involving Ada 2012. That
12095 -- would cause real difficulties for those cases where there
12096 -- are incompatibilities between Ada 95 and Ada 2012. We could
12097 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
12099 Check_Valid_Configuration_Pragma
;
12101 -- Now set appropriate Ada mode
12103 Ada_Version
:= Ada_2012
;
12104 Ada_Version_Explicit
:= Ada_2012
;
12105 Ada_Version_Pragma
:= N
;
12113 -- pragma Ada_2020;
12115 -- Note: this pragma also has some specific processing in Par.Prag
12116 -- because we want to set the Ada 2020 version mode during parsing.
12118 when Pragma_Ada_2020
=>
12121 Check_Arg_Count
(0);
12123 Check_Valid_Configuration_Pragma
;
12125 -- Now set appropriate Ada mode
12127 Ada_Version
:= Ada_2020
;
12128 Ada_Version_Explicit
:= Ada_2020
;
12129 Ada_Version_Pragma
:= N
;
12131 ----------------------
12132 -- All_Calls_Remote --
12133 ----------------------
12135 -- pragma All_Calls_Remote [(library_package_NAME)];
12137 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
12138 Lib_Entity
: Entity_Id
;
12141 Check_Ada_83_Warning
;
12142 Check_Valid_Library_Unit_Pragma
;
12144 if Nkind
(N
) = N_Null_Statement
then
12148 Lib_Entity
:= Find_Lib_Unit_Name
;
12150 -- A pragma that applies to a Ghost entity becomes Ghost for the
12151 -- purposes of legality checks and removal of ignored Ghost code.
12153 Mark_Ghost_Pragma
(N
, Lib_Entity
);
12155 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
12157 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
12158 if not Is_Remote_Call_Interface
(Lib_Entity
) then
12159 Error_Pragma
("pragma% only apply to rci unit");
12161 -- Set flag for entity of the library unit
12164 Set_Has_All_Calls_Remote
(Lib_Entity
);
12167 end All_Calls_Remote
;
12169 ---------------------------
12170 -- Allow_Integer_Address --
12171 ---------------------------
12173 -- pragma Allow_Integer_Address;
12175 when Pragma_Allow_Integer_Address
=>
12177 Check_Valid_Configuration_Pragma
;
12178 Check_Arg_Count
(0);
12180 -- If Address is a private type, then set the flag to allow
12181 -- integer address values. If Address is not private, then this
12182 -- pragma has no purpose, so it is simply ignored. Not clear if
12183 -- there are any such targets now.
12185 if Opt
.Address_Is_Private
then
12186 Opt
.Allow_Integer_Address
:= True;
12194 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
12195 -- ARG ::= NAME | EXPRESSION
12197 -- The first two arguments are by convention intended to refer to an
12198 -- external tool and a tool-specific function. These arguments are
12201 when Pragma_Annotate
=> Annotate
: declare
12208 Check_At_Least_N_Arguments
(1);
12210 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
12212 -- Determine whether the last argument is "Entity => local_NAME"
12213 -- and if it is, perform the required semantic checks. Remove the
12214 -- argument from further processing.
12216 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
12217 and then Chars
(Nam_Arg
) = Name_Entity
12219 Check_Arg_Is_Local_Name
(Nam_Arg
);
12220 Arg_Count
:= Arg_Count
- 1;
12222 -- A pragma that applies to a Ghost entity becomes Ghost for
12223 -- the purposes of legality checks and removal of ignored Ghost
12226 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
12227 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
12229 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
12232 -- Not allowed in compiler units (bootstrap issues)
12234 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
12237 -- Continue the processing with last argument removed for now
12239 Check_Arg_Is_Identifier
(Arg1
);
12240 Check_No_Identifiers
;
12243 -- The second parameter is optional, it is never analyzed
12248 -- Otherwise there is a second parameter
12251 -- The second parameter must be an identifier
12253 Check_Arg_Is_Identifier
(Arg2
);
12255 -- Process the remaining parameters (if any)
12257 Arg
:= Next
(Arg2
);
12258 while Present
(Arg
) loop
12259 Expr
:= Get_Pragma_Arg
(Arg
);
12262 if Is_Entity_Name
(Expr
) then
12265 -- For string literals, we assume Standard_String as the
12266 -- type, unless the string contains wide or wide_wide
12269 elsif Nkind
(Expr
) = N_String_Literal
then
12270 if Has_Wide_Wide_Character
(Expr
) then
12271 Resolve
(Expr
, Standard_Wide_Wide_String
);
12272 elsif Has_Wide_Character
(Expr
) then
12273 Resolve
(Expr
, Standard_Wide_String
);
12275 Resolve
(Expr
, Standard_String
);
12278 elsif Is_Overloaded
(Expr
) then
12279 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
12290 -------------------------------------------------
12291 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
12292 -------------------------------------------------
12295 -- ( [Check => ] Boolean_EXPRESSION
12296 -- [, [Message =>] Static_String_EXPRESSION]);
12298 -- pragma Assert_And_Cut
12299 -- ( [Check => ] Boolean_EXPRESSION
12300 -- [, [Message =>] Static_String_EXPRESSION]);
12303 -- ( [Check => ] Boolean_EXPRESSION
12304 -- [, [Message =>] Static_String_EXPRESSION]);
12306 -- pragma Loop_Invariant
12307 -- ( [Check => ] Boolean_EXPRESSION
12308 -- [, [Message =>] Static_String_EXPRESSION]);
12311 | Pragma_Assert_And_Cut
12313 | Pragma_Loop_Invariant
12316 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
12317 -- Determine whether expression Expr contains a Loop_Entry
12318 -- attribute reference.
12320 -------------------------
12321 -- Contains_Loop_Entry --
12322 -------------------------
12324 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
12325 Has_Loop_Entry
: Boolean := False;
12327 function Process
(N
: Node_Id
) return Traverse_Result
;
12328 -- Process function for traversal to look for Loop_Entry
12334 function Process
(N
: Node_Id
) return Traverse_Result
is
12336 if Nkind
(N
) = N_Attribute_Reference
12337 and then Attribute_Name
(N
) = Name_Loop_Entry
12339 Has_Loop_Entry
:= True;
12346 procedure Traverse
is new Traverse_Proc
(Process
);
12348 -- Start of processing for Contains_Loop_Entry
12352 return Has_Loop_Entry
;
12353 end Contains_Loop_Entry
;
12358 New_Args
: List_Id
;
12360 -- Start of processing for Assert
12363 -- Assert is an Ada 2005 RM-defined pragma
12365 if Prag_Id
= Pragma_Assert
then
12368 -- The remaining ones are GNAT pragmas
12374 Check_At_Least_N_Arguments
(1);
12375 Check_At_Most_N_Arguments
(2);
12376 Check_Arg_Order
((Name_Check
, Name_Message
));
12377 Check_Optional_Identifier
(Arg1
, Name_Check
);
12378 Expr
:= Get_Pragma_Arg
(Arg1
);
12380 -- Special processing for Loop_Invariant, Loop_Variant or for
12381 -- other cases where a Loop_Entry attribute is present. If the
12382 -- assertion pragma contains attribute Loop_Entry, ensure that
12383 -- the related pragma is within a loop.
12385 if Prag_Id
= Pragma_Loop_Invariant
12386 or else Prag_Id
= Pragma_Loop_Variant
12387 or else Contains_Loop_Entry
(Expr
)
12389 Check_Loop_Pragma_Placement
;
12391 -- Perform preanalysis to deal with embedded Loop_Entry
12394 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
12397 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
12398 -- a corresponding Check pragma:
12400 -- pragma Check (name, condition [, msg]);
12402 -- Where name is the identifier matching the pragma name. So
12403 -- rewrite pragma in this manner, transfer the message argument
12404 -- if present, and analyze the result
12406 -- Note: When dealing with a semantically analyzed tree, the
12407 -- information that a Check node N corresponds to a source Assert,
12408 -- Assume, or Assert_And_Cut pragma can be retrieved from the
12409 -- pragma kind of Original_Node(N).
12411 New_Args
:= New_List
(
12412 Make_Pragma_Argument_Association
(Loc
,
12413 Expression
=> Make_Identifier
(Loc
, Pname
)),
12414 Make_Pragma_Argument_Association
(Sloc
(Expr
),
12415 Expression
=> Expr
));
12417 if Arg_Count
> 1 then
12418 Check_Optional_Identifier
(Arg2
, Name_Message
);
12420 -- Provide semantic annnotations for optional argument, for
12421 -- ASIS use, before rewriting.
12423 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
12424 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
12427 -- Rewrite as Check pragma
12431 Chars
=> Name_Check
,
12432 Pragma_Argument_Associations
=> New_Args
));
12437 ----------------------
12438 -- Assertion_Policy --
12439 ----------------------
12441 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
12443 -- The following form is Ada 2012 only, but we allow it in all modes
12445 -- Pragma Assertion_Policy (
12446 -- ASSERTION_KIND => POLICY_IDENTIFIER
12447 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
12449 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
12451 -- RM_ASSERTION_KIND ::= Assert |
12452 -- Static_Predicate |
12453 -- Dynamic_Predicate |
12458 -- Type_Invariant |
12459 -- Type_Invariant'Class
12461 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
12463 -- Contract_Cases |
12465 -- Default_Initial_Condition |
12467 -- Initial_Condition |
12468 -- Loop_Invariant |
12474 -- Statement_Assertions
12476 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12477 -- ID_ASSERTION_KIND list contains implementation-defined additions
12478 -- recognized by GNAT. The effect is to control the behavior of
12479 -- identically named aspects and pragmas, depending on the specified
12480 -- policy identifier:
12482 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12484 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12485 -- implementation-defined addition that results in totally ignoring
12486 -- the corresponding assertion. If Disable is specified, then the
12487 -- argument of the assertion is not even analyzed. This is useful
12488 -- when the aspect/pragma argument references entities in a with'ed
12489 -- package that is replaced by a dummy package in the final build.
12491 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12492 -- and Type_Invariant'Class were recognized by the parser and
12493 -- transformed into references to the special internal identifiers
12494 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12495 -- processing is required here.
12497 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
12498 procedure Resolve_Suppressible
(Policy
: Node_Id
);
12499 -- Converts the assertion policy 'Suppressible' to either Check or
12500 -- Ignore based on whether checks are suppressed via -gnatp.
12502 --------------------------
12503 -- Resolve_Suppressible --
12504 --------------------------
12506 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
12507 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
12511 -- Transform policy argument Suppressible into either Ignore or
12512 -- Check depending on whether checks are enabled or suppressed.
12514 if Chars
(Arg
) = Name_Suppressible
then
12515 if Suppress_Checks
then
12516 Nam
:= Name_Ignore
;
12521 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
12523 end Resolve_Suppressible
;
12535 -- This can always appear as a configuration pragma
12537 if Is_Configuration_Pragma
then
12540 -- It can also appear in a declarative part or package spec in Ada
12541 -- 2012 mode. We allow this in other modes, but in that case we
12542 -- consider that we have an Ada 2012 pragma on our hands.
12545 Check_Is_In_Decl_Part_Or_Package_Spec
;
12549 -- One argument case with no identifier (first form above)
12552 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
12553 or else Chars
(Arg1
) = No_Name
)
12555 Check_Arg_Is_One_Of
(Arg1
,
12556 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12558 Resolve_Suppressible
(Arg1
);
12560 -- Treat one argument Assertion_Policy as equivalent to:
12562 -- pragma Check_Policy (Assertion, policy)
12564 -- So rewrite pragma in that manner and link on to the chain
12565 -- of Check_Policy pragmas, marking the pragma as analyzed.
12567 Policy
:= Get_Pragma_Arg
(Arg1
);
12571 Chars
=> Name_Check_Policy
,
12572 Pragma_Argument_Associations
=> New_List
(
12573 Make_Pragma_Argument_Association
(Loc
,
12574 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
12576 Make_Pragma_Argument_Association
(Loc
,
12578 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
12581 -- Here if we have two or more arguments
12584 Check_At_Least_N_Arguments
(1);
12587 -- Loop through arguments
12590 while Present
(Arg
) loop
12591 LocP
:= Sloc
(Arg
);
12593 -- Kind must be specified
12595 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12596 or else Chars
(Arg
) = No_Name
12599 ("missing assertion kind for pragma%", Arg
);
12602 -- Check Kind and Policy have allowed forms
12604 Kind
:= Chars
(Arg
);
12605 Policy
:= Get_Pragma_Arg
(Arg
);
12607 if not Is_Valid_Assertion_Kind
(Kind
) then
12609 ("invalid assertion kind for pragma%", Arg
);
12612 Check_Arg_Is_One_Of
(Arg
,
12613 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12615 Resolve_Suppressible
(Arg
);
12617 if Kind
= Name_Ghost
then
12619 -- The Ghost policy must be either Check or Ignore
12620 -- (SPARK RM 6.9(6)).
12622 if not Nam_In
(Chars
(Policy
), Name_Check
,
12626 ("argument of pragma % Ghost must be Check or "
12627 & "Ignore", Policy
);
12630 -- Pragma Assertion_Policy specifying a Ghost policy
12631 -- cannot occur within a Ghost subprogram or package
12632 -- (SPARK RM 6.9(14)).
12634 if Ghost_Mode
> None
then
12636 ("pragma % cannot appear within ghost subprogram or "
12641 -- Rewrite the Assertion_Policy pragma as a series of
12642 -- Check_Policy pragmas of the form:
12644 -- Check_Policy (Kind, Policy);
12646 -- Note: the insertion of the pragmas cannot be done with
12647 -- Insert_Action because in the configuration case, there
12648 -- are no scopes on the scope stack and the mechanism will
12651 Insert_Before_And_Analyze
(N
,
12653 Chars
=> Name_Check_Policy
,
12654 Pragma_Argument_Associations
=> New_List
(
12655 Make_Pragma_Argument_Association
(LocP
,
12656 Expression
=> Make_Identifier
(LocP
, Kind
)),
12657 Make_Pragma_Argument_Association
(LocP
,
12658 Expression
=> Policy
))));
12663 -- Rewrite the Assertion_Policy pragma as null since we have
12664 -- now inserted all the equivalent Check pragmas.
12666 Rewrite
(N
, Make_Null_Statement
(Loc
));
12669 end Assertion_Policy
;
12671 ------------------------------
12672 -- Assume_No_Invalid_Values --
12673 ------------------------------
12675 -- pragma Assume_No_Invalid_Values (On | Off);
12677 when Pragma_Assume_No_Invalid_Values
=>
12679 Check_Valid_Configuration_Pragma
;
12680 Check_Arg_Count
(1);
12681 Check_No_Identifiers
;
12682 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12684 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12685 Assume_No_Invalid_Values
:= True;
12687 Assume_No_Invalid_Values
:= False;
12690 --------------------------
12691 -- Attribute_Definition --
12692 --------------------------
12694 -- pragma Attribute_Definition
12695 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12696 -- [Entity =>] LOCAL_NAME,
12697 -- [Expression =>] EXPRESSION | NAME);
12699 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12700 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12705 Check_Arg_Count
(3);
12706 Check_Optional_Identifier
(Arg1
, "attribute");
12707 Check_Optional_Identifier
(Arg2
, "entity");
12708 Check_Optional_Identifier
(Arg3
, "expression");
12710 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12711 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12715 Check_Arg_Is_Local_Name
(Arg2
);
12717 -- If the attribute is not recognized, then issue a warning (not
12718 -- an error), and ignore the pragma.
12720 Aname
:= Chars
(Attribute_Designator
);
12722 if not Is_Attribute_Name
(Aname
) then
12723 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12727 -- Otherwise, rewrite the pragma as an attribute definition clause
12730 Make_Attribute_Definition_Clause
(Loc
,
12731 Name
=> Get_Pragma_Arg
(Arg2
),
12733 Expression
=> Get_Pragma_Arg
(Arg3
)));
12735 end Attribute_Definition
;
12737 ------------------------------------------------------------------
12738 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12739 ------------------------------------------------------------------
12741 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12742 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12743 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12744 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12746 when Pragma_Async_Readers
12747 | Pragma_Async_Writers
12748 | Pragma_Effective_Reads
12749 | Pragma_Effective_Writes
12751 Async_Effective
: declare
12752 Obj_Decl
: Node_Id
;
12753 Obj_Id
: Entity_Id
;
12757 Check_No_Identifiers
;
12758 Check_At_Most_N_Arguments
(1);
12760 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12762 -- Object declaration
12764 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12767 -- Otherwise the pragma is associated with an illegal construact
12774 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12776 -- Perform minimal verification to ensure that the argument is at
12777 -- least a variable. Subsequent finer grained checks will be done
12778 -- at the end of the declarative region the contains the pragma.
12780 if Ekind
(Obj_Id
) = E_Variable
then
12782 -- A pragma that applies to a Ghost entity becomes Ghost for
12783 -- the purposes of legality checks and removal of ignored Ghost
12786 Mark_Ghost_Pragma
(N
, Obj_Id
);
12788 -- Chain the pragma on the contract for further processing by
12789 -- Analyze_External_Property_In_Decl_Part.
12791 Add_Contract_Item
(N
, Obj_Id
);
12793 -- Analyze the Boolean expression (if any)
12795 if Present
(Arg1
) then
12796 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12799 -- Otherwise the external property applies to a constant
12802 Error_Pragma
("pragma % must apply to a volatile object");
12804 end Async_Effective
;
12810 -- pragma Asynchronous (LOCAL_NAME);
12812 when Pragma_Asynchronous
=> Asynchronous
: declare
12815 Formal
: Entity_Id
;
12820 procedure Process_Async_Pragma
;
12821 -- Common processing for procedure and access-to-procedure case
12823 --------------------------
12824 -- Process_Async_Pragma --
12825 --------------------------
12827 procedure Process_Async_Pragma
is
12830 Set_Is_Asynchronous
(Nm
);
12834 -- The formals should be of mode IN (RM E.4.1(6))
12837 while Present
(S
) loop
12838 Formal
:= Defining_Identifier
(S
);
12840 if Nkind
(Formal
) = N_Defining_Identifier
12841 and then Ekind
(Formal
) /= E_In_Parameter
12844 ("pragma% procedure can only have IN parameter",
12851 Set_Is_Asynchronous
(Nm
);
12852 end Process_Async_Pragma
;
12854 -- Start of processing for pragma Asynchronous
12857 Check_Ada_83_Warning
;
12858 Check_No_Identifiers
;
12859 Check_Arg_Count
(1);
12860 Check_Arg_Is_Local_Name
(Arg1
);
12862 if Debug_Flag_U
then
12866 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12867 Analyze
(Get_Pragma_Arg
(Arg1
));
12868 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12870 -- A pragma that applies to a Ghost entity becomes Ghost for the
12871 -- purposes of legality checks and removal of ignored Ghost code.
12873 Mark_Ghost_Pragma
(N
, Nm
);
12875 if not Is_Remote_Call_Interface
(C_Ent
)
12876 and then not Is_Remote_Types
(C_Ent
)
12878 -- This pragma should only appear in an RCI or Remote Types
12879 -- unit (RM E.4.1(4)).
12882 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12885 if Ekind
(Nm
) = E_Procedure
12886 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12888 if not Is_Remote_Call_Interface
(Nm
) then
12890 ("pragma% cannot be applied on non-remote procedure",
12894 L
:= Parameter_Specifications
(Parent
(Nm
));
12895 Process_Async_Pragma
;
12898 elsif Ekind
(Nm
) = E_Function
then
12900 ("pragma% cannot be applied to function", Arg1
);
12902 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12903 if Is_Record_Type
(Nm
) then
12905 -- A record type that is the Equivalent_Type for a remote
12906 -- access-to-subprogram type.
12908 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
12911 -- A non-expanded RAS type (distribution is not enabled)
12913 Decl
:= Declaration_Node
(Nm
);
12916 if Nkind
(Decl
) = N_Full_Type_Declaration
12917 and then Nkind
(Type_Definition
(Decl
)) =
12918 N_Access_Procedure_Definition
12920 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
12921 Process_Async_Pragma
;
12923 if Is_Asynchronous
(Nm
)
12924 and then Expander_Active
12925 and then Get_PCS_Name
/= Name_No_DSA
12927 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
12932 ("pragma% cannot reference access-to-function type",
12936 -- Only other possibility is Access-to-class-wide type
12938 elsif Is_Access_Type
(Nm
)
12939 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
12941 Check_First_Subtype
(Arg1
);
12942 Set_Is_Asynchronous
(Nm
);
12943 if Expander_Active
then
12944 RACW_Type_Is_Asynchronous
(Nm
);
12948 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12956 -- pragma Atomic (LOCAL_NAME);
12958 when Pragma_Atomic
=>
12959 Process_Atomic_Independent_Shared_Volatile
;
12961 -----------------------
12962 -- Atomic_Components --
12963 -----------------------
12965 -- pragma Atomic_Components (array_LOCAL_NAME);
12967 -- This processing is shared by Volatile_Components
12969 when Pragma_Atomic_Components
12970 | Pragma_Volatile_Components
12972 Atomic_Components
: declare
12979 Check_Ada_83_Warning
;
12980 Check_No_Identifiers
;
12981 Check_Arg_Count
(1);
12982 Check_Arg_Is_Local_Name
(Arg1
);
12983 E_Id
:= Get_Pragma_Arg
(Arg1
);
12985 if Etype
(E_Id
) = Any_Type
then
12989 E
:= Entity
(E_Id
);
12991 -- A pragma that applies to a Ghost entity becomes Ghost for the
12992 -- purposes of legality checks and removal of ignored Ghost code.
12994 Mark_Ghost_Pragma
(N
, E
);
12995 Check_Duplicate_Pragma
(E
);
12997 if Rep_Item_Too_Early
(E
, N
)
12999 Rep_Item_Too_Late
(E
, N
)
13004 D
:= Declaration_Node
(E
);
13007 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
13009 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
13010 and then Nkind
(D
) = N_Object_Declaration
13011 and then Nkind
(Object_Definition
(D
)) =
13012 N_Constrained_Array_Definition
)
13014 -- The flag is set on the object, or on the base type
13016 if Nkind
(D
) /= N_Object_Declaration
then
13017 E
:= Base_Type
(E
);
13020 -- Atomic implies both Independent and Volatile
13022 if Prag_Id
= Pragma_Atomic_Components
then
13023 Set_Has_Atomic_Components
(E
);
13024 Set_Has_Independent_Components
(E
);
13027 Set_Has_Volatile_Components
(E
);
13030 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
13032 end Atomic_Components
;
13034 --------------------
13035 -- Attach_Handler --
13036 --------------------
13038 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
13040 when Pragma_Attach_Handler
=>
13041 Check_Ada_83_Warning
;
13042 Check_No_Identifiers
;
13043 Check_Arg_Count
(2);
13045 if No_Run_Time_Mode
then
13046 Error_Msg_CRT
("Attach_Handler pragma", N
);
13048 Check_Interrupt_Or_Attach_Handler
;
13050 -- The expression that designates the attribute may depend on a
13051 -- discriminant, and is therefore a per-object expression, to
13052 -- be expanded in the init proc. If expansion is enabled, then
13053 -- perform semantic checks on a copy only.
13058 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
13061 -- In Relaxed_RM_Semantics mode, we allow any static
13062 -- integer value, for compatibility with other compilers.
13064 if Relaxed_RM_Semantics
13065 and then Nkind
(Parg2
) = N_Integer_Literal
13067 Typ
:= Standard_Integer
;
13069 Typ
:= RTE
(RE_Interrupt_ID
);
13072 if Expander_Active
then
13073 Temp
:= New_Copy_Tree
(Parg2
);
13074 Set_Parent
(Temp
, N
);
13075 Preanalyze_And_Resolve
(Temp
, Typ
);
13078 Resolve
(Parg2
, Typ
);
13082 Process_Interrupt_Or_Attach_Handler
;
13085 --------------------
13086 -- C_Pass_By_Copy --
13087 --------------------
13089 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
13091 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
13097 Check_Valid_Configuration_Pragma
;
13098 Check_Arg_Count
(1);
13099 Check_Optional_Identifier
(Arg1
, "max_size");
13101 Arg
:= Get_Pragma_Arg
(Arg1
);
13102 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
13104 Val
:= Expr_Value
(Arg
);
13108 ("maximum size for pragma% must be positive", Arg1
);
13110 elsif UI_Is_In_Int_Range
(Val
) then
13111 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
13113 -- If a giant value is given, Int'Last will do well enough.
13114 -- If sometime someone complains that a record larger than
13115 -- two gigabytes is not copied, we will worry about it then.
13118 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
13120 end C_Pass_By_Copy
;
13126 -- pragma Check ([Name =>] CHECK_KIND,
13127 -- [Check =>] Boolean_EXPRESSION
13128 -- [,[Message =>] String_EXPRESSION]);
13130 -- CHECK_KIND ::= IDENTIFIER |
13133 -- Invariant'Class |
13134 -- Type_Invariant'Class
13136 -- The identifiers Assertions and Statement_Assertions are not
13137 -- allowed, since they have special meaning for Check_Policy.
13139 -- WARNING: The code below manages Ghost regions. Return statements
13140 -- must be replaced by gotos which jump to the end of the code and
13141 -- restore the Ghost mode.
13143 when Pragma_Check
=> Check
: declare
13144 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
13145 -- Save the Ghost mode to restore on exit
13151 pragma Warnings
(Off
, Str
);
13154 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
13155 -- the mode now to ensure that any nodes generated during analysis
13156 -- and expansion are marked as Ghost.
13158 Set_Ghost_Mode
(N
);
13161 Check_At_Least_N_Arguments
(2);
13162 Check_At_Most_N_Arguments
(3);
13163 Check_Optional_Identifier
(Arg1
, Name_Name
);
13164 Check_Optional_Identifier
(Arg2
, Name_Check
);
13166 if Arg_Count
= 3 then
13167 Check_Optional_Identifier
(Arg3
, Name_Message
);
13168 Str
:= Get_Pragma_Arg
(Arg3
);
13171 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
13172 Check_Arg_Is_Identifier
(Arg1
);
13173 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
13175 -- Check forbidden name Assertions or Statement_Assertions
13178 when Name_Assertions
=>
13180 ("""Assertions"" is not allowed as a check kind for "
13181 & "pragma%", Arg1
);
13183 when Name_Statement_Assertions
=>
13185 ("""Statement_Assertions"" is not allowed as a check kind "
13186 & "for pragma%", Arg1
);
13192 -- Check applicable policy. We skip this if Checked/Ignored status
13193 -- is already set (e.g. in the case of a pragma from an aspect).
13195 if Is_Checked
(N
) or else Is_Ignored
(N
) then
13198 -- For a non-source pragma that is a rewriting of another pragma,
13199 -- copy the Is_Checked/Ignored status from the rewritten pragma.
13201 elsif Is_Rewrite_Substitution
(N
)
13202 and then Nkind
(Original_Node
(N
)) = N_Pragma
13203 and then Original_Node
(N
) /= N
13205 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
13206 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
13208 -- Otherwise query the applicable policy at this point
13211 case Check_Kind
(Cname
) is
13212 when Name_Ignore
=>
13213 Set_Is_Ignored
(N
, True);
13214 Set_Is_Checked
(N
, False);
13217 Set_Is_Ignored
(N
, False);
13218 Set_Is_Checked
(N
, True);
13220 -- For disable, rewrite pragma as null statement and skip
13221 -- rest of the analysis of the pragma.
13223 when Name_Disable
=>
13224 Rewrite
(N
, Make_Null_Statement
(Loc
));
13228 -- No other possibilities
13231 raise Program_Error
;
13235 -- If check kind was not Disable, then continue pragma analysis
13237 Expr
:= Get_Pragma_Arg
(Arg2
);
13239 -- Deal with SCO generation
13241 if Is_Checked
(N
) and then not Split_PPC
(N
) then
13242 Set_SCO_Pragma_Enabled
(Loc
);
13245 -- Deal with analyzing the string argument. If checks are not
13246 -- on we don't want any expansion (since such expansion would
13247 -- not get properly deleted) but we do want to analyze (to get
13248 -- proper references). The Preanalyze_And_Resolve routine does
13249 -- just what we want. Ditto if pragma is active, because it will
13250 -- be rewritten as an if-statement whose analysis will complete
13251 -- analysis and expansion of the string message. This makes a
13252 -- difference in the unusual case where the expression for the
13253 -- string may have a side effect, such as raising an exception.
13254 -- This is mandated by RM 11.4.2, which specifies that the string
13255 -- expression is only evaluated if the check fails and
13256 -- Assertion_Error is to be raised.
13258 if Arg_Count
= 3 then
13259 Preanalyze_And_Resolve
(Str
, Standard_String
);
13262 -- Now you might think we could just do the same with the Boolean
13263 -- expression if checks are off (and expansion is on) and then
13264 -- rewrite the check as a null statement. This would work but we
13265 -- would lose the useful warnings about an assertion being bound
13266 -- to fail even if assertions are turned off.
13268 -- So instead we wrap the boolean expression in an if statement
13269 -- that looks like:
13271 -- if False and then condition then
13275 -- The reason we do this rewriting during semantic analysis rather
13276 -- than as part of normal expansion is that we cannot analyze and
13277 -- expand the code for the boolean expression directly, or it may
13278 -- cause insertion of actions that would escape the attempt to
13279 -- suppress the check code.
13281 -- Note that the Sloc for the if statement corresponds to the
13282 -- argument condition, not the pragma itself. The reason for
13283 -- this is that we may generate a warning if the condition is
13284 -- False at compile time, and we do not want to delete this
13285 -- warning when we delete the if statement.
13287 if Expander_Active
and Is_Ignored
(N
) then
13288 Eloc
:= Sloc
(Expr
);
13291 Make_If_Statement
(Eloc
,
13293 Make_And_Then
(Eloc
,
13294 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
13295 Right_Opnd
=> Expr
),
13296 Then_Statements
=> New_List
(
13297 Make_Null_Statement
(Eloc
))));
13299 -- Now go ahead and analyze the if statement
13301 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13303 -- One rather special treatment. If we are now in Eliminated
13304 -- overflow mode, then suppress overflow checking since we do
13305 -- not want to drag in the bignum stuff if we are in Ignore
13306 -- mode anyway. This is particularly important if we are using
13307 -- a configurable run time that does not support bignum ops.
13309 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
13311 Svo
: constant Boolean :=
13312 Scope_Suppress
.Suppress
(Overflow_Check
);
13314 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
13315 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
13317 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
13318 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
13321 -- Not that special case
13327 -- All done with this check
13329 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13331 -- Check is active or expansion not active. In these cases we can
13332 -- just go ahead and analyze the boolean with no worries.
13335 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
13336 Analyze_And_Resolve
(Expr
, Any_Boolean
);
13337 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
13340 Restore_Ghost_Mode
(Saved_GM
);
13343 --------------------------
13344 -- Check_Float_Overflow --
13345 --------------------------
13347 -- pragma Check_Float_Overflow;
13349 when Pragma_Check_Float_Overflow
=>
13351 Check_Valid_Configuration_Pragma
;
13352 Check_Arg_Count
(0);
13353 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
13359 -- pragma Check_Name (check_IDENTIFIER);
13361 when Pragma_Check_Name
=>
13363 Check_No_Identifiers
;
13364 Check_Valid_Configuration_Pragma
;
13365 Check_Arg_Count
(1);
13366 Check_Arg_Is_Identifier
(Arg1
);
13369 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
13372 for J
in Check_Names
.First
.. Check_Names
.Last
loop
13373 if Check_Names
.Table
(J
) = Nam
then
13378 Check_Names
.Append
(Nam
);
13385 -- This is the old style syntax, which is still allowed in all modes:
13387 -- pragma Check_Policy ([Name =>] CHECK_KIND
13388 -- [Policy =>] POLICY_IDENTIFIER);
13390 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
13392 -- CHECK_KIND ::= IDENTIFIER |
13395 -- Type_Invariant'Class |
13398 -- This is the new style syntax, compatible with Assertion_Policy
13399 -- and also allowed in all modes.
13401 -- Pragma Check_Policy (
13402 -- CHECK_KIND => POLICY_IDENTIFIER
13403 -- {, CHECK_KIND => POLICY_IDENTIFIER});
13405 -- Note: the identifiers Name and Policy are not allowed as
13406 -- Check_Kind values. This avoids ambiguities between the old and
13407 -- new form syntax.
13409 when Pragma_Check_Policy
=> Check_Policy
: declare
13414 Check_At_Least_N_Arguments
(1);
13416 -- A Check_Policy pragma can appear either as a configuration
13417 -- pragma, or in a declarative part or a package spec (see RM
13418 -- 11.5(5) for rules for Suppress/Unsuppress which are also
13419 -- followed for Check_Policy).
13421 if not Is_Configuration_Pragma
then
13422 Check_Is_In_Decl_Part_Or_Package_Spec
;
13425 -- Figure out if we have the old or new syntax. We have the
13426 -- old syntax if the first argument has no identifier, or the
13427 -- identifier is Name.
13429 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
13430 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
13434 Check_Arg_Count
(2);
13435 Check_Optional_Identifier
(Arg1
, Name_Name
);
13436 Kind
:= Get_Pragma_Arg
(Arg1
);
13437 Rewrite_Assertion_Kind
(Kind
,
13438 From_Policy
=> Comes_From_Source
(N
));
13439 Check_Arg_Is_Identifier
(Arg1
);
13441 -- Check forbidden check kind
13443 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
13444 Error_Msg_Name_2
:= Chars
(Kind
);
13446 ("pragma% does not allow% as check name", Arg1
);
13451 Check_Optional_Identifier
(Arg2
, Name_Policy
);
13452 Check_Arg_Is_One_Of
13454 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
13456 -- And chain pragma on the Check_Policy_List for search
13458 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
13459 Opt
.Check_Policy_List
:= N
;
13461 -- For the new syntax, what we do is to convert each argument to
13462 -- an old syntax equivalent. We do that because we want to chain
13463 -- old style Check_Policy pragmas for the search (we don't want
13464 -- to have to deal with multiple arguments in the search).
13475 while Present
(Arg
) loop
13476 LocP
:= Sloc
(Arg
);
13477 Argx
:= Get_Pragma_Arg
(Arg
);
13479 -- Kind must be specified
13481 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13482 or else Chars
(Arg
) = No_Name
13485 ("missing assertion kind for pragma%", Arg
);
13488 -- Construct equivalent old form syntax Check_Policy
13489 -- pragma and insert it to get remaining checks.
13493 Chars
=> Name_Check_Policy
,
13494 Pragma_Argument_Associations
=> New_List
(
13495 Make_Pragma_Argument_Association
(LocP
,
13497 Make_Identifier
(LocP
, Chars
(Arg
))),
13498 Make_Pragma_Argument_Association
(Sloc
(Argx
),
13499 Expression
=> Argx
)));
13503 -- For a configuration pragma, insert old form in
13504 -- the corresponding file.
13506 if Is_Configuration_Pragma
then
13507 Insert_After
(N
, New_P
);
13511 Insert_Action
(N
, New_P
);
13515 -- Rewrite original Check_Policy pragma to null, since we
13516 -- have converted it into a series of old syntax pragmas.
13518 Rewrite
(N
, Make_Null_Statement
(Loc
));
13528 -- pragma Comment (static_string_EXPRESSION)
13530 -- Processing for pragma Comment shares the circuitry for pragma
13531 -- Ident. The only differences are that Ident enforces a limit of 31
13532 -- characters on its argument, and also enforces limitations on
13533 -- placement for DEC compatibility. Pragma Comment shares neither of
13534 -- these restrictions.
13536 -------------------
13537 -- Common_Object --
13538 -------------------
13540 -- pragma Common_Object (
13541 -- [Internal =>] LOCAL_NAME
13542 -- [, [External =>] EXTERNAL_SYMBOL]
13543 -- [, [Size =>] EXTERNAL_SYMBOL]);
13545 -- Processing for this pragma is shared with Psect_Object
13547 ------------------------
13548 -- Compile_Time_Error --
13549 ------------------------
13551 -- pragma Compile_Time_Error
13552 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13554 when Pragma_Compile_Time_Error
=>
13556 Process_Compile_Time_Warning_Or_Error
;
13558 --------------------------
13559 -- Compile_Time_Warning --
13560 --------------------------
13562 -- pragma Compile_Time_Warning
13563 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13565 when Pragma_Compile_Time_Warning
=>
13567 Process_Compile_Time_Warning_Or_Error
;
13569 ---------------------------
13570 -- Compiler_Unit_Warning --
13571 ---------------------------
13573 -- pragma Compiler_Unit_Warning;
13577 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13578 -- errors not warnings. This means that we had introduced a big extra
13579 -- inertia to compiler changes, since even if we implemented a new
13580 -- feature, and even if all versions to be used for bootstrapping
13581 -- implemented this new feature, we could not use it, since old
13582 -- compilers would give errors for using this feature in units
13583 -- having Compiler_Unit pragmas.
13585 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13586 -- problem. We no longer have any units mentioning Compiler_Unit,
13587 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13588 -- and thus generates a warning which can be ignored. So that deals
13589 -- with the problem of old compilers not implementing the newer form
13592 -- Newer compilers recognize the new pragma, but generate warning
13593 -- messages instead of errors, which again can be ignored in the
13594 -- case of an old compiler which implements a wanted new feature
13595 -- but at the time felt like warning about it for older compilers.
13597 -- We retain Compiler_Unit so that new compilers can be used to build
13598 -- older run-times that use this pragma. That's an unusual case, but
13599 -- it's easy enough to handle, so why not?
13601 when Pragma_Compiler_Unit
13602 | Pragma_Compiler_Unit_Warning
13605 Check_Arg_Count
(0);
13607 -- Only recognized in main unit
13609 if Current_Sem_Unit
= Main_Unit
then
13610 Compiler_Unit
:= True;
13613 -----------------------------
13614 -- Complete_Representation --
13615 -----------------------------
13617 -- pragma Complete_Representation;
13619 when Pragma_Complete_Representation
=>
13621 Check_Arg_Count
(0);
13623 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13625 ("pragma & must appear within record representation clause");
13628 ----------------------------
13629 -- Complex_Representation --
13630 ----------------------------
13632 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13634 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13641 Check_Arg_Count
(1);
13642 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13643 Check_Arg_Is_Local_Name
(Arg1
);
13644 E_Id
:= Get_Pragma_Arg
(Arg1
);
13646 if Etype
(E_Id
) = Any_Type
then
13650 E
:= Entity
(E_Id
);
13652 if not Is_Record_Type
(E
) then
13654 ("argument for pragma% must be record type", Arg1
);
13657 Ent
:= First_Entity
(E
);
13660 or else No
(Next_Entity
(Ent
))
13661 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13662 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13663 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13666 ("record for pragma% must have two fields of the same "
13667 & "floating-point type", Arg1
);
13670 Set_Has_Complex_Representation
(Base_Type
(E
));
13672 -- We need to treat the type has having a non-standard
13673 -- representation, for back-end purposes, even though in
13674 -- general a complex will have the default representation
13675 -- of a record with two real components.
13677 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13679 end Complex_Representation
;
13681 -------------------------
13682 -- Component_Alignment --
13683 -------------------------
13685 -- pragma Component_Alignment (
13686 -- [Form =>] ALIGNMENT_CHOICE
13687 -- [, [Name =>] type_LOCAL_NAME]);
13689 -- ALIGNMENT_CHOICE ::=
13691 -- | Component_Size_4
13695 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13696 Args
: Args_List
(1 .. 2);
13697 Names
: constant Name_List
(1 .. 2) := (
13701 Form
: Node_Id
renames Args
(1);
13702 Name
: Node_Id
renames Args
(2);
13704 Atype
: Component_Alignment_Kind
;
13709 Gather_Associations
(Names
, Args
);
13712 Error_Pragma
("missing Form argument for pragma%");
13715 Check_Arg_Is_Identifier
(Form
);
13717 -- Get proper alignment, note that Default = Component_Size on all
13718 -- machines we have so far, and we want to set this value rather
13719 -- than the default value to indicate that it has been explicitly
13720 -- set (and thus will not get overridden by the default component
13721 -- alignment for the current scope)
13723 if Chars
(Form
) = Name_Component_Size
then
13724 Atype
:= Calign_Component_Size
;
13726 elsif Chars
(Form
) = Name_Component_Size_4
then
13727 Atype
:= Calign_Component_Size_4
;
13729 elsif Chars
(Form
) = Name_Default
then
13730 Atype
:= Calign_Component_Size
;
13732 elsif Chars
(Form
) = Name_Storage_Unit
then
13733 Atype
:= Calign_Storage_Unit
;
13737 ("invalid Form parameter for pragma%", Form
);
13740 -- The pragma appears in a configuration file
13742 if No
(Parent
(N
)) then
13743 Check_Valid_Configuration_Pragma
;
13745 -- Capture the component alignment in a global variable when
13746 -- the pragma appears in a configuration file. Note that the
13747 -- scope stack is empty at this point and cannot be used to
13748 -- store the alignment value.
13750 Configuration_Component_Alignment
:= Atype
;
13752 -- Case with no name, supplied, affects scope table entry
13754 elsif No
(Name
) then
13756 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13758 -- Case of name supplied
13761 Check_Arg_Is_Local_Name
(Name
);
13763 Typ
:= Entity
(Name
);
13766 or else Rep_Item_Too_Early
(Typ
, N
)
13770 Typ
:= Underlying_Type
(Typ
);
13773 if not Is_Record_Type
(Typ
)
13774 and then not Is_Array_Type
(Typ
)
13777 ("Name parameter of pragma% must identify record or "
13778 & "array type", Name
);
13781 -- An explicit Component_Alignment pragma overrides an
13782 -- implicit pragma Pack, but not an explicit one.
13784 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13785 Set_Is_Packed
(Base_Type
(Typ
), False);
13786 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13789 end Component_AlignmentP
;
13791 --------------------------------
13792 -- Constant_After_Elaboration --
13793 --------------------------------
13795 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13797 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13799 Obj_Decl
: Node_Id
;
13800 Obj_Id
: Entity_Id
;
13804 Check_No_Identifiers
;
13805 Check_At_Most_N_Arguments
(1);
13807 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13809 -- Object declaration
13811 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
13814 -- Otherwise the pragma is associated with an illegal construct
13821 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13823 -- The object declaration must be a library-level variable which
13824 -- is either explicitly initialized or obtains a value during the
13825 -- elaboration of a package body (SPARK RM 3.3.1).
13827 if Ekind
(Obj_Id
) = E_Variable
then
13828 if not Is_Library_Level_Entity
(Obj_Id
) then
13830 ("pragma % must apply to a library level variable");
13834 -- Otherwise the pragma applies to a constant, which is illegal
13837 Error_Pragma
("pragma % must apply to a variable declaration");
13841 -- A pragma that applies to a Ghost entity becomes Ghost for the
13842 -- purposes of legality checks and removal of ignored Ghost code.
13844 Mark_Ghost_Pragma
(N
, Obj_Id
);
13846 -- Chain the pragma on the contract for completeness
13848 Add_Contract_Item
(N
, Obj_Id
);
13850 -- Analyze the Boolean expression (if any)
13852 if Present
(Arg1
) then
13853 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13855 end Constant_After_Elaboration
;
13857 --------------------
13858 -- Contract_Cases --
13859 --------------------
13861 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13863 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13865 -- CASE_GUARD ::= boolean_EXPRESSION | others
13867 -- CONSEQUENCE ::= boolean_EXPRESSION
13869 -- Characteristics:
13871 -- * Analysis - The annotation undergoes initial checks to verify
13872 -- the legal placement and context. Secondary checks preanalyze the
13875 -- Analyze_Contract_Cases_In_Decl_Part
13877 -- * Expansion - The annotation is expanded during the expansion of
13878 -- the related subprogram [body] contract as performed in:
13880 -- Expand_Subprogram_Contract
13882 -- * Template - The annotation utilizes the generic template of the
13883 -- related subprogram [body] when it is:
13885 -- aspect on subprogram declaration
13886 -- aspect on stand-alone subprogram body
13887 -- pragma on stand-alone subprogram body
13889 -- The annotation must prepare its own template when it is:
13891 -- pragma on subprogram declaration
13893 -- * Globals - Capture of global references must occur after full
13896 -- * Instance - The annotation is instantiated automatically when
13897 -- the related generic subprogram [body] is instantiated except for
13898 -- the "pragma on subprogram declaration" case. In that scenario
13899 -- the annotation must instantiate itself.
13901 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13902 Spec_Id
: Entity_Id
;
13903 Subp_Decl
: Node_Id
;
13904 Subp_Spec
: Node_Id
;
13908 Check_No_Identifiers
;
13909 Check_Arg_Count
(1);
13911 -- Ensure the proper placement of the pragma. Contract_Cases must
13912 -- be associated with a subprogram declaration or a body that acts
13916 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13920 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13923 -- Generic subprogram
13925 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13928 -- Body acts as spec
13930 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13931 and then No
(Corresponding_Spec
(Subp_Decl
))
13935 -- Body stub acts as spec
13937 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13938 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13944 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13945 Subp_Spec
:= Specification
(Subp_Decl
);
13947 -- Pragma Contract_Cases is forbidden on null procedures, as
13948 -- this may lead to potential ambiguities in behavior when
13949 -- interface null procedures are involved.
13951 if Nkind
(Subp_Spec
) = N_Procedure_Specification
13952 and then Null_Present
(Subp_Spec
)
13954 Error_Msg_N
(Fix_Error
13955 ("pragma % cannot apply to null procedure"), N
);
13964 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13966 -- A pragma that applies to a Ghost entity becomes Ghost for the
13967 -- purposes of legality checks and removal of ignored Ghost code.
13969 Mark_Ghost_Pragma
(N
, Spec_Id
);
13970 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13972 -- Chain the pragma on the contract for further processing by
13973 -- Analyze_Contract_Cases_In_Decl_Part.
13975 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13977 -- Fully analyze the pragma when it appears inside an entry
13978 -- or subprogram body because it cannot benefit from forward
13981 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13983 N_Subprogram_Body_Stub
)
13985 -- The legality checks of pragma Contract_Cases are affected by
13986 -- the SPARK mode in effect and the volatility of the context.
13987 -- Analyze all pragmas in a specific order.
13989 Analyze_If_Present
(Pragma_SPARK_Mode
);
13990 Analyze_If_Present
(Pragma_Volatile_Function
);
13991 Analyze_Contract_Cases_In_Decl_Part
(N
);
13993 end Contract_Cases
;
13999 -- pragma Controlled (first_subtype_LOCAL_NAME);
14001 when Pragma_Controlled
=> Controlled
: declare
14005 Check_No_Identifiers
;
14006 Check_Arg_Count
(1);
14007 Check_Arg_Is_Local_Name
(Arg1
);
14008 Arg
:= Get_Pragma_Arg
(Arg1
);
14010 if not Is_Entity_Name
(Arg
)
14011 or else not Is_Access_Type
(Entity
(Arg
))
14013 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
14015 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
14023 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
14024 -- [Entity =>] LOCAL_NAME);
14026 when Pragma_Convention
=> Convention
: declare
14029 pragma Warnings
(Off
, C
);
14030 pragma Warnings
(Off
, E
);
14033 Check_Arg_Order
((Name_Convention
, Name_Entity
));
14034 Check_Ada_83_Warning
;
14035 Check_Arg_Count
(2);
14036 Process_Convention
(C
, E
);
14038 -- A pragma that applies to a Ghost entity becomes Ghost for the
14039 -- purposes of legality checks and removal of ignored Ghost code.
14041 Mark_Ghost_Pragma
(N
, E
);
14044 ---------------------------
14045 -- Convention_Identifier --
14046 ---------------------------
14048 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
14049 -- [Convention =>] convention_IDENTIFIER);
14051 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
14057 Check_Arg_Order
((Name_Name
, Name_Convention
));
14058 Check_Arg_Count
(2);
14059 Check_Optional_Identifier
(Arg1
, Name_Name
);
14060 Check_Optional_Identifier
(Arg2
, Name_Convention
);
14061 Check_Arg_Is_Identifier
(Arg1
);
14062 Check_Arg_Is_Identifier
(Arg2
);
14063 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
14064 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
14066 if Is_Convention_Name
(Cname
) then
14067 Record_Convention_Identifier
14068 (Idnam
, Get_Convention_Id
(Cname
));
14071 ("second arg for % pragma must be convention", Arg2
);
14073 end Convention_Identifier
;
14079 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
14081 when Pragma_CPP_Class
=>
14084 if Warn_On_Obsolescent_Feature
then
14086 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
14087 & "effect; replace it by pragma import?j?", N
);
14090 Check_Arg_Count
(1);
14094 Chars
=> Name_Import
,
14095 Pragma_Argument_Associations
=> New_List
(
14096 Make_Pragma_Argument_Association
(Loc
,
14097 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
14098 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
14101 ---------------------
14102 -- CPP_Constructor --
14103 ---------------------
14105 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
14106 -- [, [External_Name =>] static_string_EXPRESSION ]
14107 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14109 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
14112 Def_Id
: Entity_Id
;
14113 Tag_Typ
: Entity_Id
;
14117 Check_At_Least_N_Arguments
(1);
14118 Check_At_Most_N_Arguments
(3);
14119 Check_Optional_Identifier
(Arg1
, Name_Entity
);
14120 Check_Arg_Is_Local_Name
(Arg1
);
14122 Id
:= Get_Pragma_Arg
(Arg1
);
14123 Find_Program_Unit_Name
(Id
);
14125 -- If we did not find the name, we are done
14127 if Etype
(Id
) = Any_Type
then
14131 Def_Id
:= Entity
(Id
);
14133 -- Check if already defined as constructor
14135 if Is_Constructor
(Def_Id
) then
14137 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
14141 if Ekind
(Def_Id
) = E_Function
14142 and then (Is_CPP_Class
(Etype
(Def_Id
))
14143 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
14145 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
14147 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
14149 ("'C'P'P constructor must be defined in the scope of "
14150 & "its returned type", Arg1
);
14153 if Arg_Count
>= 2 then
14154 Set_Imported
(Def_Id
);
14155 Set_Is_Public
(Def_Id
);
14156 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
14159 Set_Has_Completion
(Def_Id
);
14160 Set_Is_Constructor
(Def_Id
);
14161 Set_Convention
(Def_Id
, Convention_CPP
);
14163 -- Imported C++ constructors are not dispatching primitives
14164 -- because in C++ they don't have a dispatch table slot.
14165 -- However, in Ada the constructor has the profile of a
14166 -- function that returns a tagged type and therefore it has
14167 -- been treated as a primitive operation during semantic
14168 -- analysis. We now remove it from the list of primitive
14169 -- operations of the type.
14171 if Is_Tagged_Type
(Etype
(Def_Id
))
14172 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
14173 and then Is_Dispatching_Operation
(Def_Id
)
14175 Tag_Typ
:= Etype
(Def_Id
);
14177 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
14178 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
14182 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
14183 Set_Is_Dispatching_Operation
(Def_Id
, False);
14186 -- For backward compatibility, if the constructor returns a
14187 -- class wide type, and we internally change the return type to
14188 -- the corresponding root type.
14190 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
14191 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
14195 ("pragma% requires function returning a 'C'P'P_Class type",
14198 end CPP_Constructor
;
14204 when Pragma_CPP_Virtual
=>
14207 if Warn_On_Obsolescent_Feature
then
14209 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
14217 when Pragma_CPP_Vtable
=>
14220 if Warn_On_Obsolescent_Feature
then
14222 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
14230 -- pragma CPU (EXPRESSION);
14232 when Pragma_CPU
=> CPU
: declare
14233 P
: constant Node_Id
:= Parent
(N
);
14239 Check_No_Identifiers
;
14240 Check_Arg_Count
(1);
14244 if Nkind
(P
) = N_Subprogram_Body
then
14245 Check_In_Main_Program
;
14247 Arg
:= Get_Pragma_Arg
(Arg1
);
14248 Analyze_And_Resolve
(Arg
, Any_Integer
);
14250 Ent
:= Defining_Unit_Name
(Specification
(P
));
14252 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
14253 Ent
:= Defining_Identifier
(Ent
);
14258 if not Is_OK_Static_Expression
(Arg
) then
14259 Flag_Non_Static_Expr
14260 ("main subprogram affinity is not static!", Arg
);
14263 -- If constraint error, then we already signalled an error
14265 elsif Raises_Constraint_Error
(Arg
) then
14268 -- Otherwise check in range
14272 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
14273 -- This is the entity System.Multiprocessors.CPU_Range;
14275 Val
: constant Uint
:= Expr_Value
(Arg
);
14278 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
14280 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
14283 ("main subprogram CPU is out of range", Arg1
);
14289 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
14293 elsif Nkind
(P
) = N_Task_Definition
then
14294 Arg
:= Get_Pragma_Arg
(Arg1
);
14295 Ent
:= Defining_Identifier
(Parent
(P
));
14297 -- The expression must be analyzed in the special manner
14298 -- described in "Handling of Default and Per-Object
14299 -- Expressions" in sem.ads.
14301 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
14303 -- Anything else is incorrect
14309 -- Check duplicate pragma before we chain the pragma in the Rep
14310 -- Item chain of Ent.
14312 Check_Duplicate_Pragma
(Ent
);
14313 Record_Rep_Item
(Ent
, N
);
14316 --------------------
14317 -- Deadline_Floor --
14318 --------------------
14320 -- pragma Deadline_Floor (time_span_EXPRESSION);
14322 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
14323 P
: constant Node_Id
:= Parent
(N
);
14329 Check_No_Identifiers
;
14330 Check_Arg_Count
(1);
14332 Arg
:= Get_Pragma_Arg
(Arg1
);
14334 -- The expression must be analyzed in the special manner described
14335 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
14337 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
14339 -- Only protected types allowed
14341 if Nkind
(P
) /= N_Protected_Definition
then
14345 Ent
:= Defining_Identifier
(Parent
(P
));
14347 -- Check duplicate pragma before we chain the pragma in the Rep
14348 -- Item chain of Ent.
14350 Check_Duplicate_Pragma
(Ent
);
14351 Record_Rep_Item
(Ent
, N
);
14353 end Deadline_Floor
;
14359 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
14361 when Pragma_Debug
=> Debug
: declare
14368 -- The condition for executing the call is that the expander
14369 -- is active and that we are not ignoring this debug pragma.
14374 (Expander_Active
and then not Is_Ignored
(N
)),
14377 if not Is_Ignored
(N
) then
14378 Set_SCO_Pragma_Enabled
(Loc
);
14381 if Arg_Count
= 2 then
14383 Make_And_Then
(Loc
,
14384 Left_Opnd
=> Relocate_Node
(Cond
),
14385 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
14386 Call
:= Get_Pragma_Arg
(Arg2
);
14388 Call
:= Get_Pragma_Arg
(Arg1
);
14391 if Nkind_In
(Call
, N_Expanded_Name
,
14394 N_Indexed_Component
,
14395 N_Selected_Component
)
14397 -- If this pragma Debug comes from source, its argument was
14398 -- parsed as a name form (which is syntactically identical).
14399 -- In a generic context a parameterless call will be left as
14400 -- an expanded name (if global) or selected_component if local.
14401 -- Change it to a procedure call statement now.
14403 Change_Name_To_Procedure_Call_Statement
(Call
);
14405 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
14407 -- Already in the form of a procedure call statement: nothing
14408 -- to do (could happen in case of an internally generated
14414 -- All other cases: diagnose error
14417 ("argument of pragma ""Debug"" is not procedure call",
14422 -- Rewrite into a conditional with an appropriate condition. We
14423 -- wrap the procedure call in a block so that overhead from e.g.
14424 -- use of the secondary stack does not generate execution overhead
14425 -- for suppressed conditions.
14427 -- Normally the analysis that follows will freeze the subprogram
14428 -- being called. However, if the call is to a null procedure,
14429 -- we want to freeze it before creating the block, because the
14430 -- analysis that follows may be done with expansion disabled, in
14431 -- which case the body will not be generated, leading to spurious
14434 if Nkind
(Call
) = N_Procedure_Call_Statement
14435 and then Is_Entity_Name
(Name
(Call
))
14437 Analyze
(Name
(Call
));
14438 Freeze_Before
(N
, Entity
(Name
(Call
)));
14442 Make_Implicit_If_Statement
(N
,
14444 Then_Statements
=> New_List
(
14445 Make_Block_Statement
(Loc
,
14446 Handled_Statement_Sequence
=>
14447 Make_Handled_Sequence_Of_Statements
(Loc
,
14448 Statements
=> New_List
(Relocate_Node
(Call
)))))));
14451 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
14452 -- after analysis of the normally rewritten node, to capture all
14453 -- references to entities, which avoids issuing wrong warnings
14454 -- about unused entities.
14456 if GNATprove_Mode
then
14457 Rewrite
(N
, Make_Null_Statement
(Loc
));
14465 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
14467 when Pragma_Debug_Policy
=>
14469 Check_Arg_Count
(1);
14470 Check_No_Identifiers
;
14471 Check_Arg_Is_Identifier
(Arg1
);
14473 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
14474 -- rewrite it that way, and let the rest of the checking come
14475 -- from analyzing the rewritten pragma.
14479 Chars
=> Name_Check_Policy
,
14480 Pragma_Argument_Associations
=> New_List
(
14481 Make_Pragma_Argument_Association
(Loc
,
14482 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
14484 Make_Pragma_Argument_Association
(Loc
,
14485 Expression
=> Get_Pragma_Arg
(Arg1
)))));
14488 -------------------------------
14489 -- Default_Initial_Condition --
14490 -------------------------------
14492 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14494 when Pragma_Default_Initial_Condition
=> DIC
: declare
14501 Check_No_Identifiers
;
14502 Check_At_Most_N_Arguments
(1);
14506 while Present
(Stmt
) loop
14508 -- Skip prior pragmas, but check for duplicates
14510 if Nkind
(Stmt
) = N_Pragma
then
14511 if Pragma_Name
(Stmt
) = Pname
then
14518 -- Skip internally generated code. Note that derived type
14519 -- declarations of untagged types with discriminants are
14520 -- rewritten as private type declarations.
14522 elsif not Comes_From_Source
(Stmt
)
14523 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
14527 -- The associated private type [extension] has been found, stop
14530 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
14531 N_Private_Type_Declaration
)
14533 Typ
:= Defining_Entity
(Stmt
);
14536 -- The pragma does not apply to a legal construct, issue an
14537 -- error and stop the analysis.
14544 Stmt
:= Prev
(Stmt
);
14547 -- The pragma does not apply to a legal construct, issue an error
14548 -- and stop the analysis.
14555 -- A pragma that applies to a Ghost entity becomes Ghost for the
14556 -- purposes of legality checks and removal of ignored Ghost code.
14558 Mark_Ghost_Pragma
(N
, Typ
);
14560 -- The pragma signals that the type defines its own DIC assertion
14563 Set_Has_Own_DIC
(Typ
);
14565 -- Chain the pragma on the rep item chain for further processing
14567 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
14569 -- Create the declaration of the procedure which verifies the
14570 -- assertion expression of pragma DIC at runtime.
14572 Build_DIC_Procedure_Declaration
(Typ
);
14575 ----------------------------------
14576 -- Default_Scalar_Storage_Order --
14577 ----------------------------------
14579 -- pragma Default_Scalar_Storage_Order
14580 -- (High_Order_First | Low_Order_First);
14582 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
14583 Default
: Character;
14587 Check_Arg_Count
(1);
14589 -- Default_Scalar_Storage_Order can appear as a configuration
14590 -- pragma, or in a declarative part of a package spec.
14592 if not Is_Configuration_Pragma
then
14593 Check_Is_In_Decl_Part_Or_Package_Spec
;
14596 Check_No_Identifiers
;
14597 Check_Arg_Is_One_Of
14598 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
14599 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14600 Default
:= Fold_Upper
(Name_Buffer
(1));
14602 if not Support_Nondefault_SSO_On_Target
14603 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
14605 if Warn_On_Unrecognized_Pragma
then
14607 ("non-default Scalar_Storage_Order not supported "
14608 & "on target?g?", N
);
14610 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
14613 -- Here set the specified default
14616 Opt
.Default_SSO
:= Default
;
14620 --------------------------
14621 -- Default_Storage_Pool --
14622 --------------------------
14624 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14626 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
14631 Check_Arg_Count
(1);
14633 -- Default_Storage_Pool can appear as a configuration pragma, or
14634 -- in a declarative part of a package spec.
14636 if not Is_Configuration_Pragma
then
14637 Check_Is_In_Decl_Part_Or_Package_Spec
;
14640 if From_Aspect_Specification
(N
) then
14642 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
14644 if not In_Open_Scopes
(E
) then
14646 ("aspect must apply to package or subprogram", N
);
14651 if Present
(Arg1
) then
14652 Pool
:= Get_Pragma_Arg
(Arg1
);
14654 -- Case of Default_Storage_Pool (null);
14656 if Nkind
(Pool
) = N_Null
then
14659 -- This is an odd case, this is not really an expression,
14660 -- so we don't have a type for it. So just set the type to
14663 Set_Etype
(Pool
, Empty
);
14665 -- Case of Default_Storage_Pool (storage_pool_NAME);
14668 -- If it's a configuration pragma, then the only allowed
14669 -- argument is "null".
14671 if Is_Configuration_Pragma
then
14672 Error_Pragma_Arg
("NULL expected", Arg1
);
14675 -- The expected type for a non-"null" argument is
14676 -- Root_Storage_Pool'Class, and the pool must be a variable.
14678 Analyze_And_Resolve
14679 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
14681 if Is_Variable
(Pool
) then
14683 -- A pragma that applies to a Ghost entity becomes Ghost
14684 -- for the purposes of legality checks and removal of
14685 -- ignored Ghost code.
14687 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14691 ("default storage pool must be a variable", Arg1
);
14695 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14696 -- access type will use this information to set the appropriate
14697 -- attributes of the access type. If the pragma appears in a
14698 -- generic unit it is ignored, given that it may refer to a
14701 if not Inside_A_Generic
then
14702 Default_Pool
:= Pool
;
14705 end Default_Storage_Pool
;
14711 -- pragma Depends (DEPENDENCY_RELATION);
14713 -- DEPENDENCY_RELATION ::=
14715 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14717 -- DEPENDENCY_CLAUSE ::=
14718 -- OUTPUT_LIST =>[+] INPUT_LIST
14719 -- | NULL_DEPENDENCY_CLAUSE
14721 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14723 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14725 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14727 -- OUTPUT ::= NAME | FUNCTION_RESULT
14730 -- where FUNCTION_RESULT is a function Result attribute_reference
14732 -- Characteristics:
14734 -- * Analysis - The annotation undergoes initial checks to verify
14735 -- the legal placement and context. Secondary checks fully analyze
14736 -- the dependency clauses in:
14738 -- Analyze_Depends_In_Decl_Part
14740 -- * Expansion - None.
14742 -- * Template - The annotation utilizes the generic template of the
14743 -- related subprogram [body] when it is:
14745 -- aspect on subprogram declaration
14746 -- aspect on stand-alone subprogram body
14747 -- pragma on stand-alone subprogram body
14749 -- The annotation must prepare its own template when it is:
14751 -- pragma on subprogram declaration
14753 -- * Globals - Capture of global references must occur after full
14756 -- * Instance - The annotation is instantiated automatically when
14757 -- the related generic subprogram [body] is instantiated except for
14758 -- the "pragma on subprogram declaration" case. In that scenario
14759 -- the annotation must instantiate itself.
14761 when Pragma_Depends
=> Depends
: declare
14763 Spec_Id
: Entity_Id
;
14764 Subp_Decl
: Node_Id
;
14767 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14771 -- Chain the pragma on the contract for further processing by
14772 -- Analyze_Depends_In_Decl_Part.
14774 Add_Contract_Item
(N
, Spec_Id
);
14776 -- Fully analyze the pragma when it appears inside an entry
14777 -- or subprogram body because it cannot benefit from forward
14780 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14782 N_Subprogram_Body_Stub
)
14784 -- The legality checks of pragmas Depends and Global are
14785 -- affected by the SPARK mode in effect and the volatility
14786 -- of the context. In addition these two pragmas are subject
14787 -- to an inherent order:
14792 -- Analyze all these pragmas in the order outlined above
14794 Analyze_If_Present
(Pragma_SPARK_Mode
);
14795 Analyze_If_Present
(Pragma_Volatile_Function
);
14796 Analyze_If_Present
(Pragma_Global
);
14797 Analyze_Depends_In_Decl_Part
(N
);
14802 ---------------------
14803 -- Detect_Blocking --
14804 ---------------------
14806 -- pragma Detect_Blocking;
14808 when Pragma_Detect_Blocking
=>
14810 Check_Arg_Count
(0);
14811 Check_Valid_Configuration_Pragma
;
14812 Detect_Blocking
:= True;
14814 ------------------------------------
14815 -- Disable_Atomic_Synchronization --
14816 ------------------------------------
14818 -- pragma Disable_Atomic_Synchronization [(Entity)];
14820 when Pragma_Disable_Atomic_Synchronization
=>
14822 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14824 -------------------
14825 -- Discard_Names --
14826 -------------------
14828 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14830 when Pragma_Discard_Names
=> Discard_Names
: declare
14835 Check_Ada_83_Warning
;
14837 -- Deal with configuration pragma case
14839 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14840 Global_Discard_Names
:= True;
14843 -- Otherwise, check correct appropriate context
14846 Check_Is_In_Decl_Part_Or_Package_Spec
;
14848 if Arg_Count
= 0 then
14850 -- If there is no parameter, then from now on this pragma
14851 -- applies to any enumeration, exception or tagged type
14852 -- defined in the current declarative part, and recursively
14853 -- to any nested scope.
14855 Set_Discard_Names
(Current_Scope
);
14859 Check_Arg_Count
(1);
14860 Check_Optional_Identifier
(Arg1
, Name_On
);
14861 Check_Arg_Is_Local_Name
(Arg1
);
14863 E_Id
:= Get_Pragma_Arg
(Arg1
);
14865 if Etype
(E_Id
) = Any_Type
then
14869 E
:= Entity
(E_Id
);
14871 -- A pragma that applies to a Ghost entity becomes Ghost for
14872 -- the purposes of legality checks and removal of ignored
14875 Mark_Ghost_Pragma
(N
, E
);
14877 if (Is_First_Subtype
(E
)
14879 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14880 or else Ekind
(E
) = E_Exception
14882 Set_Discard_Names
(E
);
14883 Record_Rep_Item
(E
, N
);
14887 ("inappropriate entity for pragma%", Arg1
);
14893 ------------------------
14894 -- Dispatching_Domain --
14895 ------------------------
14897 -- pragma Dispatching_Domain (EXPRESSION);
14899 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14900 P
: constant Node_Id
:= Parent
(N
);
14906 Check_No_Identifiers
;
14907 Check_Arg_Count
(1);
14909 -- This pragma is born obsolete, but not the aspect
14911 if not From_Aspect_Specification
(N
) then
14913 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14916 if Nkind
(P
) = N_Task_Definition
then
14917 Arg
:= Get_Pragma_Arg
(Arg1
);
14918 Ent
:= Defining_Identifier
(Parent
(P
));
14920 -- A pragma that applies to a Ghost entity becomes Ghost for
14921 -- the purposes of legality checks and removal of ignored Ghost
14924 Mark_Ghost_Pragma
(N
, Ent
);
14926 -- The expression must be analyzed in the special manner
14927 -- described in "Handling of Default and Per-Object
14928 -- Expressions" in sem.ads.
14930 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14932 -- Check duplicate pragma before we chain the pragma in the Rep
14933 -- Item chain of Ent.
14935 Check_Duplicate_Pragma
(Ent
);
14936 Record_Rep_Item
(Ent
, N
);
14938 -- Anything else is incorrect
14943 end Dispatching_Domain
;
14949 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14951 when Pragma_Elaborate
=> Elaborate
: declare
14956 -- Pragma must be in context items list of a compilation unit
14958 if not Is_In_Context_Clause
then
14962 -- Must be at least one argument
14964 if Arg_Count
= 0 then
14965 Error_Pragma
("pragma% requires at least one argument");
14968 -- In Ada 83 mode, there can be no items following it in the
14969 -- context list except other pragmas and implicit with clauses
14970 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14971 -- placement rule does not apply.
14973 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14975 while Present
(Citem
) loop
14976 if Nkind
(Citem
) = N_Pragma
14977 or else (Nkind
(Citem
) = N_With_Clause
14978 and then Implicit_With
(Citem
))
14983 ("(Ada 83) pragma% must be at end of context clause");
14990 -- Finally, the arguments must all be units mentioned in a with
14991 -- clause in the same context clause. Note we already checked (in
14992 -- Par.Prag) that the arguments are all identifiers or selected
14996 Outer
: while Present
(Arg
) loop
14997 Citem
:= First
(List_Containing
(N
));
14998 Inner
: while Citem
/= N
loop
14999 if Nkind
(Citem
) = N_With_Clause
15000 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15002 Set_Elaborate_Present
(Citem
, True);
15003 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15013 ("argument of pragma% is not withed unit", Arg
);
15019 -- Give a warning if operating in static mode with one of the
15020 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
15023 and not Dynamic_Elaboration_Checks
15025 -- pragma Elaborate not allowed in SPARK mode anyway. We
15026 -- already complained about it, no point in generating any
15027 -- further complaint.
15029 and SPARK_Mode
/= On
15032 ("?l?use of pragma Elaborate may not be safe", N
);
15034 ("?l?use pragma Elaborate_All instead if possible", N
);
15038 -------------------
15039 -- Elaborate_All --
15040 -------------------
15042 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
15044 when Pragma_Elaborate_All
=> Elaborate_All
: declare
15049 Check_Ada_83_Warning
;
15051 -- Pragma must be in context items list of a compilation unit
15053 if not Is_In_Context_Clause
then
15057 -- Must be at least one argument
15059 if Arg_Count
= 0 then
15060 Error_Pragma
("pragma% requires at least one argument");
15063 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
15064 -- have to appear at the end of the context clause, but may
15065 -- appear mixed in with other items, even in Ada 83 mode.
15067 -- Final check: the arguments must all be units mentioned in
15068 -- a with clause in the same context clause. Note that we
15069 -- already checked (in Par.Prag) that all the arguments are
15070 -- either identifiers or selected components.
15073 Outr
: while Present
(Arg
) loop
15074 Citem
:= First
(List_Containing
(N
));
15075 Innr
: while Citem
/= N
loop
15076 if Nkind
(Citem
) = N_With_Clause
15077 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
15079 Set_Elaborate_All_Present
(Citem
, True);
15080 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
15089 Set_Error_Posted
(N
);
15091 ("argument of pragma% is not withed unit", Arg
);
15098 --------------------
15099 -- Elaborate_Body --
15100 --------------------
15102 -- pragma Elaborate_Body [( library_unit_NAME )];
15104 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
15105 Cunit_Node
: Node_Id
;
15106 Cunit_Ent
: Entity_Id
;
15109 Check_Ada_83_Warning
;
15110 Check_Valid_Library_Unit_Pragma
;
15112 if Nkind
(N
) = N_Null_Statement
then
15116 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
15117 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
15119 -- A pragma that applies to a Ghost entity becomes Ghost for the
15120 -- purposes of legality checks and removal of ignored Ghost code.
15122 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
15124 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
15127 Error_Pragma
("pragma% must refer to a spec, not a body");
15129 Set_Body_Required
(Cunit_Node
);
15130 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
15132 end Elaborate_Body
;
15134 ------------------------
15135 -- Elaboration_Checks --
15136 ------------------------
15138 -- pragma Elaboration_Checks (Static | Dynamic);
15140 when Pragma_Elaboration_Checks
=>
15142 Check_Arg_Count
(1);
15143 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
15145 -- Set flag accordingly (ignore attempt at dynamic elaboration
15146 -- checks in SPARK mode).
15148 Dynamic_Elaboration_Checks
:=
15149 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
15155 -- pragma Eliminate (
15156 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
15157 -- [Entity =>] IDENTIFIER |
15158 -- SELECTED_COMPONENT |
15160 -- [, Source_Location => SOURCE_TRACE]);
15162 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
15163 -- SOURCE_TRACE ::= STRING_LITERAL
15165 when Pragma_Eliminate
=> Eliminate
: declare
15166 Args
: Args_List
(1 .. 5);
15167 Names
: constant Name_List
(1 .. 5) := (
15170 Name_Parameter_Types
,
15172 Name_Source_Location
);
15174 -- Note : Parameter_Types and Result_Type are leftovers from
15175 -- prior implementations of the pragma. They are not generated
15176 -- by the gnatelim tool, and play no role in selecting which
15177 -- of a set of overloaded names is chosen for elimination.
15179 Unit_Name
: Node_Id
renames Args
(1);
15180 Entity
: Node_Id
renames Args
(2);
15181 Parameter_Types
: Node_Id
renames Args
(3);
15182 Result_Type
: Node_Id
renames Args
(4);
15183 Source_Location
: Node_Id
renames Args
(5);
15187 Check_Valid_Configuration_Pragma
;
15188 Gather_Associations
(Names
, Args
);
15190 if No
(Unit_Name
) then
15191 Error_Pragma
("missing Unit_Name argument for pragma%");
15195 and then (Present
(Parameter_Types
)
15197 Present
(Result_Type
)
15199 Present
(Source_Location
))
15201 Error_Pragma
("missing Entity argument for pragma%");
15204 if (Present
(Parameter_Types
)
15206 Present
(Result_Type
))
15208 Present
(Source_Location
)
15211 ("parameter profile and source location cannot be used "
15212 & "together in pragma%");
15215 Process_Eliminate_Pragma
15224 -----------------------------------
15225 -- Enable_Atomic_Synchronization --
15226 -----------------------------------
15228 -- pragma Enable_Atomic_Synchronization [(Entity)];
15230 when Pragma_Enable_Atomic_Synchronization
=>
15232 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
15239 -- [ Convention =>] convention_IDENTIFIER,
15240 -- [ Entity =>] LOCAL_NAME
15241 -- [, [External_Name =>] static_string_EXPRESSION ]
15242 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15244 when Pragma_Export
=> Export
: declare
15246 Def_Id
: Entity_Id
;
15248 pragma Warnings
(Off
, C
);
15251 Check_Ada_83_Warning
;
15255 Name_External_Name
,
15258 Check_At_Least_N_Arguments
(2);
15259 Check_At_Most_N_Arguments
(4);
15261 -- In Relaxed_RM_Semantics, support old Ada 83 style:
15262 -- pragma Export (Entity, "external name");
15264 if Relaxed_RM_Semantics
15265 and then Arg_Count
= 2
15266 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
15269 Def_Id
:= Get_Pragma_Arg
(Arg1
);
15272 if not Is_Entity_Name
(Def_Id
) then
15273 Error_Pragma_Arg
("entity name required", Arg1
);
15276 Def_Id
:= Entity
(Def_Id
);
15277 Set_Exported
(Def_Id
, Arg1
);
15280 Process_Convention
(C
, Def_Id
);
15282 -- A pragma that applies to a Ghost entity becomes Ghost for
15283 -- the purposes of legality checks and removal of ignored Ghost
15286 Mark_Ghost_Pragma
(N
, Def_Id
);
15288 if Ekind
(Def_Id
) /= E_Constant
then
15289 Note_Possible_Modification
15290 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15293 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
15294 Set_Exported
(Def_Id
, Arg2
);
15297 -- If the entity is a deferred constant, propagate the information
15298 -- to the full view, because gigi elaborates the full view only.
15300 if Ekind
(Def_Id
) = E_Constant
15301 and then Present
(Full_View
(Def_Id
))
15304 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
15306 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
15307 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
15308 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
15313 ---------------------
15314 -- Export_Function --
15315 ---------------------
15317 -- pragma Export_Function (
15318 -- [Internal =>] LOCAL_NAME
15319 -- [, [External =>] EXTERNAL_SYMBOL]
15320 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15321 -- [, [Result_Type =>] TYPE_DESIGNATOR]
15322 -- [, [Mechanism =>] MECHANISM]
15323 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15325 -- EXTERNAL_SYMBOL ::=
15327 -- | static_string_EXPRESSION
15329 -- PARAMETER_TYPES ::=
15331 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15333 -- TYPE_DESIGNATOR ::=
15335 -- | subtype_Name ' Access
15339 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15341 -- MECHANISM_ASSOCIATION ::=
15342 -- [formal_parameter_NAME =>] MECHANISM_NAME
15344 -- MECHANISM_NAME ::=
15348 when Pragma_Export_Function
=> Export_Function
: declare
15349 Args
: Args_List
(1 .. 6);
15350 Names
: constant Name_List
(1 .. 6) := (
15353 Name_Parameter_Types
,
15356 Name_Result_Mechanism
);
15358 Internal
: Node_Id
renames Args
(1);
15359 External
: Node_Id
renames Args
(2);
15360 Parameter_Types
: Node_Id
renames Args
(3);
15361 Result_Type
: Node_Id
renames Args
(4);
15362 Mechanism
: Node_Id
renames Args
(5);
15363 Result_Mechanism
: Node_Id
renames Args
(6);
15367 Gather_Associations
(Names
, Args
);
15368 Process_Extended_Import_Export_Subprogram_Pragma
(
15369 Arg_Internal
=> Internal
,
15370 Arg_External
=> External
,
15371 Arg_Parameter_Types
=> Parameter_Types
,
15372 Arg_Result_Type
=> Result_Type
,
15373 Arg_Mechanism
=> Mechanism
,
15374 Arg_Result_Mechanism
=> Result_Mechanism
);
15375 end Export_Function
;
15377 -------------------
15378 -- Export_Object --
15379 -------------------
15381 -- pragma Export_Object (
15382 -- [Internal =>] LOCAL_NAME
15383 -- [, [External =>] EXTERNAL_SYMBOL]
15384 -- [, [Size =>] EXTERNAL_SYMBOL]);
15386 -- EXTERNAL_SYMBOL ::=
15388 -- | static_string_EXPRESSION
15390 -- PARAMETER_TYPES ::=
15392 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15394 -- TYPE_DESIGNATOR ::=
15396 -- | subtype_Name ' Access
15400 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15402 -- MECHANISM_ASSOCIATION ::=
15403 -- [formal_parameter_NAME =>] MECHANISM_NAME
15405 -- MECHANISM_NAME ::=
15409 when Pragma_Export_Object
=> Export_Object
: declare
15410 Args
: Args_List
(1 .. 3);
15411 Names
: constant Name_List
(1 .. 3) := (
15416 Internal
: Node_Id
renames Args
(1);
15417 External
: Node_Id
renames Args
(2);
15418 Size
: Node_Id
renames Args
(3);
15422 Gather_Associations
(Names
, Args
);
15423 Process_Extended_Import_Export_Object_Pragma
(
15424 Arg_Internal
=> Internal
,
15425 Arg_External
=> External
,
15429 ----------------------
15430 -- Export_Procedure --
15431 ----------------------
15433 -- pragma Export_Procedure (
15434 -- [Internal =>] LOCAL_NAME
15435 -- [, [External =>] EXTERNAL_SYMBOL]
15436 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15437 -- [, [Mechanism =>] MECHANISM]);
15439 -- EXTERNAL_SYMBOL ::=
15441 -- | static_string_EXPRESSION
15443 -- PARAMETER_TYPES ::=
15445 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15447 -- TYPE_DESIGNATOR ::=
15449 -- | subtype_Name ' Access
15453 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15455 -- MECHANISM_ASSOCIATION ::=
15456 -- [formal_parameter_NAME =>] MECHANISM_NAME
15458 -- MECHANISM_NAME ::=
15462 when Pragma_Export_Procedure
=> Export_Procedure
: declare
15463 Args
: Args_List
(1 .. 4);
15464 Names
: constant Name_List
(1 .. 4) := (
15467 Name_Parameter_Types
,
15470 Internal
: Node_Id
renames Args
(1);
15471 External
: Node_Id
renames Args
(2);
15472 Parameter_Types
: Node_Id
renames Args
(3);
15473 Mechanism
: Node_Id
renames Args
(4);
15477 Gather_Associations
(Names
, Args
);
15478 Process_Extended_Import_Export_Subprogram_Pragma
(
15479 Arg_Internal
=> Internal
,
15480 Arg_External
=> External
,
15481 Arg_Parameter_Types
=> Parameter_Types
,
15482 Arg_Mechanism
=> Mechanism
);
15483 end Export_Procedure
;
15489 -- pragma Export_Value (
15490 -- [Value =>] static_integer_EXPRESSION,
15491 -- [Link_Name =>] static_string_EXPRESSION);
15493 when Pragma_Export_Value
=>
15495 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
15496 Check_Arg_Count
(2);
15498 Check_Optional_Identifier
(Arg1
, Name_Value
);
15499 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15501 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
15502 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15504 -----------------------------
15505 -- Export_Valued_Procedure --
15506 -----------------------------
15508 -- pragma Export_Valued_Procedure (
15509 -- [Internal =>] LOCAL_NAME
15510 -- [, [External =>] EXTERNAL_SYMBOL,]
15511 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15512 -- [, [Mechanism =>] MECHANISM]);
15514 -- EXTERNAL_SYMBOL ::=
15516 -- | static_string_EXPRESSION
15518 -- PARAMETER_TYPES ::=
15520 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15522 -- TYPE_DESIGNATOR ::=
15524 -- | subtype_Name ' Access
15528 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15530 -- MECHANISM_ASSOCIATION ::=
15531 -- [formal_parameter_NAME =>] MECHANISM_NAME
15533 -- MECHANISM_NAME ::=
15537 when Pragma_Export_Valued_Procedure
=>
15538 Export_Valued_Procedure
: declare
15539 Args
: Args_List
(1 .. 4);
15540 Names
: constant Name_List
(1 .. 4) := (
15543 Name_Parameter_Types
,
15546 Internal
: Node_Id
renames Args
(1);
15547 External
: Node_Id
renames Args
(2);
15548 Parameter_Types
: Node_Id
renames Args
(3);
15549 Mechanism
: Node_Id
renames Args
(4);
15553 Gather_Associations
(Names
, Args
);
15554 Process_Extended_Import_Export_Subprogram_Pragma
(
15555 Arg_Internal
=> Internal
,
15556 Arg_External
=> External
,
15557 Arg_Parameter_Types
=> Parameter_Types
,
15558 Arg_Mechanism
=> Mechanism
);
15559 end Export_Valued_Procedure
;
15561 -------------------
15562 -- Extend_System --
15563 -------------------
15565 -- pragma Extend_System ([Name =>] Identifier);
15567 when Pragma_Extend_System
=>
15569 Check_Valid_Configuration_Pragma
;
15570 Check_Arg_Count
(1);
15571 Check_Optional_Identifier
(Arg1
, Name_Name
);
15572 Check_Arg_Is_Identifier
(Arg1
);
15574 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15577 and then Name_Buffer
(1 .. 4) = "aux_"
15579 if Present
(System_Extend_Pragma_Arg
) then
15580 if Chars
(Get_Pragma_Arg
(Arg1
)) =
15581 Chars
(Expression
(System_Extend_Pragma_Arg
))
15585 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
15586 Error_Pragma
("pragma% conflicts with that #");
15590 System_Extend_Pragma_Arg
:= Arg1
;
15592 if not GNAT_Mode
then
15593 System_Extend_Unit
:= Arg1
;
15597 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
15600 ------------------------
15601 -- Extensions_Allowed --
15602 ------------------------
15604 -- pragma Extensions_Allowed (ON | OFF);
15606 when Pragma_Extensions_Allowed
=>
15608 Check_Arg_Count
(1);
15609 Check_No_Identifiers
;
15610 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
15612 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
15613 Extensions_Allowed
:= True;
15614 Ada_Version
:= Ada_Version_Type
'Last;
15617 Extensions_Allowed
:= False;
15618 Ada_Version
:= Ada_Version_Explicit
;
15619 Ada_Version_Pragma
:= Empty
;
15622 ------------------------
15623 -- Extensions_Visible --
15624 ------------------------
15626 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15628 -- Characteristics:
15630 -- * Analysis - The annotation is fully analyzed immediately upon
15631 -- elaboration as its expression must be static.
15633 -- * Expansion - None.
15635 -- * Template - The annotation utilizes the generic template of the
15636 -- related subprogram [body] when it is:
15638 -- aspect on subprogram declaration
15639 -- aspect on stand-alone subprogram body
15640 -- pragma on stand-alone subprogram body
15642 -- The annotation must prepare its own template when it is:
15644 -- pragma on subprogram declaration
15646 -- * Globals - Capture of global references must occur after full
15649 -- * Instance - The annotation is instantiated automatically when
15650 -- the related generic subprogram [body] is instantiated except for
15651 -- the "pragma on subprogram declaration" case. In that scenario
15652 -- the annotation must instantiate itself.
15654 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15655 Formal
: Entity_Id
;
15656 Has_OK_Formal
: Boolean := False;
15657 Spec_Id
: Entity_Id
;
15658 Subp_Decl
: Node_Id
;
15662 Check_No_Identifiers
;
15663 Check_At_Most_N_Arguments
(1);
15666 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15668 -- Abstract subprogram declaration
15670 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15673 -- Generic subprogram declaration
15675 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15678 -- Body acts as spec
15680 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15681 and then No
(Corresponding_Spec
(Subp_Decl
))
15685 -- Body stub acts as spec
15687 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15688 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15692 -- Subprogram declaration
15694 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15697 -- Otherwise the pragma is associated with an illegal construct
15700 Error_Pragma
("pragma % must apply to a subprogram");
15704 -- Mark the pragma as Ghost if the related subprogram is also
15705 -- Ghost. This also ensures that any expansion performed further
15706 -- below will produce Ghost nodes.
15708 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15709 Mark_Ghost_Pragma
(N
, Spec_Id
);
15711 -- Chain the pragma on the contract for completeness
15713 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15715 -- The legality checks of pragma Extension_Visible are affected
15716 -- by the SPARK mode in effect. Analyze all pragmas in specific
15719 Analyze_If_Present
(Pragma_SPARK_Mode
);
15721 -- Examine the formals of the related subprogram
15723 Formal
:= First_Formal
(Spec_Id
);
15724 while Present
(Formal
) loop
15726 -- At least one of the formals is of a specific tagged type,
15727 -- the pragma is legal.
15729 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15730 Has_OK_Formal
:= True;
15733 -- A generic subprogram with at least one formal of a private
15734 -- type ensures the legality of the pragma because the actual
15735 -- may be specifically tagged. Note that this is verified by
15736 -- the check above at instantiation time.
15738 elsif Is_Private_Type
(Etype
(Formal
))
15739 and then Is_Generic_Type
(Etype
(Formal
))
15741 Has_OK_Formal
:= True;
15745 Next_Formal
(Formal
);
15748 if not Has_OK_Formal
then
15749 Error_Msg_Name_1
:= Pname
;
15750 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15752 ("\subprogram & lacks parameter of specific tagged or "
15753 & "generic private type", N
, Spec_Id
);
15758 -- Analyze the Boolean expression (if any)
15760 if Present
(Arg1
) then
15761 Check_Static_Boolean_Expression
15762 (Expression
(Get_Argument
(N
, Spec_Id
)));
15764 end Extensions_Visible
;
15770 -- pragma External (
15771 -- [ Convention =>] convention_IDENTIFIER,
15772 -- [ Entity =>] LOCAL_NAME
15773 -- [, [External_Name =>] static_string_EXPRESSION ]
15774 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15776 when Pragma_External
=> External
: declare
15779 pragma Warnings
(Off
, C
);
15786 Name_External_Name
,
15788 Check_At_Least_N_Arguments
(2);
15789 Check_At_Most_N_Arguments
(4);
15790 Process_Convention
(C
, E
);
15792 -- A pragma that applies to a Ghost entity becomes Ghost for the
15793 -- purposes of legality checks and removal of ignored Ghost code.
15795 Mark_Ghost_Pragma
(N
, E
);
15797 Note_Possible_Modification
15798 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15799 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
15800 Set_Exported
(E
, Arg2
);
15803 --------------------------
15804 -- External_Name_Casing --
15805 --------------------------
15807 -- pragma External_Name_Casing (
15808 -- UPPERCASE | LOWERCASE
15809 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15811 when Pragma_External_Name_Casing
=>
15813 Check_No_Identifiers
;
15815 if Arg_Count
= 2 then
15816 Check_Arg_Is_One_Of
15817 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15819 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15821 Opt
.External_Name_Exp_Casing
:= As_Is
;
15823 when Name_Uppercase
=>
15824 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15826 when Name_Lowercase
=>
15827 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15834 Check_Arg_Count
(1);
15837 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15839 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15840 when Name_Uppercase
=>
15841 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15843 when Name_Lowercase
=>
15844 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15854 -- pragma Fast_Math;
15856 when Pragma_Fast_Math
=>
15858 Check_No_Identifiers
;
15859 Check_Valid_Configuration_Pragma
;
15862 --------------------------
15863 -- Favor_Top_Level --
15864 --------------------------
15866 -- pragma Favor_Top_Level (type_NAME);
15868 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15873 Check_No_Identifiers
;
15874 Check_Arg_Count
(1);
15875 Check_Arg_Is_Local_Name
(Arg1
);
15876 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15878 -- A pragma that applies to a Ghost entity becomes Ghost for the
15879 -- purposes of legality checks and removal of ignored Ghost code.
15881 Mark_Ghost_Pragma
(N
, Typ
);
15883 -- If it's an access-to-subprogram type (in particular, not a
15884 -- subtype), set the flag on that type.
15886 if Is_Access_Subprogram_Type
(Typ
) then
15887 Set_Can_Use_Internal_Rep
(Typ
, False);
15889 -- Otherwise it's an error (name denotes the wrong sort of entity)
15893 ("access-to-subprogram type expected",
15894 Get_Pragma_Arg
(Arg1
));
15896 end Favor_Top_Level
;
15898 ---------------------------
15899 -- Finalize_Storage_Only --
15900 ---------------------------
15902 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15904 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15905 Assoc
: constant Node_Id
:= Arg1
;
15906 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15911 Check_No_Identifiers
;
15912 Check_Arg_Count
(1);
15913 Check_Arg_Is_Local_Name
(Arg1
);
15915 Find_Type
(Type_Id
);
15916 Typ
:= Entity
(Type_Id
);
15919 or else Rep_Item_Too_Early
(Typ
, N
)
15923 Typ
:= Underlying_Type
(Typ
);
15926 if not Is_Controlled
(Typ
) then
15927 Error_Pragma
("pragma% must specify controlled type");
15930 Check_First_Subtype
(Arg1
);
15932 if Finalize_Storage_Only
(Typ
) then
15933 Error_Pragma
("duplicate pragma%, only one allowed");
15935 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15936 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15938 end Finalize_Storage
;
15944 -- pragma Ghost [ (boolean_EXPRESSION) ];
15946 when Pragma_Ghost
=> Ghost
: declare
15950 Orig_Stmt
: Node_Id
;
15951 Prev_Id
: Entity_Id
;
15956 Check_No_Identifiers
;
15957 Check_At_Most_N_Arguments
(1);
15961 while Present
(Stmt
) loop
15963 -- Skip prior pragmas, but check for duplicates
15965 if Nkind
(Stmt
) = N_Pragma
then
15966 if Pragma_Name
(Stmt
) = Pname
then
15973 -- Task unit declared without a definition cannot be subject to
15974 -- pragma Ghost (SPARK RM 6.9(19)).
15976 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15977 N_Task_Type_Declaration
)
15979 Error_Pragma
("pragma % cannot apply to a task type");
15982 -- Skip internally generated code
15984 elsif not Comes_From_Source
(Stmt
) then
15985 Orig_Stmt
:= Original_Node
(Stmt
);
15987 -- When pragma Ghost applies to an untagged derivation, the
15988 -- derivation is transformed into a [sub]type declaration.
15990 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15991 N_Subtype_Declaration
)
15992 and then Comes_From_Source
(Orig_Stmt
)
15993 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15994 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15995 N_Derived_Type_Definition
15997 Id
:= Defining_Entity
(Stmt
);
16000 -- When pragma Ghost applies to an object declaration which
16001 -- is initialized by means of a function call that returns
16002 -- on the secondary stack, the object declaration becomes a
16005 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
16006 and then Comes_From_Source
(Orig_Stmt
)
16007 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
16009 Id
:= Defining_Entity
(Stmt
);
16012 -- When pragma Ghost applies to an expression function, the
16013 -- expression function is transformed into a subprogram.
16015 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
16016 and then Comes_From_Source
(Orig_Stmt
)
16017 and then Nkind
(Orig_Stmt
) = N_Expression_Function
16019 Id
:= Defining_Entity
(Stmt
);
16023 -- The pragma applies to a legal construct, stop the traversal
16025 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
16026 N_Full_Type_Declaration
,
16027 N_Generic_Subprogram_Declaration
,
16028 N_Object_Declaration
,
16029 N_Private_Extension_Declaration
,
16030 N_Private_Type_Declaration
,
16031 N_Subprogram_Declaration
,
16032 N_Subtype_Declaration
)
16034 Id
:= Defining_Entity
(Stmt
);
16037 -- The pragma does not apply to a legal construct, issue an
16038 -- error and stop the analysis.
16042 ("pragma % must apply to an object, package, subprogram "
16047 Stmt
:= Prev
(Stmt
);
16050 Context
:= Parent
(N
);
16052 -- Handle compilation units
16054 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
16055 Context
:= Unit
(Parent
(Context
));
16058 -- Protected and task types cannot be subject to pragma Ghost
16059 -- (SPARK RM 6.9(19)).
16061 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
16063 Error_Pragma
("pragma % cannot apply to a protected type");
16066 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
16067 Error_Pragma
("pragma % cannot apply to a task type");
16073 -- When pragma Ghost is associated with a [generic] package, it
16074 -- appears in the visible declarations.
16076 if Nkind
(Context
) = N_Package_Specification
16077 and then Present
(Visible_Declarations
(Context
))
16078 and then List_Containing
(N
) = Visible_Declarations
(Context
)
16080 Id
:= Defining_Entity
(Context
);
16082 -- Pragma Ghost applies to a stand-alone subprogram body
16084 elsif Nkind
(Context
) = N_Subprogram_Body
16085 and then No
(Corresponding_Spec
(Context
))
16087 Id
:= Defining_Entity
(Context
);
16089 -- Pragma Ghost applies to a subprogram declaration that acts
16090 -- as a compilation unit.
16092 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
16093 Id
:= Defining_Entity
(Context
);
16095 -- Pragma Ghost applies to a generic subprogram
16097 elsif Nkind
(Context
) = N_Generic_Subprogram_Declaration
then
16098 Id
:= Defining_Entity
(Specification
(Context
));
16104 ("pragma % must apply to an object, package, subprogram or "
16109 -- Handle completions of types and constants that are subject to
16112 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
16113 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
16115 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
16116 Error_Msg_Name_1
:= Pname
;
16118 -- The full declaration of a deferred constant cannot be
16119 -- subject to pragma Ghost unless the deferred declaration
16120 -- is also Ghost (SPARK RM 6.9(9)).
16122 if Ekind
(Prev_Id
) = E_Constant
then
16123 Error_Msg_Name_1
:= Pname
;
16124 Error_Msg_NE
(Fix_Error
16125 ("pragma % must apply to declaration of deferred "
16126 & "constant &"), N
, Id
);
16129 -- Pragma Ghost may appear on the full view of an incomplete
16130 -- type because the incomplete declaration lacks aspects and
16131 -- cannot be subject to pragma Ghost.
16133 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
16136 -- The full declaration of a type cannot be subject to
16137 -- pragma Ghost unless the partial view is also Ghost
16138 -- (SPARK RM 6.9(9)).
16141 Error_Msg_NE
(Fix_Error
16142 ("pragma % must apply to partial view of type &"),
16148 -- A synchronized object cannot be subject to pragma Ghost
16149 -- (SPARK RM 6.9(19)).
16151 elsif Ekind
(Id
) = E_Variable
then
16152 if Is_Protected_Type
(Etype
(Id
)) then
16153 Error_Pragma
("pragma % cannot apply to a protected object");
16156 elsif Is_Task_Type
(Etype
(Id
)) then
16157 Error_Pragma
("pragma % cannot apply to a task object");
16162 -- Analyze the Boolean expression (if any)
16164 if Present
(Arg1
) then
16165 Expr
:= Get_Pragma_Arg
(Arg1
);
16167 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
16169 if Is_OK_Static_Expression
(Expr
) then
16171 -- "Ghostness" cannot be turned off once enabled within a
16172 -- region (SPARK RM 6.9(6)).
16174 if Is_False
(Expr_Value
(Expr
))
16175 and then Ghost_Mode
> None
16178 ("pragma % with value False cannot appear in enabled "
16183 -- Otherwie the expression is not static
16187 ("expression of pragma % must be static", Expr
);
16192 Set_Is_Ghost_Entity
(Id
);
16199 -- pragma Global (GLOBAL_SPECIFICATION);
16201 -- GLOBAL_SPECIFICATION ::=
16204 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
16206 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
16208 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
16209 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
16210 -- GLOBAL_ITEM ::= NAME
16212 -- Characteristics:
16214 -- * Analysis - The annotation undergoes initial checks to verify
16215 -- the legal placement and context. Secondary checks fully analyze
16216 -- the dependency clauses in:
16218 -- Analyze_Global_In_Decl_Part
16220 -- * Expansion - None.
16222 -- * Template - The annotation utilizes the generic template of the
16223 -- related subprogram [body] when it is:
16225 -- aspect on subprogram declaration
16226 -- aspect on stand-alone subprogram body
16227 -- pragma on stand-alone subprogram body
16229 -- The annotation must prepare its own template when it is:
16231 -- pragma on subprogram declaration
16233 -- * Globals - Capture of global references must occur after full
16236 -- * Instance - The annotation is instantiated automatically when
16237 -- the related generic subprogram [body] is instantiated except for
16238 -- the "pragma on subprogram declaration" case. In that scenario
16239 -- the annotation must instantiate itself.
16241 when Pragma_Global
=> Global
: declare
16243 Spec_Id
: Entity_Id
;
16244 Subp_Decl
: Node_Id
;
16247 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
16251 -- Chain the pragma on the contract for further processing by
16252 -- Analyze_Global_In_Decl_Part.
16254 Add_Contract_Item
(N
, Spec_Id
);
16256 -- Fully analyze the pragma when it appears inside an entry
16257 -- or subprogram body because it cannot benefit from forward
16260 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
16262 N_Subprogram_Body_Stub
)
16264 -- The legality checks of pragmas Depends and Global are
16265 -- affected by the SPARK mode in effect and the volatility
16266 -- of the context. In addition these two pragmas are subject
16267 -- to an inherent order:
16272 -- Analyze all these pragmas in the order outlined above
16274 Analyze_If_Present
(Pragma_SPARK_Mode
);
16275 Analyze_If_Present
(Pragma_Volatile_Function
);
16276 Analyze_Global_In_Decl_Part
(N
);
16277 Analyze_If_Present
(Pragma_Depends
);
16286 -- pragma Ident (static_string_EXPRESSION)
16288 -- Note: pragma Comment shares this processing. Pragma Ident is
16289 -- identical in effect to pragma Commment.
16291 when Pragma_Comment
16299 Check_Arg_Count
(1);
16300 Check_No_Identifiers
;
16301 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16304 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
16311 GP
:= Parent
(Parent
(N
));
16313 if Nkind_In
(GP
, N_Package_Declaration
,
16314 N_Generic_Package_Declaration
)
16319 -- If we have a compilation unit, then record the ident value,
16320 -- checking for improper duplication.
16322 if Nkind
(GP
) = N_Compilation_Unit
then
16323 CS
:= Ident_String
(Current_Sem_Unit
);
16325 if Present
(CS
) then
16327 -- If we have multiple instances, concatenate them, but
16328 -- not in ASIS, where we want the original tree.
16330 if not ASIS_Mode
then
16331 Start_String
(Strval
(CS
));
16332 Store_String_Char
(' ');
16333 Store_String_Chars
(Strval
(Str
));
16334 Set_Strval
(CS
, End_String
);
16338 Set_Ident_String
(Current_Sem_Unit
, Str
);
16341 -- For subunits, we just ignore the Ident, since in GNAT these
16342 -- are not separate object files, and hence not separate units
16343 -- in the unit table.
16345 elsif Nkind
(GP
) = N_Subunit
then
16351 -------------------
16352 -- Ignore_Pragma --
16353 -------------------
16355 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
16357 -- Entirely handled in the parser, nothing to do here
16359 when Pragma_Ignore_Pragma
=>
16362 ----------------------------
16363 -- Implementation_Defined --
16364 ----------------------------
16366 -- pragma Implementation_Defined (LOCAL_NAME);
16368 -- Marks previously declared entity as implementation defined. For
16369 -- an overloaded entity, applies to the most recent homonym.
16371 -- pragma Implementation_Defined;
16373 -- The form with no arguments appears anywhere within a scope, most
16374 -- typically a package spec, and indicates that all entities that are
16375 -- defined within the package spec are Implementation_Defined.
16377 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
16382 Check_No_Identifiers
;
16384 -- Form with no arguments
16386 if Arg_Count
= 0 then
16387 Set_Is_Implementation_Defined
(Current_Scope
);
16389 -- Form with one argument
16392 Check_Arg_Count
(1);
16393 Check_Arg_Is_Local_Name
(Arg1
);
16394 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
16395 Set_Is_Implementation_Defined
(Ent
);
16397 end Implementation_Defined
;
16403 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
16405 -- IMPLEMENTATION_KIND ::=
16406 -- By_Entry | By_Protected_Procedure | By_Any | Optional
16408 -- "By_Any" and "Optional" are treated as synonyms in order to
16409 -- support Ada 2012 aspect Synchronization.
16411 when Pragma_Implemented
=> Implemented
: declare
16412 Proc_Id
: Entity_Id
;
16417 Check_Arg_Count
(2);
16418 Check_No_Identifiers
;
16419 Check_Arg_Is_Identifier
(Arg1
);
16420 Check_Arg_Is_Local_Name
(Arg1
);
16421 Check_Arg_Is_One_Of
(Arg2
,
16424 Name_By_Protected_Procedure
,
16427 -- Extract the name of the local procedure
16429 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
16431 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
16432 -- primitive procedure of a synchronized tagged type.
16434 if Ekind
(Proc_Id
) = E_Procedure
16435 and then Is_Primitive
(Proc_Id
)
16436 and then Present
(First_Formal
(Proc_Id
))
16438 Typ
:= Etype
(First_Formal
(Proc_Id
));
16440 if Is_Tagged_Type
(Typ
)
16443 -- Check for a protected, a synchronized or a task interface
16445 ((Is_Interface
(Typ
)
16446 and then Is_Synchronized_Interface
(Typ
))
16448 -- Check for a protected type or a task type that implements
16452 (Is_Concurrent_Record_Type
(Typ
)
16453 and then Present
(Interfaces
(Typ
)))
16455 -- In analysis-only mode, examine original protected type
16458 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
16459 and then Present
(Interface_List
(Parent
(Typ
))))
16461 -- Check for a private record extension with keyword
16465 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
16466 E_Record_Subtype_With_Private
)
16467 and then Synchronized_Present
(Parent
(Typ
))))
16472 ("controlling formal must be of synchronized tagged type",
16477 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16478 -- By_Protected_Procedure to the primitive procedure of a task
16481 if Chars
(Arg2
) = Name_By_Protected_Procedure
16482 and then Is_Interface
(Typ
)
16483 and then Is_Task_Interface
(Typ
)
16486 ("implementation kind By_Protected_Procedure cannot be "
16487 & "applied to a task interface primitive", Arg2
);
16491 -- Procedures declared inside a protected type must be accepted
16493 elsif Ekind
(Proc_Id
) = E_Procedure
16494 and then Is_Protected_Type
(Scope
(Proc_Id
))
16498 -- The first argument is not a primitive procedure
16502 ("pragma % must be applied to a primitive procedure", Arg1
);
16506 Record_Rep_Item
(Proc_Id
, N
);
16509 ----------------------
16510 -- Implicit_Packing --
16511 ----------------------
16513 -- pragma Implicit_Packing;
16515 when Pragma_Implicit_Packing
=>
16517 Check_Arg_Count
(0);
16518 Implicit_Packing
:= True;
16525 -- [Convention =>] convention_IDENTIFIER,
16526 -- [Entity =>] LOCAL_NAME
16527 -- [, [External_Name =>] static_string_EXPRESSION ]
16528 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16530 when Pragma_Import
=>
16531 Check_Ada_83_Warning
;
16535 Name_External_Name
,
16538 Check_At_Least_N_Arguments
(2);
16539 Check_At_Most_N_Arguments
(4);
16540 Process_Import_Or_Interface
;
16542 ---------------------
16543 -- Import_Function --
16544 ---------------------
16546 -- pragma Import_Function (
16547 -- [Internal =>] LOCAL_NAME,
16548 -- [, [External =>] EXTERNAL_SYMBOL]
16549 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16550 -- [, [Result_Type =>] SUBTYPE_MARK]
16551 -- [, [Mechanism =>] MECHANISM]
16552 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16554 -- EXTERNAL_SYMBOL ::=
16556 -- | static_string_EXPRESSION
16558 -- PARAMETER_TYPES ::=
16560 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16562 -- TYPE_DESIGNATOR ::=
16564 -- | subtype_Name ' Access
16568 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16570 -- MECHANISM_ASSOCIATION ::=
16571 -- [formal_parameter_NAME =>] MECHANISM_NAME
16573 -- MECHANISM_NAME ::=
16577 when Pragma_Import_Function
=> Import_Function
: declare
16578 Args
: Args_List
(1 .. 6);
16579 Names
: constant Name_List
(1 .. 6) := (
16582 Name_Parameter_Types
,
16585 Name_Result_Mechanism
);
16587 Internal
: Node_Id
renames Args
(1);
16588 External
: Node_Id
renames Args
(2);
16589 Parameter_Types
: Node_Id
renames Args
(3);
16590 Result_Type
: Node_Id
renames Args
(4);
16591 Mechanism
: Node_Id
renames Args
(5);
16592 Result_Mechanism
: Node_Id
renames Args
(6);
16596 Gather_Associations
(Names
, Args
);
16597 Process_Extended_Import_Export_Subprogram_Pragma
(
16598 Arg_Internal
=> Internal
,
16599 Arg_External
=> External
,
16600 Arg_Parameter_Types
=> Parameter_Types
,
16601 Arg_Result_Type
=> Result_Type
,
16602 Arg_Mechanism
=> Mechanism
,
16603 Arg_Result_Mechanism
=> Result_Mechanism
);
16604 end Import_Function
;
16606 -------------------
16607 -- Import_Object --
16608 -------------------
16610 -- pragma Import_Object (
16611 -- [Internal =>] LOCAL_NAME
16612 -- [, [External =>] EXTERNAL_SYMBOL]
16613 -- [, [Size =>] EXTERNAL_SYMBOL]);
16615 -- EXTERNAL_SYMBOL ::=
16617 -- | static_string_EXPRESSION
16619 when Pragma_Import_Object
=> Import_Object
: declare
16620 Args
: Args_List
(1 .. 3);
16621 Names
: constant Name_List
(1 .. 3) := (
16626 Internal
: Node_Id
renames Args
(1);
16627 External
: Node_Id
renames Args
(2);
16628 Size
: Node_Id
renames Args
(3);
16632 Gather_Associations
(Names
, Args
);
16633 Process_Extended_Import_Export_Object_Pragma
(
16634 Arg_Internal
=> Internal
,
16635 Arg_External
=> External
,
16639 ----------------------
16640 -- Import_Procedure --
16641 ----------------------
16643 -- pragma Import_Procedure (
16644 -- [Internal =>] LOCAL_NAME
16645 -- [, [External =>] EXTERNAL_SYMBOL]
16646 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16647 -- [, [Mechanism =>] MECHANISM]);
16649 -- EXTERNAL_SYMBOL ::=
16651 -- | static_string_EXPRESSION
16653 -- PARAMETER_TYPES ::=
16655 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16657 -- TYPE_DESIGNATOR ::=
16659 -- | subtype_Name ' Access
16663 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16665 -- MECHANISM_ASSOCIATION ::=
16666 -- [formal_parameter_NAME =>] MECHANISM_NAME
16668 -- MECHANISM_NAME ::=
16672 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16673 Args
: Args_List
(1 .. 4);
16674 Names
: constant Name_List
(1 .. 4) := (
16677 Name_Parameter_Types
,
16680 Internal
: Node_Id
renames Args
(1);
16681 External
: Node_Id
renames Args
(2);
16682 Parameter_Types
: Node_Id
renames Args
(3);
16683 Mechanism
: Node_Id
renames Args
(4);
16687 Gather_Associations
(Names
, Args
);
16688 Process_Extended_Import_Export_Subprogram_Pragma
(
16689 Arg_Internal
=> Internal
,
16690 Arg_External
=> External
,
16691 Arg_Parameter_Types
=> Parameter_Types
,
16692 Arg_Mechanism
=> Mechanism
);
16693 end Import_Procedure
;
16695 -----------------------------
16696 -- Import_Valued_Procedure --
16697 -----------------------------
16699 -- pragma Import_Valued_Procedure (
16700 -- [Internal =>] LOCAL_NAME
16701 -- [, [External =>] EXTERNAL_SYMBOL]
16702 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16703 -- [, [Mechanism =>] MECHANISM]);
16705 -- EXTERNAL_SYMBOL ::=
16707 -- | static_string_EXPRESSION
16709 -- PARAMETER_TYPES ::=
16711 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16713 -- TYPE_DESIGNATOR ::=
16715 -- | subtype_Name ' Access
16719 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16721 -- MECHANISM_ASSOCIATION ::=
16722 -- [formal_parameter_NAME =>] MECHANISM_NAME
16724 -- MECHANISM_NAME ::=
16728 when Pragma_Import_Valued_Procedure
=>
16729 Import_Valued_Procedure
: declare
16730 Args
: Args_List
(1 .. 4);
16731 Names
: constant Name_List
(1 .. 4) := (
16734 Name_Parameter_Types
,
16737 Internal
: Node_Id
renames Args
(1);
16738 External
: Node_Id
renames Args
(2);
16739 Parameter_Types
: Node_Id
renames Args
(3);
16740 Mechanism
: Node_Id
renames Args
(4);
16744 Gather_Associations
(Names
, Args
);
16745 Process_Extended_Import_Export_Subprogram_Pragma
(
16746 Arg_Internal
=> Internal
,
16747 Arg_External
=> External
,
16748 Arg_Parameter_Types
=> Parameter_Types
,
16749 Arg_Mechanism
=> Mechanism
);
16750 end Import_Valued_Procedure
;
16756 -- pragma Independent (LOCAL_NAME);
16758 when Pragma_Independent
=>
16759 Process_Atomic_Independent_Shared_Volatile
;
16761 ----------------------------
16762 -- Independent_Components --
16763 ----------------------------
16765 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16767 when Pragma_Independent_Components
=> Independent_Components
: declare
16775 Check_Ada_83_Warning
;
16777 Check_No_Identifiers
;
16778 Check_Arg_Count
(1);
16779 Check_Arg_Is_Local_Name
(Arg1
);
16780 E_Id
:= Get_Pragma_Arg
(Arg1
);
16782 if Etype
(E_Id
) = Any_Type
then
16786 E
:= Entity
(E_Id
);
16788 -- A pragma that applies to a Ghost entity becomes Ghost for the
16789 -- purposes of legality checks and removal of ignored Ghost code.
16791 Mark_Ghost_Pragma
(N
, E
);
16793 -- Check duplicate before we chain ourselves
16795 Check_Duplicate_Pragma
(E
);
16797 -- Check appropriate entity
16799 if Rep_Item_Too_Early
(E
, N
)
16801 Rep_Item_Too_Late
(E
, N
)
16806 D
:= Declaration_Node
(E
);
16809 -- The flag is set on the base type, or on the object
16811 if K
= N_Full_Type_Declaration
16812 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16814 Set_Has_Independent_Components
(Base_Type
(E
));
16815 Record_Independence_Check
(N
, Base_Type
(E
));
16817 -- For record type, set all components independent
16819 if Is_Record_Type
(E
) then
16820 C
:= First_Component
(E
);
16821 while Present
(C
) loop
16822 Set_Is_Independent
(C
);
16823 Next_Component
(C
);
16827 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16828 and then Nkind
(D
) = N_Object_Declaration
16829 and then Nkind
(Object_Definition
(D
)) =
16830 N_Constrained_Array_Definition
16832 Set_Has_Independent_Components
(E
);
16833 Record_Independence_Check
(N
, E
);
16836 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16838 end Independent_Components
;
16840 -----------------------
16841 -- Initial_Condition --
16842 -----------------------
16844 -- pragma Initial_Condition (boolean_EXPRESSION);
16846 -- Characteristics:
16848 -- * Analysis - The annotation undergoes initial checks to verify
16849 -- the legal placement and context. Secondary checks preanalyze the
16852 -- Analyze_Initial_Condition_In_Decl_Part
16854 -- * Expansion - The annotation is expanded during the expansion of
16855 -- the package body whose declaration is subject to the annotation
16858 -- Expand_Pragma_Initial_Condition
16860 -- * Template - The annotation utilizes the generic template of the
16861 -- related package declaration.
16863 -- * Globals - Capture of global references must occur after full
16866 -- * Instance - The annotation is instantiated automatically when
16867 -- the related generic package is instantiated.
16869 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16870 Pack_Decl
: Node_Id
;
16871 Pack_Id
: Entity_Id
;
16875 Check_No_Identifiers
;
16876 Check_Arg_Count
(1);
16878 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16880 -- Ensure the proper placement of the pragma. Initial_Condition
16881 -- must be associated with a package declaration.
16883 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16884 N_Package_Declaration
)
16888 -- Otherwise the pragma is associated with an illegal context
16895 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16897 -- A pragma that applies to a Ghost entity becomes Ghost for the
16898 -- purposes of legality checks and removal of ignored Ghost code.
16900 Mark_Ghost_Pragma
(N
, Pack_Id
);
16902 -- Chain the pragma on the contract for further processing by
16903 -- Analyze_Initial_Condition_In_Decl_Part.
16905 Add_Contract_Item
(N
, Pack_Id
);
16907 -- The legality checks of pragmas Abstract_State, Initializes, and
16908 -- Initial_Condition are affected by the SPARK mode in effect. In
16909 -- addition, these three pragmas are subject to an inherent order:
16911 -- 1) Abstract_State
16913 -- 3) Initial_Condition
16915 -- Analyze all these pragmas in the order outlined above
16917 Analyze_If_Present
(Pragma_SPARK_Mode
);
16918 Analyze_If_Present
(Pragma_Abstract_State
);
16919 Analyze_If_Present
(Pragma_Initializes
);
16920 end Initial_Condition
;
16922 ------------------------
16923 -- Initialize_Scalars --
16924 ------------------------
16926 -- pragma Initialize_Scalars;
16928 when Pragma_Initialize_Scalars
=>
16930 Check_Arg_Count
(0);
16931 Check_Valid_Configuration_Pragma
;
16932 Check_Restriction
(No_Initialize_Scalars
, N
);
16934 -- Initialize_Scalars creates false positives in CodePeer, and
16935 -- incorrect negative results in GNATprove mode, so ignore this
16936 -- pragma in these modes.
16938 if not Restriction_Active
(No_Initialize_Scalars
)
16939 and then not (CodePeer_Mode
or GNATprove_Mode
)
16941 Init_Or_Norm_Scalars
:= True;
16942 Initialize_Scalars
:= True;
16949 -- pragma Initializes (INITIALIZATION_LIST);
16951 -- INITIALIZATION_LIST ::=
16953 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16955 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16960 -- | (INPUT {, INPUT})
16964 -- Characteristics:
16966 -- * Analysis - The annotation undergoes initial checks to verify
16967 -- the legal placement and context. Secondary checks preanalyze the
16970 -- Analyze_Initializes_In_Decl_Part
16972 -- * Expansion - None.
16974 -- * Template - The annotation utilizes the generic template of the
16975 -- related package declaration.
16977 -- * Globals - Capture of global references must occur after full
16980 -- * Instance - The annotation is instantiated automatically when
16981 -- the related generic package is instantiated.
16983 when Pragma_Initializes
=> Initializes
: declare
16984 Pack_Decl
: Node_Id
;
16985 Pack_Id
: Entity_Id
;
16989 Check_No_Identifiers
;
16990 Check_Arg_Count
(1);
16992 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16994 -- Ensure the proper placement of the pragma. Initializes must be
16995 -- associated with a package declaration.
16997 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16998 N_Package_Declaration
)
17002 -- Otherwise the pragma is associated with an illegal construc
17009 Pack_Id
:= Defining_Entity
(Pack_Decl
);
17011 -- A pragma that applies to a Ghost entity becomes Ghost for the
17012 -- purposes of legality checks and removal of ignored Ghost code.
17014 Mark_Ghost_Pragma
(N
, Pack_Id
);
17015 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
17017 -- Chain the pragma on the contract for further processing by
17018 -- Analyze_Initializes_In_Decl_Part.
17020 Add_Contract_Item
(N
, Pack_Id
);
17022 -- The legality checks of pragmas Abstract_State, Initializes, and
17023 -- Initial_Condition are affected by the SPARK mode in effect. In
17024 -- addition, these three pragmas are subject to an inherent order:
17026 -- 1) Abstract_State
17028 -- 3) Initial_Condition
17030 -- Analyze all these pragmas in the order outlined above
17032 Analyze_If_Present
(Pragma_SPARK_Mode
);
17033 Analyze_If_Present
(Pragma_Abstract_State
);
17034 Analyze_If_Present
(Pragma_Initial_Condition
);
17041 -- pragma Inline ( NAME {, NAME} );
17043 when Pragma_Inline
=>
17045 -- Pragma always active unless in GNATprove mode. It is disabled
17046 -- in GNATprove mode because frontend inlining is applied
17047 -- independently of pragmas Inline and Inline_Always for
17048 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
17051 if not GNATprove_Mode
then
17053 -- Inline status is Enabled if option -gnatn is specified.
17054 -- However this status determines only the value of the
17055 -- Is_Inlined flag on the subprogram and does not prevent
17056 -- the pragma itself from being recorded for later use,
17057 -- in particular for a later modification of Is_Inlined
17058 -- independently of the -gnatn option.
17060 -- In other words, if -gnatn is specified for a unit, then
17061 -- all Inline pragmas processed for the compilation of this
17062 -- unit, including those in the spec of other units, are
17063 -- activated, so subprograms will be inlined across units.
17065 -- If -gnatn is not specified, no Inline pragma is activated
17066 -- here, which means that subprograms will not be inlined
17067 -- across units. The Is_Inlined flag will nevertheless be
17068 -- set later when bodies are analyzed, so subprograms will
17069 -- be inlined within the unit.
17071 if Inline_Active
then
17072 Process_Inline
(Enabled
);
17074 Process_Inline
(Disabled
);
17078 -------------------
17079 -- Inline_Always --
17080 -------------------
17082 -- pragma Inline_Always ( NAME {, NAME} );
17084 when Pragma_Inline_Always
=>
17087 -- Pragma always active unless in CodePeer mode or GNATprove
17088 -- mode. It is disabled in CodePeer mode because inlining is
17089 -- not helpful, and enabling it caused walk order issues. It
17090 -- is disabled in GNATprove mode because frontend inlining is
17091 -- applied independently of pragmas Inline and Inline_Always for
17092 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
17095 if not CodePeer_Mode
and not GNATprove_Mode
then
17096 Process_Inline
(Enabled
);
17099 --------------------
17100 -- Inline_Generic --
17101 --------------------
17103 -- pragma Inline_Generic (NAME {, NAME});
17105 when Pragma_Inline_Generic
=>
17107 Process_Generic_List
;
17109 ----------------------
17110 -- Inspection_Point --
17111 ----------------------
17113 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
17115 when Pragma_Inspection_Point
=> Inspection_Point
: declare
17122 if Arg_Count
> 0 then
17125 Exp
:= Get_Pragma_Arg
(Arg
);
17128 if not Is_Entity_Name
(Exp
)
17129 or else not Is_Object
(Entity
(Exp
))
17131 Error_Pragma_Arg
("object name required", Arg
);
17135 exit when No
(Arg
);
17138 end Inspection_Point
;
17144 -- pragma Interface (
17145 -- [ Convention =>] convention_IDENTIFIER,
17146 -- [ Entity =>] LOCAL_NAME
17147 -- [, [External_Name =>] static_string_EXPRESSION ]
17148 -- [, [Link_Name =>] static_string_EXPRESSION ]);
17150 when Pragma_Interface
=>
17155 Name_External_Name
,
17157 Check_At_Least_N_Arguments
(2);
17158 Check_At_Most_N_Arguments
(4);
17159 Process_Import_Or_Interface
;
17161 -- In Ada 2005, the permission to use Interface (a reserved word)
17162 -- as a pragma name is considered an obsolescent feature, and this
17163 -- pragma was already obsolescent in Ada 95.
17165 if Ada_Version
>= Ada_95
then
17167 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
17169 if Warn_On_Obsolescent_Feature
then
17171 ("pragma Interface is an obsolescent feature?j?", N
);
17173 ("|use pragma Import instead?j?", N
);
17177 --------------------
17178 -- Interface_Name --
17179 --------------------
17181 -- pragma Interface_Name (
17182 -- [ Entity =>] LOCAL_NAME
17183 -- [,[External_Name =>] static_string_EXPRESSION ]
17184 -- [,[Link_Name =>] static_string_EXPRESSION ]);
17186 when Pragma_Interface_Name
=> Interface_Name
: declare
17188 Def_Id
: Entity_Id
;
17189 Hom_Id
: Entity_Id
;
17195 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
17196 Check_At_Least_N_Arguments
(2);
17197 Check_At_Most_N_Arguments
(3);
17198 Id
:= Get_Pragma_Arg
(Arg1
);
17201 -- This is obsolete from Ada 95 on, but it is an implementation
17202 -- defined pragma, so we do not consider that it violates the
17203 -- restriction (No_Obsolescent_Features).
17205 if Ada_Version
>= Ada_95
then
17206 if Warn_On_Obsolescent_Feature
then
17208 ("pragma Interface_Name is an obsolescent feature?j?", N
);
17210 ("|use pragma Import instead?j?", N
);
17214 if not Is_Entity_Name
(Id
) then
17216 ("first argument for pragma% must be entity name", Arg1
);
17217 elsif Etype
(Id
) = Any_Type
then
17220 Def_Id
:= Entity
(Id
);
17223 -- Special DEC-compatible processing for the object case, forces
17224 -- object to be imported.
17226 if Ekind
(Def_Id
) = E_Variable
then
17227 Kill_Size_Check_Code
(Def_Id
);
17228 Note_Possible_Modification
(Id
, Sure
=> False);
17230 -- Initialization is not allowed for imported variable
17232 if Present
(Expression
(Parent
(Def_Id
)))
17233 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
17235 Error_Msg_Sloc
:= Sloc
(Def_Id
);
17237 ("no initialization allowed for declaration of& #",
17241 -- For compatibility, support VADS usage of providing both
17242 -- pragmas Interface and Interface_Name to obtain the effect
17243 -- of a single Import pragma.
17245 if Is_Imported
(Def_Id
)
17246 and then Present
(First_Rep_Item
(Def_Id
))
17247 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
17248 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
17253 Set_Imported
(Def_Id
);
17256 Set_Is_Public
(Def_Id
);
17257 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17260 -- Otherwise must be subprogram
17262 elsif not Is_Subprogram
(Def_Id
) then
17264 ("argument of pragma% is not subprogram", Arg1
);
17267 Check_At_Most_N_Arguments
(3);
17271 -- Loop through homonyms
17274 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
17276 if Is_Imported
(Def_Id
) then
17277 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
17281 exit when From_Aspect_Specification
(N
);
17282 Hom_Id
:= Homonym
(Hom_Id
);
17284 exit when No
(Hom_Id
)
17285 or else Scope
(Hom_Id
) /= Current_Scope
;
17290 ("argument of pragma% is not imported subprogram",
17294 end Interface_Name
;
17296 -----------------------
17297 -- Interrupt_Handler --
17298 -----------------------
17300 -- pragma Interrupt_Handler (handler_NAME);
17302 when Pragma_Interrupt_Handler
=>
17303 Check_Ada_83_Warning
;
17304 Check_Arg_Count
(1);
17305 Check_No_Identifiers
;
17307 if No_Run_Time_Mode
then
17308 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
17310 Check_Interrupt_Or_Attach_Handler
;
17311 Process_Interrupt_Or_Attach_Handler
;
17314 ------------------------
17315 -- Interrupt_Priority --
17316 ------------------------
17318 -- pragma Interrupt_Priority [(EXPRESSION)];
17320 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
17321 P
: constant Node_Id
:= Parent
(N
);
17326 Check_Ada_83_Warning
;
17328 if Arg_Count
/= 0 then
17329 Arg
:= Get_Pragma_Arg
(Arg1
);
17330 Check_Arg_Count
(1);
17331 Check_No_Identifiers
;
17333 -- The expression must be analyzed in the special manner
17334 -- described in "Handling of Default and Per-Object
17335 -- Expressions" in sem.ads.
17337 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
17340 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
17345 Ent
:= Defining_Identifier
(Parent
(P
));
17347 -- Check duplicate pragma before we chain the pragma in the Rep
17348 -- Item chain of Ent.
17350 Check_Duplicate_Pragma
(Ent
);
17351 Record_Rep_Item
(Ent
, N
);
17353 -- Check the No_Task_At_Interrupt_Priority restriction
17355 if Nkind
(P
) = N_Task_Definition
then
17356 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
17359 end Interrupt_Priority
;
17361 ---------------------
17362 -- Interrupt_State --
17363 ---------------------
17365 -- pragma Interrupt_State (
17366 -- [Name =>] INTERRUPT_ID,
17367 -- [State =>] INTERRUPT_STATE);
17369 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
17370 -- INTERRUPT_STATE => System | Runtime | User
17372 -- Note: if the interrupt id is given as an identifier, then it must
17373 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
17374 -- given as a static integer expression which must be in the range of
17375 -- Ada.Interrupts.Interrupt_ID.
17377 when Pragma_Interrupt_State
=> Interrupt_State
: declare
17378 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
17379 -- This is the entity Ada.Interrupts.Interrupt_ID;
17381 State_Type
: Character;
17382 -- Set to 's'/'r'/'u' for System/Runtime/User
17385 -- Index to entry in Interrupt_States table
17388 -- Value of interrupt
17390 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
17391 -- The first argument to the pragma
17393 Int_Ent
: Entity_Id
;
17394 -- Interrupt entity in Ada.Interrupts.Names
17398 Check_Arg_Order
((Name_Name
, Name_State
));
17399 Check_Arg_Count
(2);
17401 Check_Optional_Identifier
(Arg1
, Name_Name
);
17402 Check_Optional_Identifier
(Arg2
, Name_State
);
17403 Check_Arg_Is_Identifier
(Arg2
);
17405 -- First argument is identifier
17407 if Nkind
(Arg1X
) = N_Identifier
then
17409 -- Search list of names in Ada.Interrupts.Names
17411 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
17413 if No
(Int_Ent
) then
17414 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
17416 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
17417 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
17421 Next_Entity
(Int_Ent
);
17424 -- First argument is not an identifier, so it must be a static
17425 -- expression of type Ada.Interrupts.Interrupt_ID.
17428 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
17429 Int_Val
:= Expr_Value
(Arg1X
);
17431 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
17433 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
17436 ("value not in range of type "
17437 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
17443 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17444 when Name_Runtime
=> State_Type
:= 'r';
17445 when Name_System
=> State_Type
:= 's';
17446 when Name_User
=> State_Type
:= 'u';
17449 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
17452 -- Check if entry is already stored
17454 IST_Num
:= Interrupt_States
.First
;
17456 -- If entry not found, add it
17458 if IST_Num
> Interrupt_States
.Last
then
17459 Interrupt_States
.Append
17460 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
17461 Interrupt_State
=> State_Type
,
17462 Pragma_Loc
=> Loc
));
17465 -- Case of entry for the same entry
17467 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
17470 -- If state matches, done, no need to make redundant entry
17473 State_Type
= Interrupt_States
.Table
(IST_Num
).
17476 -- Otherwise if state does not match, error
17479 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
17481 ("state conflicts with that given #", Arg2
);
17485 IST_Num
:= IST_Num
+ 1;
17487 end Interrupt_State
;
17493 -- pragma Invariant
17494 -- ([Entity =>] type_LOCAL_NAME,
17495 -- [Check =>] EXPRESSION
17496 -- [,[Message =>] String_Expression]);
17498 when Pragma_Invariant
=> Invariant
: declare
17505 Check_At_Least_N_Arguments
(2);
17506 Check_At_Most_N_Arguments
(3);
17507 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17508 Check_Optional_Identifier
(Arg2
, Name_Check
);
17510 if Arg_Count
= 3 then
17511 Check_Optional_Identifier
(Arg3
, Name_Message
);
17512 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
17515 Check_Arg_Is_Local_Name
(Arg1
);
17517 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
17518 Find_Type
(Typ_Arg
);
17519 Typ
:= Entity
(Typ_Arg
);
17521 -- Nothing to do of the related type is erroneous in some way
17523 if Typ
= Any_Type
then
17526 -- AI12-0041: Invariants are allowed in interface types
17528 elsif Is_Interface
(Typ
) then
17531 -- An invariant must apply to a private type, or appear in the
17532 -- private part of a package spec and apply to a completion.
17533 -- a class-wide invariant can only appear on a private declaration
17534 -- or private extension, not a completion.
17536 -- A [class-wide] invariant may be associated a [limited] private
17537 -- type or a private extension.
17539 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
17541 E_Record_Type_With_Private
)
17545 -- A non-class-wide invariant may be associated with the full view
17546 -- of a [limited] private type or a private extension.
17548 elsif Has_Private_Declaration
(Typ
)
17549 and then not Class_Present
(N
)
17553 -- A class-wide invariant may appear on the partial view only
17555 elsif Class_Present
(N
) then
17557 ("pragma % only allowed for private type", Arg1
);
17560 -- A regular invariant may appear on both views
17564 ("pragma % only allowed for private type or corresponding "
17565 & "full view", Arg1
);
17569 -- An invariant associated with an abstract type (this includes
17570 -- interfaces) must be class-wide.
17572 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
17574 ("pragma % not allowed for abstract type", Arg1
);
17578 -- A pragma that applies to a Ghost entity becomes Ghost for the
17579 -- purposes of legality checks and removal of ignored Ghost code.
17581 Mark_Ghost_Pragma
(N
, Typ
);
17583 -- The pragma defines a type-specific invariant, the type is said
17584 -- to have invariants of its "own".
17586 Set_Has_Own_Invariants
(Typ
);
17588 -- If the invariant is class-wide, then it can be inherited by
17589 -- derived or interface implementing types. The type is said to
17590 -- have "inheritable" invariants.
17592 if Class_Present
(N
) then
17593 Set_Has_Inheritable_Invariants
(Typ
);
17596 -- Chain the pragma on to the rep item chain, for processing when
17597 -- the type is frozen.
17599 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17601 -- Create the declaration of the invariant procedure that will
17602 -- verify the invariant at run time. Interfaces are treated as the
17603 -- partial view of a private type in order to achieve uniformity
17604 -- with the general case. As a result, an interface receives only
17605 -- a "partial" invariant procedure, which is never called.
17607 Build_Invariant_Procedure_Declaration
17609 Partial_Invariant
=> Is_Interface
(Typ
));
17616 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17618 when Pragma_Keep_Names
=> Keep_Names
: declare
17623 Check_Arg_Count
(1);
17624 Check_Optional_Identifier
(Arg1
, Name_On
);
17625 Check_Arg_Is_Local_Name
(Arg1
);
17627 Arg
:= Get_Pragma_Arg
(Arg1
);
17630 if Etype
(Arg
) = Any_Type
then
17634 if not Is_Entity_Name
(Arg
)
17635 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
17638 ("pragma% requires a local enumeration type", Arg1
);
17641 Set_Discard_Names
(Entity
(Arg
), False);
17648 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17650 when Pragma_License
=>
17653 -- Do not analyze pragma any further in CodePeer mode, to avoid
17654 -- extraneous errors in this implementation-dependent pragma,
17655 -- which has a different profile on other compilers.
17657 if CodePeer_Mode
then
17661 Check_Arg_Count
(1);
17662 Check_No_Identifiers
;
17663 Check_Valid_Configuration_Pragma
;
17664 Check_Arg_Is_Identifier
(Arg1
);
17667 Sind
: constant Source_File_Index
:=
17668 Source_Index
(Current_Sem_Unit
);
17671 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17673 Set_License
(Sind
, GPL
);
17675 when Name_Modified_GPL
=>
17676 Set_License
(Sind
, Modified_GPL
);
17678 when Name_Restricted
=>
17679 Set_License
(Sind
, Restricted
);
17681 when Name_Unrestricted
=>
17682 Set_License
(Sind
, Unrestricted
);
17685 Error_Pragma_Arg
("invalid license name", Arg1
);
17693 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17695 when Pragma_Link_With
=> Link_With
: declare
17701 if Operating_Mode
= Generate_Code
17702 and then In_Extended_Main_Source_Unit
(N
)
17704 Check_At_Least_N_Arguments
(1);
17705 Check_No_Identifiers
;
17706 Check_Is_In_Decl_Part_Or_Package_Spec
;
17707 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17711 while Present
(Arg
) loop
17712 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17714 -- Store argument, converting sequences of spaces to a
17715 -- single null character (this is one of the differences
17716 -- in processing between Link_With and Linker_Options).
17718 Arg_Store
: declare
17719 C
: constant Char_Code
:= Get_Char_Code
(' ');
17720 S
: constant String_Id
:=
17721 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17722 L
: constant Nat
:= String_Length
(S
);
17725 procedure Skip_Spaces
;
17726 -- Advance F past any spaces
17732 procedure Skip_Spaces
is
17734 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17739 -- Start of processing for Arg_Store
17742 Skip_Spaces
; -- skip leading spaces
17744 -- Loop through characters, changing any embedded
17745 -- sequence of spaces to a single null character (this
17746 -- is how Link_With/Linker_Options differ)
17749 if Get_String_Char
(S
, F
) = C
then
17752 Store_String_Char
(ASCII
.NUL
);
17755 Store_String_Char
(Get_String_Char
(S
, F
));
17763 if Present
(Arg
) then
17764 Store_String_Char
(ASCII
.NUL
);
17768 Store_Linker_Option_String
(End_String
);
17776 -- pragma Linker_Alias (
17777 -- [Entity =>] LOCAL_NAME
17778 -- [Target =>] static_string_EXPRESSION);
17780 when Pragma_Linker_Alias
=>
17782 Check_Arg_Order
((Name_Entity
, Name_Target
));
17783 Check_Arg_Count
(2);
17784 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17785 Check_Optional_Identifier
(Arg2
, Name_Target
);
17786 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17787 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17789 -- The only processing required is to link this item on to the
17790 -- list of rep items for the given entity. This is accomplished
17791 -- by the call to Rep_Item_Too_Late (when no error is detected
17792 -- and False is returned).
17794 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17797 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17800 ------------------------
17801 -- Linker_Constructor --
17802 ------------------------
17804 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17806 -- Code is shared with Linker_Destructor
17808 -----------------------
17809 -- Linker_Destructor --
17810 -----------------------
17812 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17814 when Pragma_Linker_Constructor
17815 | Pragma_Linker_Destructor
17817 Linker_Constructor
: declare
17823 Check_Arg_Count
(1);
17824 Check_No_Identifiers
;
17825 Check_Arg_Is_Local_Name
(Arg1
);
17826 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17828 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17830 if not Is_Library_Level_Entity
(Proc
) then
17832 ("argument for pragma% must be library level entity", Arg1
);
17835 -- The only processing required is to link this item on to the
17836 -- list of rep items for the given entity. This is accomplished
17837 -- by the call to Rep_Item_Too_Late (when no error is detected
17838 -- and False is returned).
17840 if Rep_Item_Too_Late
(Proc
, N
) then
17843 Set_Has_Gigi_Rep_Item
(Proc
);
17845 end Linker_Constructor
;
17847 --------------------
17848 -- Linker_Options --
17849 --------------------
17851 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17853 when Pragma_Linker_Options
=> Linker_Options
: declare
17857 Check_Ada_83_Warning
;
17858 Check_No_Identifiers
;
17859 Check_Arg_Count
(1);
17860 Check_Is_In_Decl_Part_Or_Package_Spec
;
17861 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17862 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17865 while Present
(Arg
) loop
17866 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17867 Store_String_Char
(ASCII
.NUL
);
17869 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17873 if Operating_Mode
= Generate_Code
17874 and then In_Extended_Main_Source_Unit
(N
)
17876 Store_Linker_Option_String
(End_String
);
17878 end Linker_Options
;
17880 --------------------
17881 -- Linker_Section --
17882 --------------------
17884 -- pragma Linker_Section (
17885 -- [Entity =>] LOCAL_NAME
17886 -- [Section =>] static_string_EXPRESSION);
17888 when Pragma_Linker_Section
=> Linker_Section
: declare
17893 Ghost_Error_Posted
: Boolean := False;
17894 -- Flag set when an error concerning the illegal mix of Ghost and
17895 -- non-Ghost subprograms is emitted.
17897 Ghost_Id
: Entity_Id
:= Empty
;
17898 -- The entity of the first Ghost subprogram encountered while
17899 -- processing the arguments of the pragma.
17903 Check_Arg_Order
((Name_Entity
, Name_Section
));
17904 Check_Arg_Count
(2);
17905 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17906 Check_Optional_Identifier
(Arg2
, Name_Section
);
17907 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17908 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17910 -- Check kind of entity
17912 Arg
:= Get_Pragma_Arg
(Arg1
);
17913 Ent
:= Entity
(Arg
);
17915 case Ekind
(Ent
) is
17917 -- Objects (constants and variables) and types. For these cases
17918 -- all we need to do is to set the Linker_Section_pragma field,
17919 -- checking that we do not have a duplicate.
17925 LPE
:= Linker_Section_Pragma
(Ent
);
17927 if Present
(LPE
) then
17928 Error_Msg_Sloc
:= Sloc
(LPE
);
17930 ("Linker_Section already specified for &#", Arg1
, Ent
);
17933 Set_Linker_Section_Pragma
(Ent
, N
);
17935 -- A pragma that applies to a Ghost entity becomes Ghost for
17936 -- the purposes of legality checks and removal of ignored
17939 Mark_Ghost_Pragma
(N
, Ent
);
17943 when Subprogram_Kind
=>
17945 -- Aspect case, entity already set
17947 if From_Aspect_Specification
(N
) then
17948 Set_Linker_Section_Pragma
17949 (Entity
(Corresponding_Aspect
(N
)), N
);
17951 -- Pragma case, we must climb the homonym chain, but skip
17952 -- any for which the linker section is already set.
17956 if No
(Linker_Section_Pragma
(Ent
)) then
17957 Set_Linker_Section_Pragma
(Ent
, N
);
17959 -- A pragma that applies to a Ghost entity becomes
17960 -- Ghost for the purposes of legality checks and
17961 -- removal of ignored Ghost code.
17963 Mark_Ghost_Pragma
(N
, Ent
);
17965 -- Capture the entity of the first Ghost subprogram
17966 -- being processed for error detection purposes.
17968 if Is_Ghost_Entity
(Ent
) then
17969 if No
(Ghost_Id
) then
17973 -- Otherwise the subprogram is non-Ghost. It is
17974 -- illegal to mix references to Ghost and non-Ghost
17975 -- entities (SPARK RM 6.9).
17977 elsif Present
(Ghost_Id
)
17978 and then not Ghost_Error_Posted
17980 Ghost_Error_Posted
:= True;
17982 Error_Msg_Name_1
:= Pname
;
17984 ("pragma % cannot mention ghost and "
17985 & "non-ghost subprograms", N
);
17987 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17989 ("\& # declared as ghost", N
, Ghost_Id
);
17991 Error_Msg_Sloc
:= Sloc
(Ent
);
17993 ("\& # declared as non-ghost", N
, Ent
);
17997 Ent
:= Homonym
(Ent
);
17999 or else Scope
(Ent
) /= Current_Scope
;
18003 -- All other cases are illegal
18007 ("pragma% applies only to objects, subprograms, and types",
18010 end Linker_Section
;
18016 -- pragma List (On | Off)
18018 -- There is nothing to do here, since we did all the processing for
18019 -- this pragma in Par.Prag (so that it works properly even in syntax
18022 when Pragma_List
=>
18029 -- pragma Lock_Free [(Boolean_EXPRESSION)];
18031 when Pragma_Lock_Free
=> Lock_Free
: declare
18032 P
: constant Node_Id
:= Parent
(N
);
18038 Check_No_Identifiers
;
18039 Check_At_Most_N_Arguments
(1);
18041 -- Protected definition case
18043 if Nkind
(P
) = N_Protected_Definition
then
18044 Ent
:= Defining_Identifier
(Parent
(P
));
18048 if Arg_Count
= 1 then
18049 Arg
:= Get_Pragma_Arg
(Arg1
);
18050 Val
:= Is_True
(Static_Boolean
(Arg
));
18052 -- No arguments (expression is considered to be True)
18058 -- Check duplicate pragma before we chain the pragma in the Rep
18059 -- Item chain of Ent.
18061 Check_Duplicate_Pragma
(Ent
);
18062 Record_Rep_Item
(Ent
, N
);
18063 Set_Uses_Lock_Free
(Ent
, Val
);
18065 -- Anything else is incorrect placement
18072 --------------------
18073 -- Locking_Policy --
18074 --------------------
18076 -- pragma Locking_Policy (policy_IDENTIFIER);
18078 when Pragma_Locking_Policy
=> declare
18079 subtype LP_Range
is Name_Id
18080 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
18085 Check_Ada_83_Warning
;
18086 Check_Arg_Count
(1);
18087 Check_No_Identifiers
;
18088 Check_Arg_Is_Locking_Policy
(Arg1
);
18089 Check_Valid_Configuration_Pragma
;
18090 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18093 when Name_Ceiling_Locking
=> LP
:= 'C';
18094 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
18095 when Name_Inheritance_Locking
=> LP
:= 'I';
18098 if Locking_Policy
/= ' '
18099 and then Locking_Policy
/= LP
18101 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
18102 Error_Pragma
("locking policy incompatible with policy#");
18104 -- Set new policy, but always preserve System_Location since we
18105 -- like the error message with the run time name.
18108 Locking_Policy
:= LP
;
18110 if Locking_Policy_Sloc
/= System_Location
then
18111 Locking_Policy_Sloc
:= Loc
;
18116 -------------------
18117 -- Loop_Optimize --
18118 -------------------
18120 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
18122 -- OPTIMIZATION_HINT ::=
18123 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
18125 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
18130 Check_At_Least_N_Arguments
(1);
18131 Check_No_Identifiers
;
18133 Hint
:= First
(Pragma_Argument_Associations
(N
));
18134 while Present
(Hint
) loop
18135 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
18143 Check_Loop_Pragma_Placement
;
18150 -- pragma Loop_Variant
18151 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
18153 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
18155 -- CHANGE_DIRECTION ::= Increases | Decreases
18157 when Pragma_Loop_Variant
=> Loop_Variant
: declare
18162 Check_At_Least_N_Arguments
(1);
18163 Check_Loop_Pragma_Placement
;
18165 -- Process all increasing / decreasing expressions
18167 Variant
:= First
(Pragma_Argument_Associations
(N
));
18168 while Present
(Variant
) loop
18169 if Chars
(Variant
) = No_Name
then
18170 Error_Pragma_Arg
("expect name `Increases`", Variant
);
18172 elsif not Nam_In
(Chars
(Variant
), Name_Decreases
,
18176 Name
: String := Get_Name_String
(Chars
(Variant
));
18179 -- It is a common mistake to write "Increasing" for
18180 -- "Increases" or "Decreasing" for "Decreases". Recognize
18181 -- specially names starting with "incr" or "decr" to
18182 -- suggest the corresponding name.
18184 System
.Case_Util
.To_Lower
(Name
);
18186 if Name
'Length >= 4
18187 and then Name
(1 .. 4) = "incr"
18189 Error_Pragma_Arg_Ident
18190 ("expect name `Increases`", Variant
);
18192 elsif Name
'Length >= 4
18193 and then Name
(1 .. 4) = "decr"
18195 Error_Pragma_Arg_Ident
18196 ("expect name `Decreases`", Variant
);
18199 Error_Pragma_Arg_Ident
18200 ("expect name `Increases` or `Decreases`", Variant
);
18205 Preanalyze_Assert_Expression
18206 (Expression
(Variant
), Any_Discrete
);
18212 -----------------------
18213 -- Machine_Attribute --
18214 -----------------------
18216 -- pragma Machine_Attribute (
18217 -- [Entity =>] LOCAL_NAME,
18218 -- [Attribute_Name =>] static_string_EXPRESSION
18219 -- [, [Info =>] static_EXPRESSION] );
18221 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
18222 Def_Id
: Entity_Id
;
18226 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
18228 if Arg_Count
= 3 then
18229 Check_Optional_Identifier
(Arg3
, Name_Info
);
18230 Check_Arg_Is_OK_Static_Expression
(Arg3
);
18232 Check_Arg_Count
(2);
18235 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18236 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
18237 Check_Arg_Is_Local_Name
(Arg1
);
18238 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
18239 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18241 if Is_Access_Type
(Def_Id
) then
18242 Def_Id
:= Designated_Type
(Def_Id
);
18245 if Rep_Item_Too_Early
(Def_Id
, N
) then
18249 Def_Id
:= Underlying_Type
(Def_Id
);
18251 -- The only processing required is to link this item on to the
18252 -- list of rep items for the given entity. This is accomplished
18253 -- by the call to Rep_Item_Too_Late (when no error is detected
18254 -- and False is returned).
18256 if Rep_Item_Too_Late
(Def_Id
, N
) then
18259 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
18261 end Machine_Attribute
;
18268 -- (MAIN_OPTION [, MAIN_OPTION]);
18271 -- [STACK_SIZE =>] static_integer_EXPRESSION
18272 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
18273 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
18275 when Pragma_Main
=> Main
: declare
18276 Args
: Args_List
(1 .. 3);
18277 Names
: constant Name_List
(1 .. 3) := (
18279 Name_Task_Stack_Size_Default
,
18280 Name_Time_Slicing_Enabled
);
18286 Gather_Associations
(Names
, Args
);
18288 for J
in 1 .. 2 loop
18289 if Present
(Args
(J
)) then
18290 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18294 if Present
(Args
(3)) then
18295 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
18299 while Present
(Nod
) loop
18300 if Nkind
(Nod
) = N_Pragma
18301 and then Pragma_Name
(Nod
) = Name_Main
18303 Error_Msg_Name_1
:= Pname
;
18304 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18315 -- pragma Main_Storage
18316 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
18318 -- MAIN_STORAGE_OPTION ::=
18319 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
18320 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
18322 when Pragma_Main_Storage
=> Main_Storage
: declare
18323 Args
: Args_List
(1 .. 2);
18324 Names
: constant Name_List
(1 .. 2) := (
18325 Name_Working_Storage
,
18332 Gather_Associations
(Names
, Args
);
18334 for J
in 1 .. 2 loop
18335 if Present
(Args
(J
)) then
18336 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
18340 Check_In_Main_Program
;
18343 while Present
(Nod
) loop
18344 if Nkind
(Nod
) = N_Pragma
18345 and then Pragma_Name
(Nod
) = Name_Main_Storage
18347 Error_Msg_Name_1
:= Pname
;
18348 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
18355 ----------------------
18356 -- Max_Queue_Length --
18357 ----------------------
18359 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
18361 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
18363 Entry_Decl
: Node_Id
;
18364 Entry_Id
: Entity_Id
;
18369 Check_Arg_Count
(1);
18372 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
18374 -- Entry declaration
18376 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
18378 -- Entry illegally within a task
18380 if Nkind
(Parent
(N
)) = N_Task_Definition
then
18381 Error_Pragma
("pragma % cannot apply to task entries");
18385 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
18387 -- Otherwise the pragma is associated with an illegal construct
18390 Error_Pragma
("pragma % must apply to a protected entry");
18394 -- Mark the pragma as Ghost if the related subprogram is also
18395 -- Ghost. This also ensures that any expansion performed further
18396 -- below will produce Ghost nodes.
18398 Mark_Ghost_Pragma
(N
, Entry_Id
);
18400 -- Analyze the Integer expression
18402 Arg
:= Get_Pragma_Arg
(Arg1
);
18403 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
18405 Val
:= Expr_Value
(Arg
);
18409 ("argument for pragma% must be positive", Arg1
);
18411 elsif not UI_Is_In_Int_Range
(Val
) then
18413 ("argument for pragma% out of range of Integer", Arg1
);
18417 -- Manually substitute the expression value of the pragma argument
18418 -- if it's not an integer literal because this is not taken care
18419 -- of automatically elsewhere.
18421 if Nkind
(Arg
) /= N_Integer_Literal
then
18422 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
18425 Record_Rep_Item
(Entry_Id
, N
);
18426 end Max_Queue_Length
;
18432 -- pragma Memory_Size (NUMERIC_LITERAL)
18434 when Pragma_Memory_Size
=>
18437 -- Memory size is simply ignored
18439 Check_No_Identifiers
;
18440 Check_Arg_Count
(1);
18441 Check_Arg_Is_Integer_Literal
(Arg1
);
18449 -- The only correct use of this pragma is on its own in a file, in
18450 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
18451 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
18452 -- check for a file containing nothing but a No_Body pragma). If we
18453 -- attempt to process it during normal semantics processing, it means
18454 -- it was misplaced.
18456 when Pragma_No_Body
=>
18460 -----------------------------
18461 -- No_Elaboration_Code_All --
18462 -----------------------------
18464 -- pragma No_Elaboration_Code_All;
18466 when Pragma_No_Elaboration_Code_All
=>
18468 Check_Valid_Library_Unit_Pragma
;
18470 if Nkind
(N
) = N_Null_Statement
then
18474 -- Must appear for a spec or generic spec
18476 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
18477 N_Generic_Package_Declaration
,
18478 N_Generic_Subprogram_Declaration
,
18479 N_Package_Declaration
,
18480 N_Subprogram_Declaration
)
18484 ("pragma% can only occur for package "
18485 & "or subprogram spec"));
18488 -- Set flag in unit table
18490 Set_No_Elab_Code_All
(Current_Sem_Unit
);
18492 -- Set restriction No_Elaboration_Code if this is the main unit
18494 if Current_Sem_Unit
= Main_Unit
then
18495 Set_Restriction
(No_Elaboration_Code
, N
);
18498 -- If we are in the main unit or in an extended main source unit,
18499 -- then we also add it to the configuration restrictions so that
18500 -- it will apply to all units in the extended main source.
18502 if Current_Sem_Unit
= Main_Unit
18503 or else In_Extended_Main_Source_Unit
(N
)
18505 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
18508 -- If in main extended unit, activate transitive with test
18510 if In_Extended_Main_Source_Unit
(N
) then
18511 Opt
.No_Elab_Code_All_Pragma
:= N
;
18514 -----------------------------
18515 -- No_Component_Reordering --
18516 -----------------------------
18518 -- pragma No_Component_Reordering [([Entity =>] type_LOCAL_NAME)];
18520 when Pragma_No_Component_Reordering
=> No_Comp_Reordering
: declare
18526 Check_At_Most_N_Arguments
(1);
18528 if Arg_Count
= 0 then
18529 Check_Valid_Configuration_Pragma
;
18530 Opt
.No_Component_Reordering
:= True;
18533 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18534 Check_Arg_Is_Local_Name
(Arg1
);
18535 E_Id
:= Get_Pragma_Arg
(Arg1
);
18537 if Etype
(E_Id
) = Any_Type
then
18541 E
:= Entity
(E_Id
);
18543 if not Is_Record_Type
(E
) then
18544 Error_Pragma_Arg
("pragma% requires record type", Arg1
);
18547 Set_No_Reordering
(Base_Type
(E
));
18549 end No_Comp_Reordering
;
18551 --------------------------
18552 -- No_Heap_Finalization --
18553 --------------------------
18555 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18557 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
18558 Context
: constant Node_Id
:= Parent
(N
);
18559 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18565 Check_No_Identifiers
;
18567 -- The pragma appears in a configuration file
18569 if No
(Context
) then
18570 Check_Arg_Count
(0);
18571 Check_Valid_Configuration_Pragma
;
18573 -- Detect a duplicate pragma
18575 if Present
(No_Heap_Finalization_Pragma
) then
18578 Prev
=> No_Heap_Finalization_Pragma
);
18582 No_Heap_Finalization_Pragma
:= N
;
18584 -- Otherwise the pragma should be associated with a library-level
18585 -- named access-to-object type.
18588 Check_Arg_Count
(1);
18589 Check_Arg_Is_Local_Name
(Arg1
);
18591 Find_Type
(Typ_Arg
);
18592 Typ
:= Entity
(Typ_Arg
);
18594 -- The type being subjected to the pragma is erroneous
18596 if Typ
= Any_Type
then
18597 Error_Pragma
("cannot find type referenced by pragma %");
18599 -- The pragma is applied to an incomplete or generic formal
18600 -- type way too early.
18602 elsif Rep_Item_Too_Early
(Typ
, N
) then
18606 Typ
:= Underlying_Type
(Typ
);
18609 -- The pragma must apply to an access-to-object type
18611 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
18614 -- Give a detailed error message on all other access type kinds
18616 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
18618 ("pragma % cannot apply to access protected subprogram "
18621 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
18623 ("pragma % cannot apply to access subprogram type");
18625 elsif Is_Anonymous_Access_Type
(Typ
) then
18627 ("pragma % cannot apply to anonymous access type");
18629 -- Give a general error message in case the pragma applies to a
18630 -- non-access type.
18634 ("pragma % must apply to library level access type");
18637 -- At this point the argument denotes an access-to-object type.
18638 -- Ensure that the type is declared at the library level.
18640 if Is_Library_Level_Entity
(Typ
) then
18643 -- Quietly ignore an access-to-object type originally declared
18644 -- at the library level within a generic, but instantiated at
18645 -- a non-library level. As a result the access-to-object type
18646 -- "loses" its No_Heap_Finalization property.
18648 elsif In_Instance
then
18653 ("pragma % must apply to library level access type");
18656 -- Detect a duplicate pragma
18658 if Present
(No_Heap_Finalization_Pragma
) then
18661 Prev
=> No_Heap_Finalization_Pragma
);
18665 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
18667 if Present
(Prev
) then
18675 Record_Rep_Item
(Typ
, N
);
18677 end No_Heap_Finalization
;
18683 -- pragma No_Inline ( NAME {, NAME} );
18685 when Pragma_No_Inline
=>
18687 Process_Inline
(Suppressed
);
18693 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18695 when Pragma_No_Return
=> No_Return
: declare
18701 Ghost_Error_Posted
: Boolean := False;
18702 -- Flag set when an error concerning the illegal mix of Ghost and
18703 -- non-Ghost subprograms is emitted.
18705 Ghost_Id
: Entity_Id
:= Empty
;
18706 -- The entity of the first Ghost procedure encountered while
18707 -- processing the arguments of the pragma.
18711 Check_At_Least_N_Arguments
(1);
18713 -- Loop through arguments of pragma
18716 while Present
(Arg
) loop
18717 Check_Arg_Is_Local_Name
(Arg
);
18718 Id
:= Get_Pragma_Arg
(Arg
);
18721 if not Is_Entity_Name
(Id
) then
18722 Error_Pragma_Arg
("entity name required", Arg
);
18725 if Etype
(Id
) = Any_Type
then
18729 -- Loop to find matching procedures
18735 and then Scope
(E
) = Current_Scope
18737 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
18739 -- Check that the pragma is not applied to a body.
18740 -- First check the specless body case, to give a
18741 -- different error message. These checks do not apply
18742 -- if Relaxed_RM_Semantics, to accommodate other Ada
18743 -- compilers. Disable these checks under -gnatd.J.
18745 if not Debug_Flag_Dot_JJ
then
18746 if Nkind
(Parent
(Declaration_Node
(E
))) =
18748 and then not Relaxed_RM_Semantics
18751 ("pragma% requires separate spec and must come "
18755 -- Now the "specful" body case
18757 if Rep_Item_Too_Late
(E
, N
) then
18764 -- A pragma that applies to a Ghost entity becomes Ghost
18765 -- for the purposes of legality checks and removal of
18766 -- ignored Ghost code.
18768 Mark_Ghost_Pragma
(N
, E
);
18770 -- Capture the entity of the first Ghost procedure being
18771 -- processed for error detection purposes.
18773 if Is_Ghost_Entity
(E
) then
18774 if No
(Ghost_Id
) then
18778 -- Otherwise the subprogram is non-Ghost. It is illegal
18779 -- to mix references to Ghost and non-Ghost entities
18782 elsif Present
(Ghost_Id
)
18783 and then not Ghost_Error_Posted
18785 Ghost_Error_Posted
:= True;
18787 Error_Msg_Name_1
:= Pname
;
18789 ("pragma % cannot mention ghost and non-ghost "
18790 & "procedures", N
);
18792 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18793 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
18795 Error_Msg_Sloc
:= Sloc
(E
);
18796 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
18799 -- Set flag on any alias as well
18801 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
18802 Set_No_Return
(Alias
(E
));
18808 exit when From_Aspect_Specification
(N
);
18812 -- If entity in not in current scope it may be the enclosing
18813 -- suprogram body to which the aspect applies.
18816 if Entity
(Id
) = Current_Scope
18817 and then From_Aspect_Specification
(N
)
18819 Set_No_Return
(Entity
(Id
));
18821 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
18833 -- pragma No_Run_Time;
18835 -- Note: this pragma is retained for backwards compatibility. See
18836 -- body of Rtsfind for full details on its handling.
18838 when Pragma_No_Run_Time
=>
18840 Check_Valid_Configuration_Pragma
;
18841 Check_Arg_Count
(0);
18843 -- Remove backward compatibility if Build_Type is FSF or GPL and
18844 -- generate a warning.
18847 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
18850 Error_Pragma
("pragma% is ignored, has no effect??");
18852 No_Run_Time_Mode
:= True;
18853 Configurable_Run_Time_Mode
:= True;
18855 -- Set Duration to 32 bits if word size is 32
18857 if Ttypes
.System_Word_Size
= 32 then
18858 Duration_32_Bits_On_Target
:= True;
18861 -- Set appropriate restrictions
18863 Set_Restriction
(No_Finalization
, N
);
18864 Set_Restriction
(No_Exception_Handlers
, N
);
18865 Set_Restriction
(Max_Tasks
, N
, 0);
18866 Set_Restriction
(No_Tasking
, N
);
18870 -----------------------
18871 -- No_Tagged_Streams --
18872 -----------------------
18874 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18876 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
18882 Check_At_Most_N_Arguments
(1);
18884 -- One argument case
18886 if Arg_Count
= 1 then
18887 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18888 Check_Arg_Is_Local_Name
(Arg1
);
18889 E_Id
:= Get_Pragma_Arg
(Arg1
);
18891 if Etype
(E_Id
) = Any_Type
then
18895 E
:= Entity
(E_Id
);
18897 Check_Duplicate_Pragma
(E
);
18899 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
18901 ("argument for pragma% must be root tagged type", Arg1
);
18904 if Rep_Item_Too_Early
(E
, N
)
18906 Rep_Item_Too_Late
(E
, N
)
18910 Set_No_Tagged_Streams_Pragma
(E
, N
);
18913 -- Zero argument case
18916 Check_Is_In_Decl_Part_Or_Package_Spec
;
18917 No_Tagged_Streams
:= N
;
18919 end No_Tagged_Strms
;
18921 ------------------------
18922 -- No_Strict_Aliasing --
18923 ------------------------
18925 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18927 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
18933 Check_At_Most_N_Arguments
(1);
18935 if Arg_Count
= 0 then
18936 Check_Valid_Configuration_Pragma
;
18937 Opt
.No_Strict_Aliasing
:= True;
18940 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18941 Check_Arg_Is_Local_Name
(Arg1
);
18942 E_Id
:= Get_Pragma_Arg
(Arg1
);
18944 if Etype
(E_Id
) = Any_Type
then
18948 E
:= Entity
(E_Id
);
18950 if not Is_Access_Type
(E
) then
18951 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
18954 Set_No_Strict_Aliasing
(Base_Type
(E
));
18956 end No_Strict_Aliasing
;
18958 -----------------------
18959 -- Normalize_Scalars --
18960 -----------------------
18962 -- pragma Normalize_Scalars;
18964 when Pragma_Normalize_Scalars
=>
18965 Check_Ada_83_Warning
;
18966 Check_Arg_Count
(0);
18967 Check_Valid_Configuration_Pragma
;
18969 -- Normalize_Scalars creates false positives in CodePeer, and
18970 -- incorrect negative results in GNATprove mode, so ignore this
18971 -- pragma in these modes.
18973 if not (CodePeer_Mode
or GNATprove_Mode
) then
18974 Normalize_Scalars
:= True;
18975 Init_Or_Norm_Scalars
:= True;
18982 -- pragma Obsolescent;
18984 -- pragma Obsolescent (
18985 -- [Message =>] static_string_EXPRESSION
18986 -- [,[Version =>] Ada_05]]);
18988 -- pragma Obsolescent (
18989 -- [Entity =>] NAME
18990 -- [,[Message =>] static_string_EXPRESSION
18991 -- [,[Version =>] Ada_05]] );
18993 when Pragma_Obsolescent
=> Obsolescent
: declare
18997 procedure Set_Obsolescent
(E
: Entity_Id
);
18998 -- Given an entity Ent, mark it as obsolescent if appropriate
19000 ---------------------
19001 -- Set_Obsolescent --
19002 ---------------------
19004 procedure Set_Obsolescent
(E
: Entity_Id
) is
19013 -- A pragma that applies to a Ghost entity becomes Ghost for
19014 -- the purposes of legality checks and removal of ignored Ghost
19017 Mark_Ghost_Pragma
(N
, E
);
19019 -- Entity name was given
19021 if Present
(Ename
) then
19023 -- If entity name matches, we are fine. Save entity in
19024 -- pragma argument, for ASIS use.
19026 if Chars
(Ename
) = Chars
(Ent
) then
19027 Set_Entity
(Ename
, Ent
);
19028 Generate_Reference
(Ent
, Ename
);
19030 -- If entity name does not match, only possibility is an
19031 -- enumeration literal from an enumeration type declaration.
19033 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
19035 ("pragma % entity name does not match declaration");
19038 Ent
:= First_Literal
(E
);
19042 ("pragma % entity name does not match any "
19043 & "enumeration literal");
19045 elsif Chars
(Ent
) = Chars
(Ename
) then
19046 Set_Entity
(Ename
, Ent
);
19047 Generate_Reference
(Ent
, Ename
);
19051 Ent
:= Next_Literal
(Ent
);
19057 -- Ent points to entity to be marked
19059 if Arg_Count
>= 1 then
19061 -- Deal with static string argument
19063 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
19064 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
19066 for J
in 1 .. String_Length
(S
) loop
19067 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
19069 ("pragma% argument does not allow wide characters",
19074 Obsolescent_Warnings
.Append
19075 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
19077 -- Check for Ada_05 parameter
19079 if Arg_Count
/= 1 then
19080 Check_Arg_Count
(2);
19083 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19086 Check_Arg_Is_Identifier
(Argx
);
19088 if Chars
(Argx
) /= Name_Ada_05
then
19089 Error_Msg_Name_2
:= Name_Ada_05
;
19091 ("only allowed argument for pragma% is %", Argx
);
19094 if Ada_Version_Explicit
< Ada_2005
19095 or else not Warn_On_Ada_2005_Compatibility
19103 -- Set flag if pragma active
19106 Set_Is_Obsolescent
(Ent
);
19110 end Set_Obsolescent
;
19112 -- Start of processing for pragma Obsolescent
19117 Check_At_Most_N_Arguments
(3);
19119 -- See if first argument specifies an entity name
19123 (Chars
(Arg1
) = Name_Entity
19125 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
19127 N_Operator_Symbol
))
19129 Ename
:= Get_Pragma_Arg
(Arg1
);
19131 -- Eliminate first argument, so we can share processing
19135 Arg_Count
:= Arg_Count
- 1;
19137 -- No Entity name argument given
19143 if Arg_Count
>= 1 then
19144 Check_Optional_Identifier
(Arg1
, Name_Message
);
19146 if Arg_Count
= 2 then
19147 Check_Optional_Identifier
(Arg2
, Name_Version
);
19151 -- Get immediately preceding declaration
19154 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
19158 -- Cases where we do not follow anything other than another pragma
19162 -- First case: library level compilation unit declaration with
19163 -- the pragma immediately following the declaration.
19165 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
19167 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
19170 -- Case 2: library unit placement for package
19174 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
19176 if Is_Package_Or_Generic_Package
(Ent
) then
19177 Set_Obsolescent
(Ent
);
19183 -- Cases where we must follow a declaration, including an
19184 -- abstract subprogram declaration, which is not in the
19185 -- other node subtypes.
19188 if Nkind
(Decl
) not in N_Declaration
19189 and then Nkind
(Decl
) not in N_Later_Decl_Item
19190 and then Nkind
(Decl
) not in N_Generic_Declaration
19191 and then Nkind
(Decl
) not in N_Renaming_Declaration
19192 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
19195 ("pragma% misplaced, "
19196 & "must immediately follow a declaration");
19199 Set_Obsolescent
(Defining_Entity
(Decl
));
19209 -- pragma Optimize (Time | Space | Off);
19211 -- The actual check for optimize is done in Gigi. Note that this
19212 -- pragma does not actually change the optimization setting, it
19213 -- simply checks that it is consistent with the pragma.
19215 when Pragma_Optimize
=>
19216 Check_No_Identifiers
;
19217 Check_Arg_Count
(1);
19218 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
19220 ------------------------
19221 -- Optimize_Alignment --
19222 ------------------------
19224 -- pragma Optimize_Alignment (Time | Space | Off);
19226 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
19228 Check_No_Identifiers
;
19229 Check_Arg_Count
(1);
19230 Check_Valid_Configuration_Pragma
;
19233 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
19236 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
19237 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
19238 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
19241 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
19245 -- Set indication that mode is set locally. If we are in fact in a
19246 -- configuration pragma file, this setting is harmless since the
19247 -- switch will get reset anyway at the start of each unit.
19249 Optimize_Alignment_Local
:= True;
19250 end Optimize_Alignment
;
19256 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
19258 when Pragma_Ordered
=> Ordered
: declare
19259 Assoc
: constant Node_Id
:= Arg1
;
19265 Check_No_Identifiers
;
19266 Check_Arg_Count
(1);
19267 Check_Arg_Is_Local_Name
(Arg1
);
19269 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19270 Find_Type
(Type_Id
);
19271 Typ
:= Entity
(Type_Id
);
19273 if Typ
= Any_Type
then
19276 Typ
:= Underlying_Type
(Typ
);
19279 if not Is_Enumeration_Type
(Typ
) then
19280 Error_Pragma
("pragma% must specify enumeration type");
19283 Check_First_Subtype
(Arg1
);
19284 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
19287 -------------------
19288 -- Overflow_Mode --
19289 -------------------
19291 -- pragma Overflow_Mode
19292 -- ([General => ] MODE [, [Assertions => ] MODE]);
19294 -- MODE := STRICT | MINIMIZED | ELIMINATED
19296 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
19297 -- since System.Bignums makes this assumption. This is true of nearly
19298 -- all (all?) targets.
19300 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
19301 function Get_Overflow_Mode
19303 Arg
: Node_Id
) return Overflow_Mode_Type
;
19304 -- Function to process one pragma argument, Arg. If an identifier
19305 -- is present, it must be Name. Mode type is returned if a valid
19306 -- argument exists, otherwise an error is signalled.
19308 -----------------------
19309 -- Get_Overflow_Mode --
19310 -----------------------
19312 function Get_Overflow_Mode
19314 Arg
: Node_Id
) return Overflow_Mode_Type
19316 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
19319 Check_Optional_Identifier
(Arg
, Name
);
19320 Check_Arg_Is_Identifier
(Argx
);
19322 if Chars
(Argx
) = Name_Strict
then
19325 elsif Chars
(Argx
) = Name_Minimized
then
19328 elsif Chars
(Argx
) = Name_Eliminated
then
19329 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
19331 ("Eliminated not implemented on this target", Argx
);
19337 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
19339 end Get_Overflow_Mode
;
19341 -- Start of processing for Overflow_Mode
19345 Check_At_Least_N_Arguments
(1);
19346 Check_At_Most_N_Arguments
(2);
19348 -- Process first argument
19350 Scope_Suppress
.Overflow_Mode_General
:=
19351 Get_Overflow_Mode
(Name_General
, Arg1
);
19353 -- Case of only one argument
19355 if Arg_Count
= 1 then
19356 Scope_Suppress
.Overflow_Mode_Assertions
:=
19357 Scope_Suppress
.Overflow_Mode_General
;
19359 -- Case of two arguments present
19362 Scope_Suppress
.Overflow_Mode_Assertions
:=
19363 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
19367 --------------------------
19368 -- Overriding Renamings --
19369 --------------------------
19371 -- pragma Overriding_Renamings;
19373 when Pragma_Overriding_Renamings
=>
19375 Check_Arg_Count
(0);
19376 Check_Valid_Configuration_Pragma
;
19377 Overriding_Renamings
:= True;
19383 -- pragma Pack (first_subtype_LOCAL_NAME);
19385 when Pragma_Pack
=> Pack
: declare
19386 Assoc
: constant Node_Id
:= Arg1
;
19388 Ignore
: Boolean := False;
19393 Check_No_Identifiers
;
19394 Check_Arg_Count
(1);
19395 Check_Arg_Is_Local_Name
(Arg1
);
19396 Type_Id
:= Get_Pragma_Arg
(Assoc
);
19398 if not Is_Entity_Name
(Type_Id
)
19399 or else not Is_Type
(Entity
(Type_Id
))
19402 ("argument for pragma% must be type or subtype", Arg1
);
19405 Find_Type
(Type_Id
);
19406 Typ
:= Entity
(Type_Id
);
19409 or else Rep_Item_Too_Early
(Typ
, N
)
19413 Typ
:= Underlying_Type
(Typ
);
19416 -- A pragma that applies to a Ghost entity becomes Ghost for the
19417 -- purposes of legality checks and removal of ignored Ghost code.
19419 Mark_Ghost_Pragma
(N
, Typ
);
19421 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
19422 Error_Pragma
("pragma% must specify array or record type");
19425 Check_First_Subtype
(Arg1
);
19426 Check_Duplicate_Pragma
(Typ
);
19430 if Is_Array_Type
(Typ
) then
19431 Ctyp
:= Component_Type
(Typ
);
19433 -- Ignore pack that does nothing
19435 if Known_Static_Esize
(Ctyp
)
19436 and then Known_Static_RM_Size
(Ctyp
)
19437 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
19438 and then Addressable
(Esize
(Ctyp
))
19443 -- Process OK pragma Pack. Note that if there is a separate
19444 -- component clause present, the Pack will be cancelled. This
19445 -- processing is in Freeze.
19447 if not Rep_Item_Too_Late
(Typ
, N
) then
19449 -- In CodePeer mode, we do not need complex front-end
19450 -- expansions related to pragma Pack, so disable handling
19453 if CodePeer_Mode
then
19456 -- Normal case where we do the pack action
19460 Set_Is_Packed
(Base_Type
(Typ
));
19461 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19464 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19468 -- For record types, the pack is always effective
19470 else pragma Assert
(Is_Record_Type
(Typ
));
19471 if not Rep_Item_Too_Late
(Typ
, N
) then
19472 Set_Is_Packed
(Base_Type
(Typ
));
19473 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
19474 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
19485 -- There is nothing to do here, since we did all the processing for
19486 -- this pragma in Par.Prag (so that it works properly even in syntax
19489 when Pragma_Page
=>
19496 -- pragma Part_Of (ABSTRACT_STATE);
19498 -- ABSTRACT_STATE ::= NAME
19500 when Pragma_Part_Of
=> Part_Of
: declare
19501 procedure Propagate_Part_Of
19502 (Pack_Id
: Entity_Id
;
19503 State_Id
: Entity_Id
;
19504 Instance
: Node_Id
);
19505 -- Propagate the Part_Of indicator to all abstract states and
19506 -- objects declared in the visible state space of a package
19507 -- denoted by Pack_Id. State_Id is the encapsulating state.
19508 -- Instance is the package instantiation node.
19510 -----------------------
19511 -- Propagate_Part_Of --
19512 -----------------------
19514 procedure Propagate_Part_Of
19515 (Pack_Id
: Entity_Id
;
19516 State_Id
: Entity_Id
;
19517 Instance
: Node_Id
)
19519 Has_Item
: Boolean := False;
19520 -- Flag set when the visible state space contains at least one
19521 -- abstract state or variable.
19523 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
19524 -- Propagate the Part_Of indicator to all abstract states and
19525 -- objects declared in the visible state space of a package
19526 -- denoted by Pack_Id.
19528 -----------------------
19529 -- Propagate_Part_Of --
19530 -----------------------
19532 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
19533 Constits
: Elist_Id
;
19534 Item_Id
: Entity_Id
;
19537 -- Traverse the entity chain of the package and set relevant
19538 -- attributes of abstract states and objects declared in the
19539 -- visible state space of the package.
19541 Item_Id
:= First_Entity
(Pack_Id
);
19542 while Present
(Item_Id
)
19543 and then not In_Private_Part
(Item_Id
)
19545 -- Do not consider internally generated items
19547 if not Comes_From_Source
(Item_Id
) then
19550 -- The Part_Of indicator turns an abstract state or an
19551 -- object into a constituent of the encapsulating state.
19553 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
19558 Constits
:= Part_Of_Constituents
(State_Id
);
19560 if No
(Constits
) then
19561 Constits
:= New_Elmt_List
;
19562 Set_Part_Of_Constituents
(State_Id
, Constits
);
19565 Append_Elmt
(Item_Id
, Constits
);
19566 Set_Encapsulating_State
(Item_Id
, State_Id
);
19568 -- Recursively handle nested packages and instantiations
19570 elsif Ekind
(Item_Id
) = E_Package
then
19571 Propagate_Part_Of
(Item_Id
);
19574 Next_Entity
(Item_Id
);
19576 end Propagate_Part_Of
;
19578 -- Start of processing for Propagate_Part_Of
19581 Propagate_Part_Of
(Pack_Id
);
19583 -- Detect a package instantiation that is subject to a Part_Of
19584 -- indicator, but has no visible state.
19586 if not Has_Item
then
19588 ("package instantiation & has Part_Of indicator but "
19589 & "lacks visible state", Instance
, Pack_Id
);
19591 end Propagate_Part_Of
;
19595 Constits
: Elist_Id
;
19597 Encap_Id
: Entity_Id
;
19598 Item_Id
: Entity_Id
;
19602 -- Start of processing for Part_Of
19606 Check_No_Identifiers
;
19607 Check_Arg_Count
(1);
19609 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
19611 -- Object declaration
19613 if Nkind
(Stmt
) = N_Object_Declaration
then
19616 -- Package instantiation
19618 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
19621 -- Single concurrent type declaration
19623 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
19626 -- Otherwise the pragma is associated with an illegal construct
19633 -- Extract the entity of the related object declaration or package
19634 -- instantiation. In the case of the instantiation, use the entity
19635 -- of the instance spec.
19637 if Nkind
(Stmt
) = N_Package_Instantiation
then
19638 Stmt
:= Instance_Spec
(Stmt
);
19641 Item_Id
:= Defining_Entity
(Stmt
);
19643 -- A pragma that applies to a Ghost entity becomes Ghost for the
19644 -- purposes of legality checks and removal of ignored Ghost code.
19646 Mark_Ghost_Pragma
(N
, Item_Id
);
19648 -- Chain the pragma on the contract for further processing by
19649 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19651 Add_Contract_Item
(N
, Item_Id
);
19653 -- A variable may act as constituent of a single concurrent type
19654 -- which in turn could be declared after the variable. Due to this
19655 -- discrepancy, the full analysis of indicator Part_Of is delayed
19656 -- until the end of the enclosing declarative region (see routine
19657 -- Analyze_Part_Of_In_Decl_Part).
19659 if Ekind
(Item_Id
) = E_Variable
then
19662 -- Otherwise indicator Part_Of applies to a constant or a package
19666 Encap
:= Get_Pragma_Arg
(Arg1
);
19668 -- Detect any discrepancies between the placement of the
19669 -- constant or package instantiation with respect to state
19670 -- space and the encapsulating state.
19674 Item_Id
=> Item_Id
,
19676 Encap_Id
=> Encap_Id
,
19680 pragma Assert
(Present
(Encap_Id
));
19682 if Ekind
(Item_Id
) = E_Constant
then
19683 Constits
:= Part_Of_Constituents
(Encap_Id
);
19685 if No
(Constits
) then
19686 Constits
:= New_Elmt_List
;
19687 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
19690 Append_Elmt
(Item_Id
, Constits
);
19691 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
19693 -- Propagate the Part_Of indicator to the visible state
19694 -- space of the package instantiation.
19698 (Pack_Id
=> Item_Id
,
19699 State_Id
=> Encap_Id
,
19706 ----------------------------------
19707 -- Partition_Elaboration_Policy --
19708 ----------------------------------
19710 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19712 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
19713 subtype PEP_Range
is Name_Id
19714 range First_Partition_Elaboration_Policy_Name
19715 .. Last_Partition_Elaboration_Policy_Name
;
19716 PEP_Val
: PEP_Range
;
19721 Check_Arg_Count
(1);
19722 Check_No_Identifiers
;
19723 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
19724 Check_Valid_Configuration_Pragma
;
19725 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19728 when Name_Concurrent
=> PEP
:= 'C';
19729 when Name_Sequential
=> PEP
:= 'S';
19732 if Partition_Elaboration_Policy
/= ' '
19733 and then Partition_Elaboration_Policy
/= PEP
19735 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
19737 ("partition elaboration policy incompatible with policy#");
19739 -- Set new policy, but always preserve System_Location since we
19740 -- like the error message with the run time name.
19743 Partition_Elaboration_Policy
:= PEP
;
19745 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
19746 Partition_Elaboration_Policy_Sloc
:= Loc
;
19755 -- pragma Passive [(PASSIVE_FORM)];
19757 -- PASSIVE_FORM ::= Semaphore | No
19759 when Pragma_Passive
=>
19762 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
19763 Error_Pragma
("pragma% must be within task definition");
19766 if Arg_Count
/= 0 then
19767 Check_Arg_Count
(1);
19768 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
19771 ----------------------------------
19772 -- Preelaborable_Initialization --
19773 ----------------------------------
19775 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19777 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
19782 Check_Arg_Count
(1);
19783 Check_No_Identifiers
;
19784 Check_Arg_Is_Identifier
(Arg1
);
19785 Check_Arg_Is_Local_Name
(Arg1
);
19786 Check_First_Subtype
(Arg1
);
19787 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19789 -- A pragma that applies to a Ghost entity becomes Ghost for the
19790 -- purposes of legality checks and removal of ignored Ghost code.
19792 Mark_Ghost_Pragma
(N
, Ent
);
19794 -- The pragma may come from an aspect on a private declaration,
19795 -- even if the freeze point at which this is analyzed in the
19796 -- private part after the full view.
19798 if Has_Private_Declaration
(Ent
)
19799 and then From_Aspect_Specification
(N
)
19803 -- Check appropriate type argument
19805 elsif Is_Private_Type
(Ent
)
19806 or else Is_Protected_Type
(Ent
)
19807 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
19809 -- AI05-0028: The pragma applies to all composite types. Note
19810 -- that we apply this binding interpretation to earlier versions
19811 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19812 -- choice since there are other compilers that do the same.
19814 or else Is_Composite_Type
(Ent
)
19820 ("pragma % can only be applied to private, formal derived, "
19821 & "protected, or composite type", Arg1
);
19824 -- Give an error if the pragma is applied to a protected type that
19825 -- does not qualify (due to having entries, or due to components
19826 -- that do not qualify).
19828 if Is_Protected_Type
(Ent
)
19829 and then not Has_Preelaborable_Initialization
(Ent
)
19832 ("protected type & does not have preelaborable "
19833 & "initialization", Ent
);
19835 -- Otherwise mark the type as definitely having preelaborable
19839 Set_Known_To_Have_Preelab_Init
(Ent
);
19842 if Has_Pragma_Preelab_Init
(Ent
)
19843 and then Warn_On_Redundant_Constructs
19845 Error_Pragma
("?r?duplicate pragma%!");
19847 Set_Has_Pragma_Preelab_Init
(Ent
);
19851 --------------------
19852 -- Persistent_BSS --
19853 --------------------
19855 -- pragma Persistent_BSS [(object_NAME)];
19857 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
19864 Check_At_Most_N_Arguments
(1);
19866 -- Case of application to specific object (one argument)
19868 if Arg_Count
= 1 then
19869 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19871 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
19873 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
19876 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
19879 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19881 -- A pragma that applies to a Ghost entity becomes Ghost for
19882 -- the purposes of legality checks and removal of ignored Ghost
19885 Mark_Ghost_Pragma
(N
, Ent
);
19887 -- Check for duplication before inserting in list of
19888 -- representation items.
19890 Check_Duplicate_Pragma
(Ent
);
19892 if Rep_Item_Too_Late
(Ent
, N
) then
19896 Decl
:= Parent
(Ent
);
19898 if Present
(Expression
(Decl
)) then
19900 ("object for pragma% cannot have initialization", Arg1
);
19903 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
19905 ("object type for pragma% is not potentially persistent",
19910 Make_Linker_Section_Pragma
19911 (Ent
, Sloc
(N
), ".persistent.bss");
19912 Insert_After
(N
, Prag
);
19915 -- Case of use as configuration pragma with no arguments
19918 Check_Valid_Configuration_Pragma
;
19919 Persistent_BSS_Mode
:= True;
19921 end Persistent_BSS
;
19923 --------------------
19924 -- Rename_Pragma --
19925 --------------------
19927 -- pragma Rename_Pragma (
19928 -- [New_Name =>] IDENTIFIER,
19929 -- [Renamed =>] pragma_IDENTIFIER);
19931 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
19932 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19933 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19937 Check_Valid_Configuration_Pragma
;
19938 Check_Arg_Count
(2);
19939 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
19940 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
19942 if Nkind
(New_Name
) /= N_Identifier
then
19943 Error_Pragma_Arg
("identifier expected", Arg1
);
19946 if Nkind
(Old_Name
) /= N_Identifier
then
19947 Error_Pragma_Arg
("identifier expected", Arg2
);
19950 -- The New_Name arg should not be an existing pragma (but we allow
19951 -- it; it's just a warning). The Old_Name arg must be an existing
19954 if Is_Pragma_Name
(Chars
(New_Name
)) then
19955 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
19958 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
19959 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
19962 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
19969 -- pragma Polling (ON | OFF);
19971 when Pragma_Polling
=>
19973 Check_Arg_Count
(1);
19974 Check_No_Identifiers
;
19975 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19976 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
19978 -----------------------------------
19979 -- Post/Post_Class/Postcondition --
19980 -----------------------------------
19982 -- pragma Post (Boolean_EXPRESSION);
19983 -- pragma Post_Class (Boolean_EXPRESSION);
19984 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19985 -- [,[Message =>] String_EXPRESSION]);
19987 -- Characteristics:
19989 -- * Analysis - The annotation undergoes initial checks to verify
19990 -- the legal placement and context. Secondary checks preanalyze the
19993 -- Analyze_Pre_Post_Condition_In_Decl_Part
19995 -- * Expansion - The annotation is expanded during the expansion of
19996 -- the related subprogram [body] contract as performed in:
19998 -- Expand_Subprogram_Contract
20000 -- * Template - The annotation utilizes the generic template of the
20001 -- related subprogram [body] when it is:
20003 -- aspect on subprogram declaration
20004 -- aspect on stand-alone subprogram body
20005 -- pragma on stand-alone subprogram body
20007 -- The annotation must prepare its own template when it is:
20009 -- pragma on subprogram declaration
20011 -- * Globals - Capture of global references must occur after full
20014 -- * Instance - The annotation is instantiated automatically when
20015 -- the related generic subprogram [body] is instantiated except for
20016 -- the "pragma on subprogram declaration" case. In that scenario
20017 -- the annotation must instantiate itself.
20020 | Pragma_Post_Class
20021 | Pragma_Postcondition
20023 Analyze_Pre_Post_Condition
;
20025 --------------------------------
20026 -- Pre/Pre_Class/Precondition --
20027 --------------------------------
20029 -- pragma Pre (Boolean_EXPRESSION);
20030 -- pragma Pre_Class (Boolean_EXPRESSION);
20031 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
20032 -- [,[Message =>] String_EXPRESSION]);
20034 -- Characteristics:
20036 -- * Analysis - The annotation undergoes initial checks to verify
20037 -- the legal placement and context. Secondary checks preanalyze the
20040 -- Analyze_Pre_Post_Condition_In_Decl_Part
20042 -- * Expansion - The annotation is expanded during the expansion of
20043 -- the related subprogram [body] contract as performed in:
20045 -- Expand_Subprogram_Contract
20047 -- * Template - The annotation utilizes the generic template of the
20048 -- related subprogram [body] when it is:
20050 -- aspect on subprogram declaration
20051 -- aspect on stand-alone subprogram body
20052 -- pragma on stand-alone subprogram body
20054 -- The annotation must prepare its own template when it is:
20056 -- pragma on subprogram declaration
20058 -- * Globals - Capture of global references must occur after full
20061 -- * Instance - The annotation is instantiated automatically when
20062 -- the related generic subprogram [body] is instantiated except for
20063 -- the "pragma on subprogram declaration" case. In that scenario
20064 -- the annotation must instantiate itself.
20068 | Pragma_Precondition
20070 Analyze_Pre_Post_Condition
;
20076 -- pragma Predicate
20077 -- ([Entity =>] type_LOCAL_NAME,
20078 -- [Check =>] boolean_EXPRESSION);
20080 when Pragma_Predicate
=> Predicate
: declare
20087 Check_Arg_Count
(2);
20088 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20089 Check_Optional_Identifier
(Arg2
, Name_Check
);
20091 Check_Arg_Is_Local_Name
(Arg1
);
20093 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20094 Find_Type
(Type_Id
);
20095 Typ
:= Entity
(Type_Id
);
20097 if Typ
= Any_Type
then
20101 -- A pragma that applies to a Ghost entity becomes Ghost for the
20102 -- purposes of legality checks and removal of ignored Ghost code.
20104 Mark_Ghost_Pragma
(N
, Typ
);
20106 -- The remaining processing is simply to link the pragma on to
20107 -- the rep item chain, for processing when the type is frozen.
20108 -- This is accomplished by a call to Rep_Item_Too_Late. We also
20109 -- mark the type as having predicates.
20111 -- If the current policy for predicate checking is Ignore mark the
20112 -- subtype accordingly. In the case of predicates we consider them
20113 -- enabled unless Ignore is specified (either directly or with a
20114 -- general Assertion_Policy pragma) to preserve existing warnings.
20116 Set_Has_Predicates
(Typ
);
20117 Set_Predicates_Ignored
(Typ
,
20118 Present
(Check_Policy_List
)
20120 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
20121 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20124 -----------------------
20125 -- Predicate_Failure --
20126 -----------------------
20128 -- pragma Predicate_Failure
20129 -- ([Entity =>] type_LOCAL_NAME,
20130 -- [Message =>] string_EXPRESSION);
20132 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
20139 Check_Arg_Count
(2);
20140 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20141 Check_Optional_Identifier
(Arg2
, Name_Message
);
20143 Check_Arg_Is_Local_Name
(Arg1
);
20145 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20146 Find_Type
(Type_Id
);
20147 Typ
:= Entity
(Type_Id
);
20149 if Typ
= Any_Type
then
20153 -- A pragma that applies to a Ghost entity becomes Ghost for the
20154 -- purposes of legality checks and removal of ignored Ghost code.
20156 Mark_Ghost_Pragma
(N
, Typ
);
20158 -- The remaining processing is simply to link the pragma on to
20159 -- the rep item chain, for processing when the type is frozen.
20160 -- This is accomplished by a call to Rep_Item_Too_Late.
20162 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
20163 end Predicate_Failure
;
20169 -- pragma Preelaborate [(library_unit_NAME)];
20171 -- Set the flag Is_Preelaborated of program unit name entity
20173 when Pragma_Preelaborate
=> Preelaborate
: declare
20174 Pa
: constant Node_Id
:= Parent
(N
);
20175 Pk
: constant Node_Kind
:= Nkind
(Pa
);
20179 Check_Ada_83_Warning
;
20180 Check_Valid_Library_Unit_Pragma
;
20182 if Nkind
(N
) = N_Null_Statement
then
20186 Ent
:= Find_Lib_Unit_Name
;
20188 -- A pragma that applies to a Ghost entity becomes Ghost for the
20189 -- purposes of legality checks and removal of ignored Ghost code.
20191 Mark_Ghost_Pragma
(N
, Ent
);
20192 Check_Duplicate_Pragma
(Ent
);
20194 -- This filters out pragmas inside generic parents that show up
20195 -- inside instantiations. Pragmas that come from aspects in the
20196 -- unit are not ignored.
20198 if Present
(Ent
) then
20199 if Pk
= N_Package_Specification
20200 and then Present
(Generic_Parent
(Pa
))
20201 and then not From_Aspect_Specification
(N
)
20206 if not Debug_Flag_U
then
20207 Set_Is_Preelaborated
(Ent
);
20213 -------------------------------
20214 -- Prefix_Exception_Messages --
20215 -------------------------------
20217 -- pragma Prefix_Exception_Messages;
20219 when Pragma_Prefix_Exception_Messages
=>
20221 Check_Valid_Configuration_Pragma
;
20222 Check_Arg_Count
(0);
20223 Prefix_Exception_Messages
:= True;
20229 -- pragma Priority (EXPRESSION);
20231 when Pragma_Priority
=> Priority
: declare
20232 P
: constant Node_Id
:= Parent
(N
);
20237 Check_No_Identifiers
;
20238 Check_Arg_Count
(1);
20242 if Nkind
(P
) = N_Subprogram_Body
then
20243 Check_In_Main_Program
;
20245 Ent
:= Defining_Unit_Name
(Specification
(P
));
20247 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
20248 Ent
:= Defining_Identifier
(Ent
);
20251 Arg
:= Get_Pragma_Arg
(Arg1
);
20252 Analyze_And_Resolve
(Arg
, Standard_Integer
);
20256 if not Is_OK_Static_Expression
(Arg
) then
20257 Flag_Non_Static_Expr
20258 ("main subprogram priority is not static!", Arg
);
20261 -- If constraint error, then we already signalled an error
20263 elsif Raises_Constraint_Error
(Arg
) then
20266 -- Otherwise check in range except if Relaxed_RM_Semantics
20267 -- where we ignore the value if out of range.
20270 if not Relaxed_RM_Semantics
20271 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
20274 ("main subprogram priority is out of range", Arg1
);
20277 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
20281 -- Load an arbitrary entity from System.Tasking.Stages or
20282 -- System.Tasking.Restricted.Stages (depending on the
20283 -- supported profile) to make sure that one of these packages
20284 -- is implicitly with'ed, since we need to have the tasking
20285 -- run time active for the pragma Priority to have any effect.
20286 -- Previously we with'ed the package System.Tasking, but this
20287 -- package does not trigger the required initialization of the
20288 -- run-time library.
20291 Discard
: Entity_Id
;
20292 pragma Warnings
(Off
, Discard
);
20294 if Restricted_Profile
then
20295 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
20297 Discard
:= RTE
(RE_Activate_Tasks
);
20301 -- Task or Protected, must be of type Integer
20303 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
20304 Arg
:= Get_Pragma_Arg
(Arg1
);
20305 Ent
:= Defining_Identifier
(Parent
(P
));
20307 -- The expression must be analyzed in the special manner
20308 -- described in "Handling of Default and Per-Object
20309 -- Expressions" in sem.ads.
20311 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
20313 if not Is_OK_Static_Expression
(Arg
) then
20314 Check_Restriction
(Static_Priorities
, Arg
);
20317 -- Anything else is incorrect
20323 -- Check duplicate pragma before we chain the pragma in the Rep
20324 -- Item chain of Ent.
20326 Check_Duplicate_Pragma
(Ent
);
20327 Record_Rep_Item
(Ent
, N
);
20330 -----------------------------------
20331 -- Priority_Specific_Dispatching --
20332 -----------------------------------
20334 -- pragma Priority_Specific_Dispatching (
20335 -- policy_IDENTIFIER,
20336 -- first_priority_EXPRESSION,
20337 -- last_priority_EXPRESSION);
20339 when Pragma_Priority_Specific_Dispatching
=>
20340 Priority_Specific_Dispatching
: declare
20341 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
20342 -- This is the entity System.Any_Priority;
20345 Lower_Bound
: Node_Id
;
20346 Upper_Bound
: Node_Id
;
20352 Check_Arg_Count
(3);
20353 Check_No_Identifiers
;
20354 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
20355 Check_Valid_Configuration_Pragma
;
20356 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20357 DP
:= Fold_Upper
(Name_Buffer
(1));
20359 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
20360 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
20361 Lower_Val
:= Expr_Value
(Lower_Bound
);
20363 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
20364 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
20365 Upper_Val
:= Expr_Value
(Upper_Bound
);
20367 -- It is not allowed to use Task_Dispatching_Policy and
20368 -- Priority_Specific_Dispatching in the same partition.
20370 if Task_Dispatching_Policy
/= ' ' then
20371 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20373 ("pragma% incompatible with Task_Dispatching_Policy#");
20375 -- Check lower bound in range
20377 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20379 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20382 ("first_priority is out of range", Arg2
);
20384 -- Check upper bound in range
20386 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
20388 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
20391 ("last_priority is out of range", Arg3
);
20393 -- Check that the priority range is valid
20395 elsif Lower_Val
> Upper_Val
then
20397 ("last_priority_expression must be greater than or equal to "
20398 & "first_priority_expression");
20400 -- Store the new policy, but always preserve System_Location since
20401 -- we like the error message with the run-time name.
20404 -- Check overlapping in the priority ranges specified in other
20405 -- Priority_Specific_Dispatching pragmas within the same
20406 -- partition. We can only check those we know about.
20409 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
20411 if Specific_Dispatching
.Table
(J
).First_Priority
in
20412 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20413 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
20414 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
20417 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
20419 ("priority range overlaps with "
20420 & "Priority_Specific_Dispatching#");
20424 -- The use of Priority_Specific_Dispatching is incompatible
20425 -- with Task_Dispatching_Policy.
20427 if Task_Dispatching_Policy
/= ' ' then
20428 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
20430 ("Priority_Specific_Dispatching incompatible "
20431 & "with Task_Dispatching_Policy#");
20434 -- The use of Priority_Specific_Dispatching forces ceiling
20437 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
20438 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
20440 ("Priority_Specific_Dispatching incompatible "
20441 & "with Locking_Policy#");
20443 -- Set the Ceiling_Locking policy, but preserve System_Location
20444 -- since we like the error message with the run time name.
20447 Locking_Policy
:= 'C';
20449 if Locking_Policy_Sloc
/= System_Location
then
20450 Locking_Policy_Sloc
:= Loc
;
20454 -- Add entry in the table
20456 Specific_Dispatching
.Append
20457 ((Dispatching_Policy
=> DP
,
20458 First_Priority
=> UI_To_Int
(Lower_Val
),
20459 Last_Priority
=> UI_To_Int
(Upper_Val
),
20460 Pragma_Loc
=> Loc
));
20462 end Priority_Specific_Dispatching
;
20468 -- pragma Profile (profile_IDENTIFIER);
20470 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
20472 when Pragma_Profile
=>
20474 Check_Arg_Count
(1);
20475 Check_Valid_Configuration_Pragma
;
20476 Check_No_Identifiers
;
20479 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20482 if Chars
(Argx
) = Name_Ravenscar
then
20483 Set_Ravenscar_Profile
(Ravenscar
, N
);
20485 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
20486 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
20488 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
20489 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
20491 elsif Chars
(Argx
) = Name_Restricted
then
20492 Set_Profile_Restrictions
20494 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20496 elsif Chars
(Argx
) = Name_Rational
then
20497 Set_Rational_Profile
;
20499 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20500 Set_Profile_Restrictions
20501 (No_Implementation_Extensions
,
20502 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20505 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20509 ----------------------
20510 -- Profile_Warnings --
20511 ----------------------
20513 -- pragma Profile_Warnings (profile_IDENTIFIER);
20515 -- profile_IDENTIFIER => Restricted | Ravenscar
20517 when Pragma_Profile_Warnings
=>
20519 Check_Arg_Count
(1);
20520 Check_Valid_Configuration_Pragma
;
20521 Check_No_Identifiers
;
20524 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20527 if Chars
(Argx
) = Name_Ravenscar
then
20528 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
20530 elsif Chars
(Argx
) = Name_Restricted
then
20531 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
20533 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20534 Set_Profile_Restrictions
20535 (No_Implementation_Extensions
, N
, Warn
=> True);
20538 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20542 --------------------------
20543 -- Propagate_Exceptions --
20544 --------------------------
20546 -- pragma Propagate_Exceptions;
20548 -- Note: this pragma is obsolete and has no effect
20550 when Pragma_Propagate_Exceptions
=>
20552 Check_Arg_Count
(0);
20554 if Warn_On_Obsolescent_Feature
then
20556 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20557 "and has no effect?j?", N
);
20560 -----------------------------
20561 -- Provide_Shift_Operators --
20562 -----------------------------
20564 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20566 when Pragma_Provide_Shift_Operators
=>
20567 Provide_Shift_Operators
: declare
20570 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
20571 -- Insert declaration and pragma Instrinsic for named shift op
20573 ----------------------------
20574 -- Declare_Shift_Operator --
20575 ----------------------------
20577 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
20583 Make_Subprogram_Declaration
(Loc
,
20584 Make_Function_Specification
(Loc
,
20585 Defining_Unit_Name
=>
20586 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
20588 Result_Definition
=>
20589 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
20591 Parameter_Specifications
=> New_List
(
20592 Make_Parameter_Specification
(Loc
,
20593 Defining_Identifier
=>
20594 Make_Defining_Identifier
(Loc
, Name_Value
),
20596 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
20598 Make_Parameter_Specification
(Loc
,
20599 Defining_Identifier
=>
20600 Make_Defining_Identifier
(Loc
, Name_Amount
),
20602 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
20606 Chars
=> Name_Import
,
20607 Pragma_Argument_Associations
=> New_List
(
20608 Make_Pragma_Argument_Association
(Loc
,
20609 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
20610 Make_Pragma_Argument_Association
(Loc
,
20611 Expression
=> Make_Identifier
(Loc
, Nam
))));
20613 Insert_After
(N
, Import
);
20614 Insert_After
(N
, Func
);
20615 end Declare_Shift_Operator
;
20617 -- Start of processing for Provide_Shift_Operators
20621 Check_Arg_Count
(1);
20622 Check_Arg_Is_Local_Name
(Arg1
);
20624 Arg1
:= Get_Pragma_Arg
(Arg1
);
20626 -- We must have an entity name
20628 if not Is_Entity_Name
(Arg1
) then
20630 ("pragma % must apply to integer first subtype", Arg1
);
20633 -- If no Entity, means there was a prior error so ignore
20635 if Present
(Entity
(Arg1
)) then
20636 Ent
:= Entity
(Arg1
);
20638 -- Apply error checks
20640 if not Is_First_Subtype
(Ent
) then
20642 ("cannot apply pragma %",
20643 "\& is not a first subtype",
20646 elsif not Is_Integer_Type
(Ent
) then
20648 ("cannot apply pragma %",
20649 "\& is not an integer type",
20652 elsif Has_Shift_Operator
(Ent
) then
20654 ("cannot apply pragma %",
20655 "\& already has declared shift operators",
20658 elsif Is_Frozen
(Ent
) then
20660 ("pragma % appears too late",
20661 "\& is already frozen",
20665 -- Now declare the operators. We do this during analysis rather
20666 -- than expansion, since we want the operators available if we
20667 -- are operating in -gnatc or ASIS mode.
20669 Declare_Shift_Operator
(Name_Rotate_Left
);
20670 Declare_Shift_Operator
(Name_Rotate_Right
);
20671 Declare_Shift_Operator
(Name_Shift_Left
);
20672 Declare_Shift_Operator
(Name_Shift_Right
);
20673 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
20675 end Provide_Shift_Operators
;
20681 -- pragma Psect_Object (
20682 -- [Internal =>] LOCAL_NAME,
20683 -- [, [External =>] EXTERNAL_SYMBOL]
20684 -- [, [Size =>] EXTERNAL_SYMBOL]);
20686 when Pragma_Common_Object
20687 | Pragma_Psect_Object
20689 Psect_Object
: declare
20690 Args
: Args_List
(1 .. 3);
20691 Names
: constant Name_List
(1 .. 3) := (
20696 Internal
: Node_Id
renames Args
(1);
20697 External
: Node_Id
renames Args
(2);
20698 Size
: Node_Id
renames Args
(3);
20700 Def_Id
: Entity_Id
;
20702 procedure Check_Arg
(Arg
: Node_Id
);
20703 -- Checks that argument is either a string literal or an
20704 -- identifier, and posts error message if not.
20710 procedure Check_Arg
(Arg
: Node_Id
) is
20712 if not Nkind_In
(Original_Node
(Arg
),
20717 ("inappropriate argument for pragma %", Arg
);
20721 -- Start of processing for Common_Object/Psect_Object
20725 Gather_Associations
(Names
, Args
);
20726 Process_Extended_Import_Export_Internal_Arg
(Internal
);
20728 Def_Id
:= Entity
(Internal
);
20730 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
20732 ("pragma% must designate an object", Internal
);
20735 Check_Arg
(Internal
);
20737 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
20739 ("cannot use pragma% for imported/exported object",
20743 if Is_Concurrent_Type
(Etype
(Internal
)) then
20745 ("cannot specify pragma % for task/protected object",
20749 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
20751 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
20753 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
20756 if Ekind
(Def_Id
) = E_Constant
then
20758 ("cannot specify pragma % for a constant", Internal
);
20761 if Is_Record_Type
(Etype
(Internal
)) then
20767 Ent
:= First_Entity
(Etype
(Internal
));
20768 while Present
(Ent
) loop
20769 Decl
:= Declaration_Node
(Ent
);
20771 if Ekind
(Ent
) = E_Component
20772 and then Nkind
(Decl
) = N_Component_Declaration
20773 and then Present
(Expression
(Decl
))
20774 and then Warn_On_Export_Import
20777 ("?x?object for pragma % has defaults", Internal
);
20787 if Present
(Size
) then
20791 if Present
(External
) then
20792 Check_Arg_Is_External_Name
(External
);
20795 -- If all error tests pass, link pragma on to the rep item chain
20797 Record_Rep_Item
(Def_Id
, N
);
20804 -- pragma Pure [(library_unit_NAME)];
20806 when Pragma_Pure
=> Pure
: declare
20810 Check_Ada_83_Warning
;
20812 -- If the pragma comes from a subprogram instantiation, nothing to
20813 -- check, this can happen at any level of nesting.
20815 if Is_Wrapper_Package
(Current_Scope
) then
20818 Check_Valid_Library_Unit_Pragma
;
20821 if Nkind
(N
) = N_Null_Statement
then
20825 Ent
:= Find_Lib_Unit_Name
;
20827 -- A pragma that applies to a Ghost entity becomes Ghost for the
20828 -- purposes of legality checks and removal of ignored Ghost code.
20830 Mark_Ghost_Pragma
(N
, Ent
);
20832 if not Debug_Flag_U
then
20834 Set_Has_Pragma_Pure
(Ent
);
20838 -------------------
20839 -- Pure_Function --
20840 -------------------
20842 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20844 when Pragma_Pure_Function
=> Pure_Function
: declare
20845 Def_Id
: Entity_Id
;
20848 Effective
: Boolean := False;
20852 Check_Arg_Count
(1);
20853 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20854 Check_Arg_Is_Local_Name
(Arg1
);
20855 E_Id
:= Get_Pragma_Arg
(Arg1
);
20857 if Etype
(E_Id
) = Any_Type
then
20861 -- Loop through homonyms (overloadings) of referenced entity
20863 E
:= Entity
(E_Id
);
20865 -- A pragma that applies to a Ghost entity becomes Ghost for the
20866 -- purposes of legality checks and removal of ignored Ghost code.
20868 Mark_Ghost_Pragma
(N
, E
);
20870 if Present
(E
) then
20872 Def_Id
:= Get_Base_Subprogram
(E
);
20874 if not Ekind_In
(Def_Id
, E_Function
,
20875 E_Generic_Function
,
20879 ("pragma% requires a function name", Arg1
);
20882 Set_Is_Pure
(Def_Id
);
20884 if not Has_Pragma_Pure_Function
(Def_Id
) then
20885 Set_Has_Pragma_Pure_Function
(Def_Id
);
20889 exit when From_Aspect_Specification
(N
);
20891 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
20895 and then Warn_On_Redundant_Constructs
20898 ("pragma Pure_Function on& is redundant?r?",
20904 --------------------
20905 -- Queuing_Policy --
20906 --------------------
20908 -- pragma Queuing_Policy (policy_IDENTIFIER);
20910 when Pragma_Queuing_Policy
=> declare
20914 Check_Ada_83_Warning
;
20915 Check_Arg_Count
(1);
20916 Check_No_Identifiers
;
20917 Check_Arg_Is_Queuing_Policy
(Arg1
);
20918 Check_Valid_Configuration_Pragma
;
20919 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20920 QP
:= Fold_Upper
(Name_Buffer
(1));
20922 if Queuing_Policy
/= ' '
20923 and then Queuing_Policy
/= QP
20925 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
20926 Error_Pragma
("queuing policy incompatible with policy#");
20928 -- Set new policy, but always preserve System_Location since we
20929 -- like the error message with the run time name.
20932 Queuing_Policy
:= QP
;
20934 if Queuing_Policy_Sloc
/= System_Location
then
20935 Queuing_Policy_Sloc
:= Loc
;
20944 -- pragma Rational, for compatibility with foreign compiler
20946 when Pragma_Rational
=>
20947 Set_Rational_Profile
;
20949 ---------------------
20950 -- Refined_Depends --
20951 ---------------------
20953 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20955 -- DEPENDENCY_RELATION ::=
20957 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20959 -- DEPENDENCY_CLAUSE ::=
20960 -- OUTPUT_LIST =>[+] INPUT_LIST
20961 -- | NULL_DEPENDENCY_CLAUSE
20963 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20965 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20967 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20969 -- OUTPUT ::= NAME | FUNCTION_RESULT
20972 -- where FUNCTION_RESULT is a function Result attribute_reference
20974 -- Characteristics:
20976 -- * Analysis - The annotation undergoes initial checks to verify
20977 -- the legal placement and context. Secondary checks fully analyze
20978 -- the dependency clauses/global list in:
20980 -- Analyze_Refined_Depends_In_Decl_Part
20982 -- * Expansion - None.
20984 -- * Template - The annotation utilizes the generic template of the
20985 -- related subprogram body.
20987 -- * Globals - Capture of global references must occur after full
20990 -- * Instance - The annotation is instantiated automatically when
20991 -- the related generic subprogram body is instantiated.
20993 when Pragma_Refined_Depends
=> Refined_Depends
: declare
20994 Body_Id
: Entity_Id
;
20996 Spec_Id
: Entity_Id
;
20999 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21003 -- Chain the pragma on the contract for further processing by
21004 -- Analyze_Refined_Depends_In_Decl_Part.
21006 Add_Contract_Item
(N
, Body_Id
);
21008 -- The legality checks of pragmas Refined_Depends and
21009 -- Refined_Global are affected by the SPARK mode in effect and
21010 -- the volatility of the context. In addition these two pragmas
21011 -- are subject to an inherent order:
21013 -- 1) Refined_Global
21014 -- 2) Refined_Depends
21016 -- Analyze all these pragmas in the order outlined above
21018 Analyze_If_Present
(Pragma_SPARK_Mode
);
21019 Analyze_If_Present
(Pragma_Volatile_Function
);
21020 Analyze_If_Present
(Pragma_Refined_Global
);
21021 Analyze_Refined_Depends_In_Decl_Part
(N
);
21023 end Refined_Depends
;
21025 --------------------
21026 -- Refined_Global --
21027 --------------------
21029 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
21031 -- GLOBAL_SPECIFICATION ::=
21034 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
21036 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
21038 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
21039 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
21040 -- GLOBAL_ITEM ::= NAME
21042 -- Characteristics:
21044 -- * Analysis - The annotation undergoes initial checks to verify
21045 -- the legal placement and context. Secondary checks fully analyze
21046 -- the dependency clauses/global list in:
21048 -- Analyze_Refined_Global_In_Decl_Part
21050 -- * Expansion - None.
21052 -- * Template - The annotation utilizes the generic template of the
21053 -- related subprogram body.
21055 -- * Globals - Capture of global references must occur after full
21058 -- * Instance - The annotation is instantiated automatically when
21059 -- the related generic subprogram body is instantiated.
21061 when Pragma_Refined_Global
=> Refined_Global
: declare
21062 Body_Id
: Entity_Id
;
21064 Spec_Id
: Entity_Id
;
21067 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21071 -- Chain the pragma on the contract for further processing by
21072 -- Analyze_Refined_Global_In_Decl_Part.
21074 Add_Contract_Item
(N
, Body_Id
);
21076 -- The legality checks of pragmas Refined_Depends and
21077 -- Refined_Global are affected by the SPARK mode in effect and
21078 -- the volatility of the context. In addition these two pragmas
21079 -- are subject to an inherent order:
21081 -- 1) Refined_Global
21082 -- 2) Refined_Depends
21084 -- Analyze all these pragmas in the order outlined above
21086 Analyze_If_Present
(Pragma_SPARK_Mode
);
21087 Analyze_If_Present
(Pragma_Volatile_Function
);
21088 Analyze_Refined_Global_In_Decl_Part
(N
);
21089 Analyze_If_Present
(Pragma_Refined_Depends
);
21091 end Refined_Global
;
21097 -- pragma Refined_Post (boolean_EXPRESSION);
21099 -- Characteristics:
21101 -- * Analysis - The annotation is fully analyzed immediately upon
21102 -- elaboration as it cannot forward reference entities.
21104 -- * Expansion - The annotation is expanded during the expansion of
21105 -- the related subprogram body contract as performed in:
21107 -- Expand_Subprogram_Contract
21109 -- * Template - The annotation utilizes the generic template of the
21110 -- related subprogram body.
21112 -- * Globals - Capture of global references must occur after full
21115 -- * Instance - The annotation is instantiated automatically when
21116 -- the related generic subprogram body is instantiated.
21118 when Pragma_Refined_Post
=> Refined_Post
: declare
21119 Body_Id
: Entity_Id
;
21121 Spec_Id
: Entity_Id
;
21124 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
21126 -- Fully analyze the pragma when it appears inside a subprogram
21127 -- body because it cannot benefit from forward references.
21131 -- Chain the pragma on the contract for completeness
21133 Add_Contract_Item
(N
, Body_Id
);
21135 -- The legality checks of pragma Refined_Post are affected by
21136 -- the SPARK mode in effect and the volatility of the context.
21137 -- Analyze all pragmas in a specific order.
21139 Analyze_If_Present
(Pragma_SPARK_Mode
);
21140 Analyze_If_Present
(Pragma_Volatile_Function
);
21141 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
21143 -- Currently it is not possible to inline pre/postconditions on
21144 -- a subprogram subject to pragma Inline_Always.
21146 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
21150 -------------------
21151 -- Refined_State --
21152 -------------------
21154 -- pragma Refined_State (REFINEMENT_LIST);
21156 -- REFINEMENT_LIST ::=
21157 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
21159 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
21161 -- CONSTITUENT_LIST ::=
21164 -- | (CONSTITUENT {, CONSTITUENT})
21166 -- CONSTITUENT ::= object_NAME | state_NAME
21168 -- Characteristics:
21170 -- * Analysis - The annotation undergoes initial checks to verify
21171 -- the legal placement and context. Secondary checks preanalyze the
21172 -- refinement clauses in:
21174 -- Analyze_Refined_State_In_Decl_Part
21176 -- * Expansion - None.
21178 -- * Template - The annotation utilizes the template of the related
21181 -- * Globals - Capture of global references must occur after full
21184 -- * Instance - The annotation is instantiated automatically when
21185 -- the related generic package body is instantiated.
21187 when Pragma_Refined_State
=> Refined_State
: declare
21188 Pack_Decl
: Node_Id
;
21189 Spec_Id
: Entity_Id
;
21193 Check_No_Identifiers
;
21194 Check_Arg_Count
(1);
21196 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
21198 -- Ensure the proper placement of the pragma. Refined states must
21199 -- be associated with a package body.
21201 if Nkind
(Pack_Decl
) = N_Package_Body
then
21204 -- Otherwise the pragma is associated with an illegal construct
21211 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
21213 -- A pragma that applies to a Ghost entity becomes Ghost for the
21214 -- purposes of legality checks and removal of ignored Ghost code.
21216 Mark_Ghost_Pragma
(N
, Spec_Id
);
21218 -- Chain the pragma on the contract for further processing by
21219 -- Analyze_Refined_State_In_Decl_Part.
21221 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
21223 -- The legality checks of pragma Refined_State are affected by the
21224 -- SPARK mode in effect. Analyze all pragmas in a specific order.
21226 Analyze_If_Present
(Pragma_SPARK_Mode
);
21228 -- State refinement is allowed only when the corresponding package
21229 -- declaration has non-null pragma Abstract_State. Refinement not
21230 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
21232 if SPARK_Mode
/= Off
21234 (No
(Abstract_States
(Spec_Id
))
21235 or else Has_Null_Abstract_State
(Spec_Id
))
21238 ("useless refinement, package & does not define abstract "
21239 & "states", N
, Spec_Id
);
21244 -----------------------
21245 -- Relative_Deadline --
21246 -----------------------
21248 -- pragma Relative_Deadline (time_span_EXPRESSION);
21250 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
21251 P
: constant Node_Id
:= Parent
(N
);
21256 Check_No_Identifiers
;
21257 Check_Arg_Count
(1);
21259 Arg
:= Get_Pragma_Arg
(Arg1
);
21261 -- The expression must be analyzed in the special manner described
21262 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
21264 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
21268 if Nkind
(P
) = N_Subprogram_Body
then
21269 Check_In_Main_Program
;
21271 -- Only Task and subprogram cases allowed
21273 elsif Nkind
(P
) /= N_Task_Definition
then
21277 -- Check duplicate pragma before we set the corresponding flag
21279 if Has_Relative_Deadline_Pragma
(P
) then
21280 Error_Pragma
("duplicate pragma% not allowed");
21283 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
21284 -- Relative_Deadline pragma node cannot be inserted in the Rep
21285 -- Item chain of Ent since it is rewritten by the expander as a
21286 -- procedure call statement that will break the chain.
21288 Set_Has_Relative_Deadline_Pragma
(P
);
21289 end Relative_Deadline
;
21291 ------------------------
21292 -- Remote_Access_Type --
21293 ------------------------
21295 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
21297 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
21302 Check_Arg_Count
(1);
21303 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21304 Check_Arg_Is_Local_Name
(Arg1
);
21306 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
21308 -- A pragma that applies to a Ghost entity becomes Ghost for the
21309 -- purposes of legality checks and removal of ignored Ghost code.
21311 Mark_Ghost_Pragma
(N
, E
);
21313 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
21314 and then Ekind
(E
) = E_General_Access_Type
21315 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
21316 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
21318 and then Is_Valid_Remote_Object_Type
21319 (Root_Type
(Directly_Designated_Type
(E
)))
21321 Set_Is_Remote_Types
(E
);
21325 ("pragma% applies only to formal access-to-class-wide types",
21328 end Remote_Access_Type
;
21330 ---------------------------
21331 -- Remote_Call_Interface --
21332 ---------------------------
21334 -- pragma Remote_Call_Interface [(library_unit_NAME)];
21336 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
21337 Cunit_Node
: Node_Id
;
21338 Cunit_Ent
: Entity_Id
;
21342 Check_Ada_83_Warning
;
21343 Check_Valid_Library_Unit_Pragma
;
21345 if Nkind
(N
) = N_Null_Statement
then
21349 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21350 K
:= Nkind
(Unit
(Cunit_Node
));
21351 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21353 -- A pragma that applies to a Ghost entity becomes Ghost for the
21354 -- purposes of legality checks and removal of ignored Ghost code.
21356 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21358 if K
= N_Package_Declaration
21359 or else K
= N_Generic_Package_Declaration
21360 or else K
= N_Subprogram_Declaration
21361 or else K
= N_Generic_Subprogram_Declaration
21362 or else (K
= N_Subprogram_Body
21363 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
21368 "pragma% must apply to package or subprogram declaration");
21371 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
21372 end Remote_Call_Interface
;
21378 -- pragma Remote_Types [(library_unit_NAME)];
21380 when Pragma_Remote_Types
=> Remote_Types
: declare
21381 Cunit_Node
: Node_Id
;
21382 Cunit_Ent
: Entity_Id
;
21385 Check_Ada_83_Warning
;
21386 Check_Valid_Library_Unit_Pragma
;
21388 if Nkind
(N
) = N_Null_Statement
then
21392 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21393 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21395 -- A pragma that applies to a Ghost entity becomes Ghost for the
21396 -- purposes of legality checks and removal of ignored Ghost code.
21398 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21400 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21401 N_Generic_Package_Declaration
)
21404 ("pragma% can only apply to a package declaration");
21407 Set_Is_Remote_Types
(Cunit_Ent
);
21414 -- pragma Ravenscar;
21416 when Pragma_Ravenscar
=>
21418 Check_Arg_Count
(0);
21419 Check_Valid_Configuration_Pragma
;
21420 Set_Ravenscar_Profile
(Ravenscar
, N
);
21422 if Warn_On_Obsolescent_Feature
then
21424 ("pragma Ravenscar is an obsolescent feature?j?", N
);
21426 ("|use pragma Profile (Ravenscar) instead?j?", N
);
21429 -------------------------
21430 -- Restricted_Run_Time --
21431 -------------------------
21433 -- pragma Restricted_Run_Time;
21435 when Pragma_Restricted_Run_Time
=>
21437 Check_Arg_Count
(0);
21438 Check_Valid_Configuration_Pragma
;
21439 Set_Profile_Restrictions
21440 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
21442 if Warn_On_Obsolescent_Feature
then
21444 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
21447 ("|use pragma Profile (Restricted) instead?j?", N
);
21454 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
21457 -- restriction_IDENTIFIER
21458 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21460 when Pragma_Restrictions
=>
21461 Process_Restrictions_Or_Restriction_Warnings
21462 (Warn
=> Treat_Restrictions_As_Warnings
);
21464 --------------------------
21465 -- Restriction_Warnings --
21466 --------------------------
21468 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
21471 -- restriction_IDENTIFIER
21472 -- | restriction_parameter_IDENTIFIER => EXPRESSION
21474 when Pragma_Restriction_Warnings
=>
21476 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
21482 -- pragma Reviewable;
21484 when Pragma_Reviewable
=>
21485 Check_Ada_83_Warning
;
21486 Check_Arg_Count
(0);
21488 -- Call dummy debugging function rv. This is done to assist front
21489 -- end debugging. By placing a Reviewable pragma in the source
21490 -- program, a breakpoint on rv catches this place in the source,
21491 -- allowing convenient stepping to the point of interest.
21495 --------------------------
21496 -- Secondary_Stack_Size --
21497 --------------------------
21499 -- pragma Secondary_Stack_Size (EXPRESSION);
21501 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
21502 P
: constant Node_Id
:= Parent
(N
);
21508 Check_No_Identifiers
;
21509 Check_Arg_Count
(1);
21511 if Nkind
(P
) = N_Task_Definition
then
21512 Arg
:= Get_Pragma_Arg
(Arg1
);
21513 Ent
:= Defining_Identifier
(Parent
(P
));
21515 -- The expression must be analyzed in the special manner
21516 -- described in "Handling of Default Expressions" in sem.ads.
21518 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21520 -- The pragma cannot appear if the No_Secondary_Stack
21521 -- restriction is in effect.
21523 Check_Restriction
(No_Secondary_Stack
, Arg
);
21525 -- Anything else is incorrect
21531 -- Check duplicate pragma before we chain the pragma in the Rep
21532 -- Item chain of Ent.
21534 Check_Duplicate_Pragma
(Ent
);
21535 Record_Rep_Item
(Ent
, N
);
21536 end Secondary_Stack_Size
;
21538 --------------------------
21539 -- Short_Circuit_And_Or --
21540 --------------------------
21542 -- pragma Short_Circuit_And_Or;
21544 when Pragma_Short_Circuit_And_Or
=>
21546 Check_Arg_Count
(0);
21547 Check_Valid_Configuration_Pragma
;
21548 Short_Circuit_And_Or
:= True;
21550 -------------------
21551 -- Share_Generic --
21552 -------------------
21554 -- pragma Share_Generic (GNAME {, GNAME});
21556 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21558 when Pragma_Share_Generic
=>
21560 Process_Generic_List
;
21566 -- pragma Shared (LOCAL_NAME);
21568 when Pragma_Shared
=>
21570 Process_Atomic_Independent_Shared_Volatile
;
21572 --------------------
21573 -- Shared_Passive --
21574 --------------------
21576 -- pragma Shared_Passive [(library_unit_NAME)];
21578 -- Set the flag Is_Shared_Passive of program unit name entity
21580 when Pragma_Shared_Passive
=> Shared_Passive
: declare
21581 Cunit_Node
: Node_Id
;
21582 Cunit_Ent
: Entity_Id
;
21585 Check_Ada_83_Warning
;
21586 Check_Valid_Library_Unit_Pragma
;
21588 if Nkind
(N
) = N_Null_Statement
then
21592 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21593 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21595 -- A pragma that applies to a Ghost entity becomes Ghost for the
21596 -- purposes of legality checks and removal of ignored Ghost code.
21598 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21600 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21601 N_Generic_Package_Declaration
)
21604 ("pragma% can only apply to a package declaration");
21607 Set_Is_Shared_Passive
(Cunit_Ent
);
21608 end Shared_Passive
;
21610 -----------------------
21611 -- Short_Descriptors --
21612 -----------------------
21614 -- pragma Short_Descriptors;
21616 -- Recognize and validate, but otherwise ignore
21618 when Pragma_Short_Descriptors
=>
21620 Check_Arg_Count
(0);
21621 Check_Valid_Configuration_Pragma
;
21623 ------------------------------
21624 -- Simple_Storage_Pool_Type --
21625 ------------------------------
21627 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21629 when Pragma_Simple_Storage_Pool_Type
=>
21630 Simple_Storage_Pool_Type
: declare
21636 Check_Arg_Count
(1);
21637 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21639 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21640 Find_Type
(Type_Id
);
21641 Typ
:= Entity
(Type_Id
);
21643 if Typ
= Any_Type
then
21647 -- A pragma that applies to a Ghost entity becomes Ghost for the
21648 -- purposes of legality checks and removal of ignored Ghost code.
21650 Mark_Ghost_Pragma
(N
, Typ
);
21652 -- We require the pragma to apply to a type declared in a package
21653 -- declaration, but not (immediately) within a package body.
21655 if Ekind
(Current_Scope
) /= E_Package
21656 or else In_Package_Body
(Current_Scope
)
21659 ("pragma% can only apply to type declared immediately "
21660 & "within a package declaration");
21663 -- A simple storage pool type must be an immutably limited record
21664 -- or private type. If the pragma is given for a private type,
21665 -- the full type is similarly restricted (which is checked later
21666 -- in Freeze_Entity).
21668 if Is_Record_Type
(Typ
)
21669 and then not Is_Limited_View
(Typ
)
21672 ("pragma% can only apply to explicitly limited record type");
21674 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
21676 ("pragma% can only apply to a private type that is limited");
21678 elsif not Is_Record_Type
(Typ
)
21679 and then not Is_Private_Type
(Typ
)
21682 ("pragma% can only apply to limited record or private type");
21685 Record_Rep_Item
(Typ
, N
);
21686 end Simple_Storage_Pool_Type
;
21688 ----------------------
21689 -- Source_File_Name --
21690 ----------------------
21692 -- There are five forms for this pragma:
21694 -- pragma Source_File_Name (
21695 -- [UNIT_NAME =>] unit_NAME,
21696 -- BODY_FILE_NAME => STRING_LITERAL
21697 -- [, [INDEX =>] INTEGER_LITERAL]);
21699 -- pragma Source_File_Name (
21700 -- [UNIT_NAME =>] unit_NAME,
21701 -- SPEC_FILE_NAME => STRING_LITERAL
21702 -- [, [INDEX =>] INTEGER_LITERAL]);
21704 -- pragma Source_File_Name (
21705 -- BODY_FILE_NAME => STRING_LITERAL
21706 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21707 -- [, CASING => CASING_SPEC]);
21709 -- pragma Source_File_Name (
21710 -- SPEC_FILE_NAME => STRING_LITERAL
21711 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21712 -- [, CASING => CASING_SPEC]);
21714 -- pragma Source_File_Name (
21715 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21716 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21717 -- [, CASING => CASING_SPEC]);
21719 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21721 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21722 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21723 -- only be used when no project file is used, while SFNP can only be
21724 -- used when a project file is used.
21726 -- No processing here. Processing was completed during parsing, since
21727 -- we need to have file names set as early as possible. Units are
21728 -- loaded well before semantic processing starts.
21730 -- The only processing we defer to this point is the check for
21731 -- correct placement.
21733 when Pragma_Source_File_Name
=>
21735 Check_Valid_Configuration_Pragma
;
21737 ------------------------------
21738 -- Source_File_Name_Project --
21739 ------------------------------
21741 -- See Source_File_Name for syntax
21743 -- No processing here. Processing was completed during parsing, since
21744 -- we need to have file names set as early as possible. Units are
21745 -- loaded well before semantic processing starts.
21747 -- The only processing we defer to this point is the check for
21748 -- correct placement.
21750 when Pragma_Source_File_Name_Project
=>
21752 Check_Valid_Configuration_Pragma
;
21754 -- Check that a pragma Source_File_Name_Project is used only in a
21755 -- configuration pragmas file.
21757 -- Pragmas Source_File_Name_Project should only be generated by
21758 -- the Project Manager in configuration pragmas files.
21760 -- This is really an ugly test. It seems to depend on some
21761 -- accidental and undocumented property. At the very least it
21762 -- needs to be documented, but it would be better to have a
21763 -- clean way of testing if we are in a configuration file???
21765 if Present
(Parent
(N
)) then
21767 ("pragma% can only appear in a configuration pragmas file");
21770 ----------------------
21771 -- Source_Reference --
21772 ----------------------
21774 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21776 -- Nothing to do, all processing completed in Par.Prag, since we need
21777 -- the information for possible parser messages that are output.
21779 when Pragma_Source_Reference
=>
21786 -- pragma SPARK_Mode [(On | Off)];
21788 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
21789 Mode_Id
: SPARK_Mode_Type
;
21791 procedure Check_Pragma_Conformance
21792 (Context_Pragma
: Node_Id
;
21793 Entity
: Entity_Id
;
21794 Entity_Pragma
: Node_Id
);
21795 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21796 -- conformance of pragma N depending the following scenarios:
21798 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21799 -- compatible with the pragma Context_Pragma that was inherited
21800 -- from the context:
21801 -- * If the mode of Context_Pragma is ON, then the new mode can
21803 -- * If the mode of Context_Pragma is OFF, then the only allowed
21804 -- new mode is also OFF. Emit error if this is not the case.
21806 -- If Entity is not Empty, verify that pragma N is compatible with
21807 -- pragma Entity_Pragma that belongs to Entity.
21808 -- * If Entity_Pragma is Empty, always issue an error as this
21809 -- corresponds to the case where a previous section of Entity
21810 -- has no SPARK_Mode set.
21811 -- * If the mode of Entity_Pragma is ON, then the new mode can
21813 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21814 -- new mode is also OFF. Emit error if this is not the case.
21816 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
21817 -- Subsidiary to routines Process_xxx. Verify that the related
21818 -- entity E subject to pragma SPARK_Mode is library-level.
21820 procedure Process_Body
(Decl
: Node_Id
);
21821 -- Verify the legality of pragma SPARK_Mode when it appears as the
21822 -- top of the body declarations of entry, package, protected unit,
21823 -- subprogram or task unit body denoted by Decl.
21825 procedure Process_Overloadable
(Decl
: Node_Id
);
21826 -- Verify the legality of pragma SPARK_Mode when it applies to an
21827 -- entry or [generic] subprogram declaration denoted by Decl.
21829 procedure Process_Private_Part
(Decl
: Node_Id
);
21830 -- Verify the legality of pragma SPARK_Mode when it appears at the
21831 -- top of the private declarations of a package spec, protected or
21832 -- task unit declaration denoted by Decl.
21834 procedure Process_Statement_Part
(Decl
: Node_Id
);
21835 -- Verify the legality of pragma SPARK_Mode when it appears at the
21836 -- top of the statement sequence of a package body denoted by node
21839 procedure Process_Visible_Part
(Decl
: Node_Id
);
21840 -- Verify the legality of pragma SPARK_Mode when it appears at the
21841 -- top of the visible declarations of a package spec, protected or
21842 -- task unit declaration denoted by Decl. The routine is also used
21843 -- on protected or task units declared without a definition.
21845 procedure Set_SPARK_Context
;
21846 -- Subsidiary to routines Process_xxx. Set the global variables
21847 -- which represent the mode of the context from pragma N. Ensure
21848 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21850 ------------------------------
21851 -- Check_Pragma_Conformance --
21852 ------------------------------
21854 procedure Check_Pragma_Conformance
21855 (Context_Pragma
: Node_Id
;
21856 Entity
: Entity_Id
;
21857 Entity_Pragma
: Node_Id
)
21859 Err_Id
: Entity_Id
;
21863 -- The current pragma may appear without an argument. If this
21864 -- is the case, associate all error messages with the pragma
21867 if Present
(Arg1
) then
21873 -- The mode of the current pragma is compared against that of
21874 -- an enclosing context.
21876 if Present
(Context_Pragma
) then
21877 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
21879 -- Issue an error if the new mode is less restrictive than
21880 -- that of the context.
21882 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
21883 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21886 ("cannot change SPARK_Mode from Off to On", Err_N
);
21887 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21888 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
21893 -- The mode of the current pragma is compared against that of
21894 -- an initial package, protected type, subprogram or task type
21897 if Present
(Entity
) then
21899 -- A simple protected or task type is transformed into an
21900 -- anonymous type whose name cannot be used to issue error
21901 -- messages. Recover the original entity of the type.
21903 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
21906 (Original_Node
(Unit_Declaration_Node
(Entity
)));
21911 -- Both the initial declaration and the completion carry
21912 -- SPARK_Mode pragmas.
21914 if Present
(Entity_Pragma
) then
21915 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
21917 -- Issue an error if the new mode is less restrictive
21918 -- than that of the initial declaration.
21920 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
21921 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21923 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21924 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
21926 ("\value Off was set for SPARK_Mode on&#",
21931 -- Otherwise the initial declaration lacks a SPARK_Mode
21932 -- pragma in which case the current pragma is illegal as
21933 -- it cannot "complete".
21936 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21937 Error_Msg_Sloc
:= Sloc
(Err_Id
);
21939 ("\no value was set for SPARK_Mode on&#",
21944 end Check_Pragma_Conformance
;
21946 --------------------------------
21947 -- Check_Library_Level_Entity --
21948 --------------------------------
21950 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
21951 procedure Add_Entity_To_Name_Buffer
;
21952 -- Add the E_Kind of entity E to the name buffer
21954 -------------------------------
21955 -- Add_Entity_To_Name_Buffer --
21956 -------------------------------
21958 procedure Add_Entity_To_Name_Buffer
is
21960 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
21961 Add_Str_To_Name_Buffer
("entry");
21963 elsif Ekind_In
(E
, E_Generic_Package
,
21967 Add_Str_To_Name_Buffer
("package");
21969 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
21970 Add_Str_To_Name_Buffer
("protected type");
21972 elsif Ekind_In
(E
, E_Function
,
21973 E_Generic_Function
,
21974 E_Generic_Procedure
,
21978 Add_Str_To_Name_Buffer
("subprogram");
21981 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
21982 Add_Str_To_Name_Buffer
("task type");
21984 end Add_Entity_To_Name_Buffer
;
21988 Msg_1
: constant String := "incorrect placement of pragma%";
21991 -- Start of processing for Check_Library_Level_Entity
21994 if not Is_Library_Level_Entity
(E
) then
21995 Error_Msg_Name_1
:= Pname
;
21996 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
21999 Add_Str_To_Name_Buffer
("\& is not a library-level ");
22000 Add_Entity_To_Name_Buffer
;
22002 Msg_2
:= Name_Find
;
22003 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
22007 end Check_Library_Level_Entity
;
22013 procedure Process_Body
(Decl
: Node_Id
) is
22014 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22015 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
22018 -- Ignore pragma when applied to the special body created for
22019 -- inlining, recognized by its internal name _Parent.
22021 if Chars
(Body_Id
) = Name_uParent
then
22025 Check_Library_Level_Entity
(Body_Id
);
22027 -- For entry bodies, verify the legality against:
22028 -- * The mode of the context
22029 -- * The mode of the spec (if any)
22031 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
22033 -- A stand-alone subprogram body
22035 if Body_Id
= Spec_Id
then
22036 Check_Pragma_Conformance
22037 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22039 Entity_Pragma
=> Empty
);
22041 -- An entry or subprogram body that completes a previous
22045 Check_Pragma_Conformance
22046 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22048 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22052 Set_SPARK_Pragma
(Body_Id
, N
);
22053 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22055 -- For package bodies, verify the legality against:
22056 -- * The mode of the context
22057 -- * The mode of the private part
22059 -- This case is separated from protected and task bodies
22060 -- because the statement part of the package body inherits
22061 -- the mode of the body declarations.
22063 elsif Nkind
(Decl
) = N_Package_Body
then
22064 Check_Pragma_Conformance
22065 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22067 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22070 Set_SPARK_Pragma
(Body_Id
, N
);
22071 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22072 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22073 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
22075 -- For protected and task bodies, verify the legality against:
22076 -- * The mode of the context
22077 -- * The mode of the private part
22081 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
22083 Check_Pragma_Conformance
22084 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
22086 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
22089 Set_SPARK_Pragma
(Body_Id
, N
);
22090 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
22094 --------------------------
22095 -- Process_Overloadable --
22096 --------------------------
22098 procedure Process_Overloadable
(Decl
: Node_Id
) is
22099 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22100 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
22103 Check_Library_Level_Entity
(Spec_Id
);
22105 -- Verify the legality against:
22106 -- * The mode of the context
22108 Check_Pragma_Conformance
22109 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22111 Entity_Pragma
=> Empty
);
22113 Set_SPARK_Pragma
(Spec_Id
, N
);
22114 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22116 -- When the pragma applies to the anonymous object created for
22117 -- a single task type, decorate the type as well. This scenario
22118 -- arises when the single task type lacks a task definition,
22119 -- therefore there is no issue with respect to a potential
22120 -- pragma SPARK_Mode in the private part.
22122 -- task type Anon_Task_Typ;
22123 -- Obj : Anon_Task_Typ;
22124 -- pragma SPARK_Mode ...;
22126 if Is_Single_Task_Object
(Spec_Id
) then
22127 Set_SPARK_Pragma
(Spec_Typ
, N
);
22128 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
22129 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
22130 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
22132 end Process_Overloadable
;
22134 --------------------------
22135 -- Process_Private_Part --
22136 --------------------------
22138 procedure Process_Private_Part
(Decl
: Node_Id
) is
22139 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22142 Check_Library_Level_Entity
(Spec_Id
);
22144 -- Verify the legality against:
22145 -- * The mode of the visible declarations
22147 Check_Pragma_Conformance
22148 (Context_Pragma
=> Empty
,
22150 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
22153 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22154 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
22155 end Process_Private_Part
;
22157 ----------------------------
22158 -- Process_Statement_Part --
22159 ----------------------------
22161 procedure Process_Statement_Part
(Decl
: Node_Id
) is
22162 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22165 Check_Library_Level_Entity
(Body_Id
);
22167 -- Verify the legality against:
22168 -- * The mode of the body declarations
22170 Check_Pragma_Conformance
22171 (Context_Pragma
=> Empty
,
22173 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
22176 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
22177 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
22178 end Process_Statement_Part
;
22180 --------------------------
22181 -- Process_Visible_Part --
22182 --------------------------
22184 procedure Process_Visible_Part
(Decl
: Node_Id
) is
22185 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
22186 Obj_Id
: Entity_Id
;
22189 Check_Library_Level_Entity
(Spec_Id
);
22191 -- Verify the legality against:
22192 -- * The mode of the context
22194 Check_Pragma_Conformance
22195 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
22197 Entity_Pragma
=> Empty
);
22199 -- A task unit declared without a definition does not set the
22200 -- SPARK_Mode of the context because the task does not have any
22201 -- entries that could inherit the mode.
22203 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
22204 N_Task_Type_Declaration
)
22209 Set_SPARK_Pragma
(Spec_Id
, N
);
22210 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
22211 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
22212 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
22214 -- When the pragma applies to a single protected or task type,
22215 -- decorate the corresponding anonymous object as well.
22217 -- protected Anon_Prot_Typ is
22218 -- pragma SPARK_Mode ...;
22220 -- end Anon_Prot_Typ;
22222 -- Obj : Anon_Prot_Typ;
22224 if Is_Single_Concurrent_Type
(Spec_Id
) then
22225 Obj_Id
:= Anonymous_Object
(Spec_Id
);
22227 Set_SPARK_Pragma
(Obj_Id
, N
);
22228 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
22230 end Process_Visible_Part
;
22232 -----------------------
22233 -- Set_SPARK_Context --
22234 -----------------------
22236 procedure Set_SPARK_Context
is
22238 SPARK_Mode
:= Mode_Id
;
22239 SPARK_Mode_Pragma
:= N
;
22240 end Set_SPARK_Context
;
22248 -- Start of processing for Do_SPARK_Mode
22251 -- When a SPARK_Mode pragma appears inside an instantiation whose
22252 -- enclosing context has SPARK_Mode set to "off", the pragma has
22253 -- no semantic effect.
22255 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
22256 Rewrite
(N
, Make_Null_Statement
(Loc
));
22262 Check_No_Identifiers
;
22263 Check_At_Most_N_Arguments
(1);
22265 -- Check the legality of the mode (no argument = ON)
22267 if Arg_Count
= 1 then
22268 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22269 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
22274 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
22275 Context
:= Parent
(N
);
22277 -- The pragma appears in a configuration file
22279 if No
(Context
) then
22280 Check_Valid_Configuration_Pragma
;
22282 if Present
(SPARK_Mode_Pragma
) then
22285 Prev
=> SPARK_Mode_Pragma
);
22291 -- The pragma acts as a configuration pragma in a compilation unit
22293 -- pragma SPARK_Mode ...;
22294 -- package Pack is ...;
22296 elsif Nkind
(Context
) = N_Compilation_Unit
22297 and then List_Containing
(N
) = Context_Items
(Context
)
22299 Check_Valid_Configuration_Pragma
;
22302 -- Otherwise the placement of the pragma within the tree dictates
22303 -- its associated construct. Inspect the declarative list where
22304 -- the pragma resides to find a potential construct.
22308 while Present
(Stmt
) loop
22310 -- Skip prior pragmas, but check for duplicates. Note that
22311 -- this also takes care of pragmas generated for aspects.
22313 if Nkind
(Stmt
) = N_Pragma
then
22314 if Pragma_Name
(Stmt
) = Pname
then
22321 -- The pragma applies to an expression function that has
22322 -- already been rewritten into a subprogram declaration.
22324 -- function Expr_Func return ... is (...);
22325 -- pragma SPARK_Mode ...;
22327 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
22328 and then Nkind
(Original_Node
(Stmt
)) =
22329 N_Expression_Function
22331 Process_Overloadable
(Stmt
);
22334 -- The pragma applies to the anonymous object created for a
22335 -- single concurrent type.
22337 -- protected type Anon_Prot_Typ ...;
22338 -- Obj : Anon_Prot_Typ;
22339 -- pragma SPARK_Mode ...;
22341 elsif Nkind
(Stmt
) = N_Object_Declaration
22342 and then Is_Single_Concurrent_Object
22343 (Defining_Entity
(Stmt
))
22345 Process_Overloadable
(Stmt
);
22348 -- Skip internally generated code
22350 elsif not Comes_From_Source
(Stmt
) then
22353 -- The pragma applies to an entry or [generic] subprogram
22357 -- pragma SPARK_Mode ...;
22360 -- procedure Proc ...;
22361 -- pragma SPARK_Mode ...;
22363 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
22364 N_Subprogram_Declaration
)
22365 or else (Nkind
(Stmt
) = N_Entry_Declaration
22366 and then Is_Protected_Type
22367 (Scope
(Defining_Entity
(Stmt
))))
22369 Process_Overloadable
(Stmt
);
22372 -- Otherwise the pragma does not apply to a legal construct
22373 -- or it does not appear at the top of a declarative or a
22374 -- statement list. Issue an error and stop the analysis.
22384 -- The pragma applies to a package or a subprogram that acts as
22385 -- a compilation unit.
22387 -- procedure Proc ...;
22388 -- pragma SPARK_Mode ...;
22390 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
22391 Context
:= Unit
(Parent
(Context
));
22394 -- The pragma appears at the top of entry, package, protected
22395 -- unit, subprogram or task unit body declarations.
22397 -- entry Ent when ... is
22398 -- pragma SPARK_Mode ...;
22400 -- package body Pack is
22401 -- pragma SPARK_Mode ...;
22403 -- procedure Proc ... is
22404 -- pragma SPARK_Mode;
22406 -- protected body Prot is
22407 -- pragma SPARK_Mode ...;
22409 if Nkind_In
(Context
, N_Entry_Body
,
22415 Process_Body
(Context
);
22417 -- The pragma appears at the top of the visible or private
22418 -- declaration of a package spec, protected or task unit.
22421 -- pragma SPARK_Mode ...;
22423 -- pragma SPARK_Mode ...;
22425 -- protected [type] Prot is
22426 -- pragma SPARK_Mode ...;
22428 -- pragma SPARK_Mode ...;
22430 elsif Nkind_In
(Context
, N_Package_Specification
,
22431 N_Protected_Definition
,
22434 if List_Containing
(N
) = Visible_Declarations
(Context
) then
22435 Process_Visible_Part
(Parent
(Context
));
22437 Process_Private_Part
(Parent
(Context
));
22440 -- The pragma appears at the top of package body statements
22442 -- package body Pack is
22444 -- pragma SPARK_Mode;
22446 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
22447 and then Nkind
(Parent
(Context
)) = N_Package_Body
22449 Process_Statement_Part
(Parent
(Context
));
22451 -- The pragma appeared as an aspect of a [generic] subprogram
22452 -- declaration that acts as a compilation unit.
22455 -- procedure Proc ...;
22456 -- pragma SPARK_Mode ...;
22458 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
22459 N_Subprogram_Declaration
)
22461 Process_Overloadable
(Context
);
22463 -- The pragma does not apply to a legal construct, issue error
22471 --------------------------------
22472 -- Static_Elaboration_Desired --
22473 --------------------------------
22475 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
22477 when Pragma_Static_Elaboration_Desired
=>
22479 Check_At_Most_N_Arguments
(1);
22481 if Is_Compilation_Unit
(Current_Scope
)
22482 and then Ekind
(Current_Scope
) = E_Package
22484 Set_Static_Elaboration_Desired
(Current_Scope
, True);
22486 Error_Pragma
("pragma% must apply to a library-level package");
22493 -- pragma Storage_Size (EXPRESSION);
22495 when Pragma_Storage_Size
=> Storage_Size
: declare
22496 P
: constant Node_Id
:= Parent
(N
);
22500 Check_No_Identifiers
;
22501 Check_Arg_Count
(1);
22503 -- The expression must be analyzed in the special manner described
22504 -- in "Handling of Default Expressions" in sem.ads.
22506 Arg
:= Get_Pragma_Arg
(Arg1
);
22507 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22509 if not Is_OK_Static_Expression
(Arg
) then
22510 Check_Restriction
(Static_Storage_Size
, Arg
);
22513 if Nkind
(P
) /= N_Task_Definition
then
22518 if Has_Storage_Size_Pragma
(P
) then
22519 Error_Pragma
("duplicate pragma% not allowed");
22521 Set_Has_Storage_Size_Pragma
(P
, True);
22524 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
22532 -- pragma Storage_Unit (NUMERIC_LITERAL);
22534 -- Only permitted argument is System'Storage_Unit value
22536 when Pragma_Storage_Unit
=>
22537 Check_No_Identifiers
;
22538 Check_Arg_Count
(1);
22539 Check_Arg_Is_Integer_Literal
(Arg1
);
22541 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
22542 UI_From_Int
(Ttypes
.System_Storage_Unit
)
22544 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
22546 ("the only allowed argument for pragma% is ^", Arg1
);
22549 --------------------
22550 -- Stream_Convert --
22551 --------------------
22553 -- pragma Stream_Convert (
22554 -- [Entity =>] type_LOCAL_NAME,
22555 -- [Read =>] function_NAME,
22556 -- [Write =>] function NAME);
22558 when Pragma_Stream_Convert
=> Stream_Convert
: declare
22559 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
22560 -- Check that the given argument is the name of a local function
22561 -- of one argument that is not overloaded earlier in the current
22562 -- local scope. A check is also made that the argument is a
22563 -- function with one parameter.
22565 --------------------------------------
22566 -- Check_OK_Stream_Convert_Function --
22567 --------------------------------------
22569 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
22573 Check_Arg_Is_Local_Name
(Arg
);
22574 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
22576 if Has_Homonym
(Ent
) then
22578 ("argument for pragma% may not be overloaded", Arg
);
22581 if Ekind
(Ent
) /= E_Function
22582 or else No
(First_Formal
(Ent
))
22583 or else Present
(Next_Formal
(First_Formal
(Ent
)))
22586 ("argument for pragma% must be function of one argument",
22589 end Check_OK_Stream_Convert_Function
;
22591 -- Start of processing for Stream_Convert
22595 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
22596 Check_Arg_Count
(3);
22597 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22598 Check_Optional_Identifier
(Arg2
, Name_Read
);
22599 Check_Optional_Identifier
(Arg3
, Name_Write
);
22600 Check_Arg_Is_Local_Name
(Arg1
);
22601 Check_OK_Stream_Convert_Function
(Arg2
);
22602 Check_OK_Stream_Convert_Function
(Arg3
);
22605 Typ
: constant Entity_Id
:=
22606 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
22607 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
22608 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
22611 Check_First_Subtype
(Arg1
);
22613 -- Check for too early or too late. Note that we don't enforce
22614 -- the rule about primitive operations in this case, since, as
22615 -- is the case for explicit stream attributes themselves, these
22616 -- restrictions are not appropriate. Note that the chaining of
22617 -- the pragma by Rep_Item_Too_Late is actually the critical
22618 -- processing done for this pragma.
22620 if Rep_Item_Too_Early
(Typ
, N
)
22622 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
22627 -- Return if previous error
22629 if Etype
(Typ
) = Any_Type
22631 Etype
(Read
) = Any_Type
22633 Etype
(Write
) = Any_Type
22640 if Underlying_Type
(Etype
(Read
)) /= Typ
then
22642 ("incorrect return type for function&", Arg2
);
22645 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
22647 ("incorrect parameter type for function&", Arg3
);
22650 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
22651 Underlying_Type
(Etype
(Write
))
22654 ("result type of & does not match Read parameter type",
22658 end Stream_Convert
;
22664 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22666 -- This is processed by the parser since some of the style checks
22667 -- take place during source scanning and parsing. This means that
22668 -- we don't need to issue error messages here.
22670 when Pragma_Style_Checks
=> Style_Checks
: declare
22671 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22677 Check_No_Identifiers
;
22679 -- Two argument form
22681 if Arg_Count
= 2 then
22682 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22689 E_Id
:= Get_Pragma_Arg
(Arg2
);
22692 if not Is_Entity_Name
(E_Id
) then
22694 ("second argument of pragma% must be entity name",
22698 E
:= Entity
(E_Id
);
22700 if not Ignore_Style_Checks_Pragmas
then
22705 Set_Suppress_Style_Checks
22706 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
22707 exit when No
(Homonym
(E
));
22714 -- One argument form
22717 Check_Arg_Count
(1);
22719 if Nkind
(A
) = N_String_Literal
then
22723 Slen
: constant Natural := Natural (String_Length
(S
));
22724 Options
: String (1 .. Slen
);
22730 C
:= Get_String_Char
(S
, Pos
(J
));
22731 exit when not In_Character_Range
(C
);
22732 Options
(J
) := Get_Character
(C
);
22734 -- If at end of string, set options. As per discussion
22735 -- above, no need to check for errors, since we issued
22736 -- them in the parser.
22739 if not Ignore_Style_Checks_Pragmas
then
22740 Set_Style_Check_Options
(Options
);
22750 elsif Nkind
(A
) = N_Identifier
then
22751 if Chars
(A
) = Name_All_Checks
then
22752 if not Ignore_Style_Checks_Pragmas
then
22754 Set_GNAT_Style_Check_Options
;
22756 Set_Default_Style_Check_Options
;
22760 elsif Chars
(A
) = Name_On
then
22761 if not Ignore_Style_Checks_Pragmas
then
22762 Style_Check
:= True;
22765 elsif Chars
(A
) = Name_Off
then
22766 if not Ignore_Style_Checks_Pragmas
then
22767 Style_Check
:= False;
22778 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22780 when Pragma_Subtitle
=>
22782 Check_Arg_Count
(1);
22783 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
22784 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22791 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22793 when Pragma_Suppress
=>
22794 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
22800 -- pragma Suppress_All;
22802 -- The only check made here is that the pragma has no arguments.
22803 -- There are no placement rules, and the processing required (setting
22804 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22805 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22806 -- then creates and inserts a pragma Suppress (All_Checks).
22808 when Pragma_Suppress_All
=>
22810 Check_Arg_Count
(0);
22812 -------------------------
22813 -- Suppress_Debug_Info --
22814 -------------------------
22816 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22818 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
22819 Nam_Id
: Entity_Id
;
22823 Check_Arg_Count
(1);
22824 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22825 Check_Arg_Is_Local_Name
(Arg1
);
22827 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22829 -- A pragma that applies to a Ghost entity becomes Ghost for the
22830 -- purposes of legality checks and removal of ignored Ghost code.
22832 Mark_Ghost_Pragma
(N
, Nam_Id
);
22833 Set_Debug_Info_Off
(Nam_Id
);
22834 end Suppress_Debug_Info
;
22836 ----------------------------------
22837 -- Suppress_Exception_Locations --
22838 ----------------------------------
22840 -- pragma Suppress_Exception_Locations;
22842 when Pragma_Suppress_Exception_Locations
=>
22844 Check_Arg_Count
(0);
22845 Check_Valid_Configuration_Pragma
;
22846 Exception_Locations_Suppressed
:= True;
22848 -----------------------------
22849 -- Suppress_Initialization --
22850 -----------------------------
22852 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22854 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
22860 Check_Arg_Count
(1);
22861 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22862 Check_Arg_Is_Local_Name
(Arg1
);
22864 E_Id
:= Get_Pragma_Arg
(Arg1
);
22866 if Etype
(E_Id
) = Any_Type
then
22870 E
:= Entity
(E_Id
);
22872 -- A pragma that applies to a Ghost entity becomes Ghost for the
22873 -- purposes of legality checks and removal of ignored Ghost code.
22875 Mark_Ghost_Pragma
(N
, E
);
22877 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
22879 ("pragma% requires variable, type or subtype", Arg1
);
22882 if Rep_Item_Too_Early
(E
, N
)
22884 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
22889 -- For incomplete/private type, set flag on full view
22891 if Is_Incomplete_Or_Private_Type
(E
) then
22892 if No
(Full_View
(Base_Type
(E
))) then
22894 ("argument of pragma% cannot be an incomplete type", Arg1
);
22896 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
22899 -- For first subtype, set flag on base type
22901 elsif Is_First_Subtype
(E
) then
22902 Set_Suppress_Initialization
(Base_Type
(E
));
22904 -- For other than first subtype, set flag on subtype or variable
22907 Set_Suppress_Initialization
(E
);
22915 -- pragma System_Name (DIRECT_NAME);
22917 -- Syntax check: one argument, which must be the identifier GNAT or
22918 -- the identifier GCC, no other identifiers are acceptable.
22920 when Pragma_System_Name
=>
22922 Check_No_Identifiers
;
22923 Check_Arg_Count
(1);
22924 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
22926 -----------------------------
22927 -- Task_Dispatching_Policy --
22928 -----------------------------
22930 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22932 when Pragma_Task_Dispatching_Policy
=> declare
22936 Check_Ada_83_Warning
;
22937 Check_Arg_Count
(1);
22938 Check_No_Identifiers
;
22939 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22940 Check_Valid_Configuration_Pragma
;
22941 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22942 DP
:= Fold_Upper
(Name_Buffer
(1));
22944 if Task_Dispatching_Policy
/= ' '
22945 and then Task_Dispatching_Policy
/= DP
22947 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22949 ("task dispatching policy incompatible with policy#");
22951 -- Set new policy, but always preserve System_Location since we
22952 -- like the error message with the run time name.
22955 Task_Dispatching_Policy
:= DP
;
22957 if Task_Dispatching_Policy_Sloc
/= System_Location
then
22958 Task_Dispatching_Policy_Sloc
:= Loc
;
22967 -- pragma Task_Info (EXPRESSION);
22969 when Pragma_Task_Info
=> Task_Info
: declare
22970 P
: constant Node_Id
:= Parent
(N
);
22976 if Warn_On_Obsolescent_Feature
then
22978 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22979 & "instead?j?", N
);
22982 if Nkind
(P
) /= N_Task_Definition
then
22983 Error_Pragma
("pragma% must appear in task definition");
22986 Check_No_Identifiers
;
22987 Check_Arg_Count
(1);
22989 Analyze_And_Resolve
22990 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
22992 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
22996 Ent
:= Defining_Identifier
(Parent
(P
));
22998 -- Check duplicate pragma before we chain the pragma in the Rep
22999 -- Item chain of Ent.
23002 (Ent
, Name_Task_Info
, Check_Parents
=> False)
23004 Error_Pragma
("duplicate pragma% not allowed");
23007 Record_Rep_Item
(Ent
, N
);
23014 -- pragma Task_Name (string_EXPRESSION);
23016 when Pragma_Task_Name
=> Task_Name
: declare
23017 P
: constant Node_Id
:= Parent
(N
);
23022 Check_No_Identifiers
;
23023 Check_Arg_Count
(1);
23025 Arg
:= Get_Pragma_Arg
(Arg1
);
23027 -- The expression is used in the call to Create_Task, and must be
23028 -- expanded there, not in the context of the current spec. It must
23029 -- however be analyzed to capture global references, in case it
23030 -- appears in a generic context.
23032 Preanalyze_And_Resolve
(Arg
, Standard_String
);
23034 if Nkind
(P
) /= N_Task_Definition
then
23038 Ent
:= Defining_Identifier
(Parent
(P
));
23040 -- Check duplicate pragma before we chain the pragma in the Rep
23041 -- Item chain of Ent.
23044 (Ent
, Name_Task_Name
, Check_Parents
=> False)
23046 Error_Pragma
("duplicate pragma% not allowed");
23049 Record_Rep_Item
(Ent
, N
);
23056 -- pragma Task_Storage (
23057 -- [Task_Type =>] LOCAL_NAME,
23058 -- [Top_Guard =>] static_integer_EXPRESSION);
23060 when Pragma_Task_Storage
=> Task_Storage
: declare
23061 Args
: Args_List
(1 .. 2);
23062 Names
: constant Name_List
(1 .. 2) := (
23066 Task_Type
: Node_Id
renames Args
(1);
23067 Top_Guard
: Node_Id
renames Args
(2);
23073 Gather_Associations
(Names
, Args
);
23075 if No
(Task_Type
) then
23077 ("missing task_type argument for pragma%");
23080 Check_Arg_Is_Local_Name
(Task_Type
);
23082 Ent
:= Entity
(Task_Type
);
23084 if not Is_Task_Type
(Ent
) then
23086 ("argument for pragma% must be task type", Task_Type
);
23089 if No
(Top_Guard
) then
23091 ("pragma% takes two arguments", Task_Type
);
23093 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
23096 Check_First_Subtype
(Task_Type
);
23098 if Rep_Item_Too_Late
(Ent
, N
) then
23107 -- pragma Test_Case
23108 -- ([Name =>] Static_String_EXPRESSION
23109 -- ,[Mode =>] MODE_TYPE
23110 -- [, Requires => Boolean_EXPRESSION]
23111 -- [, Ensures => Boolean_EXPRESSION]);
23113 -- MODE_TYPE ::= Nominal | Robustness
23115 -- Characteristics:
23117 -- * Analysis - The annotation undergoes initial checks to verify
23118 -- the legal placement and context. Secondary checks preanalyze the
23121 -- Analyze_Test_Case_In_Decl_Part
23123 -- * Expansion - None.
23125 -- * Template - The annotation utilizes the generic template of the
23126 -- related subprogram when it is:
23128 -- aspect on subprogram declaration
23130 -- The annotation must prepare its own template when it is:
23132 -- pragma on subprogram declaration
23134 -- * Globals - Capture of global references must occur after full
23137 -- * Instance - The annotation is instantiated automatically when
23138 -- the related generic subprogram is instantiated except for the
23139 -- "pragma on subprogram declaration" case. In that scenario the
23140 -- annotation must instantiate itself.
23142 when Pragma_Test_Case
=> Test_Case
: declare
23143 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
23144 -- Ensure that the contract of subprogram Subp_Id does not contain
23145 -- another Test_Case pragma with the same Name as the current one.
23147 -------------------------
23148 -- Check_Distinct_Name --
23149 -------------------------
23151 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
23152 Items
: constant Node_Id
:= Contract
(Subp_Id
);
23153 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
23157 -- Inspect all Test_Case pragma of the related subprogram
23158 -- looking for one with a duplicate "Name" argument.
23160 if Present
(Items
) then
23161 Prag
:= Contract_Test_Cases
(Items
);
23162 while Present
(Prag
) loop
23163 if Pragma_Name
(Prag
) = Name_Test_Case
23165 and then String_Equal
23166 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
23168 Error_Msg_Sloc
:= Sloc
(Prag
);
23169 Error_Pragma
("name for pragma % is already used #");
23172 Prag
:= Next_Pragma
(Prag
);
23175 end Check_Distinct_Name
;
23179 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
23182 Subp_Decl
: Node_Id
;
23183 Subp_Id
: Entity_Id
;
23185 -- Start of processing for Test_Case
23189 Check_At_Least_N_Arguments
(2);
23190 Check_At_Most_N_Arguments
(4);
23192 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
23196 Check_Optional_Identifier
(Arg1
, Name_Name
);
23197 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
23201 Check_Optional_Identifier
(Arg2
, Name_Mode
);
23202 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
23204 -- Arguments "Requires" and "Ensures"
23206 if Present
(Arg3
) then
23207 if Present
(Arg4
) then
23208 Check_Identifier
(Arg3
, Name_Requires
);
23209 Check_Identifier
(Arg4
, Name_Ensures
);
23211 Check_Identifier_Is_One_Of
23212 (Arg3
, Name_Requires
, Name_Ensures
);
23216 -- Pragma Test_Case must be associated with a subprogram declared
23217 -- in a library-level package. First determine whether the current
23218 -- compilation unit is a legal context.
23220 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
23221 N_Generic_Package_Declaration
)
23225 -- Otherwise the placement is illegal
23229 ("pragma % must be specified within a package declaration");
23233 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
23235 -- Find the enclosing context
23237 Context
:= Parent
(Subp_Decl
);
23239 if Present
(Context
) then
23240 Context
:= Parent
(Context
);
23243 -- Verify the placement of the pragma
23245 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
23247 ("pragma % cannot be applied to abstract subprogram");
23250 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
23251 Error_Pragma
("pragma % cannot be applied to entry");
23254 -- The context is a [generic] subprogram declared at the top level
23255 -- of the [generic] package unit.
23257 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
23258 N_Subprogram_Declaration
)
23259 and then Present
(Context
)
23260 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
23261 N_Package_Declaration
)
23265 -- Otherwise the placement is illegal
23269 ("pragma % must be applied to a library-level subprogram "
23274 Subp_Id
:= Defining_Entity
(Subp_Decl
);
23276 -- A pragma that applies to a Ghost entity becomes Ghost for the
23277 -- purposes of legality checks and removal of ignored Ghost code.
23279 Mark_Ghost_Pragma
(N
, Subp_Id
);
23281 -- Chain the pragma on the contract for further processing by
23282 -- Analyze_Test_Case_In_Decl_Part.
23284 Add_Contract_Item
(N
, Subp_Id
);
23286 -- Preanalyze the original aspect argument "Name" for ASIS or for
23287 -- a generic subprogram to properly capture global references.
23289 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
23290 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
23292 if Present
(Asp_Arg
) then
23294 -- The argument appears with an identifier in association
23297 if Nkind
(Asp_Arg
) = N_Component_Association
then
23298 Asp_Arg
:= Expression
(Asp_Arg
);
23301 Check_Expr_Is_OK_Static_Expression
23302 (Asp_Arg
, Standard_String
);
23306 -- Ensure that the all Test_Case pragmas of the related subprogram
23307 -- have distinct names.
23309 Check_Distinct_Name
(Subp_Id
);
23311 -- Fully analyze the pragma when it appears inside an entry
23312 -- or subprogram body because it cannot benefit from forward
23315 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
23317 N_Subprogram_Body_Stub
)
23319 -- The legality checks of pragma Test_Case are affected by the
23320 -- SPARK mode in effect and the volatility of the context.
23321 -- Analyze all pragmas in a specific order.
23323 Analyze_If_Present
(Pragma_SPARK_Mode
);
23324 Analyze_If_Present
(Pragma_Volatile_Function
);
23325 Analyze_Test_Case_In_Decl_Part
(N
);
23329 --------------------------
23330 -- Thread_Local_Storage --
23331 --------------------------
23333 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
23335 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
23341 Check_Arg_Count
(1);
23342 Check_Optional_Identifier
(Arg1
, Name_Entity
);
23343 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
23345 Id
:= Get_Pragma_Arg
(Arg1
);
23348 if not Is_Entity_Name
(Id
)
23349 or else Ekind
(Entity
(Id
)) /= E_Variable
23351 Error_Pragma_Arg
("local variable name required", Arg1
);
23356 -- A pragma that applies to a Ghost entity becomes Ghost for the
23357 -- purposes of legality checks and removal of ignored Ghost code.
23359 Mark_Ghost_Pragma
(N
, E
);
23361 if Rep_Item_Too_Early
(E
, N
)
23363 Rep_Item_Too_Late
(E
, N
)
23368 Set_Has_Pragma_Thread_Local_Storage
(E
);
23369 Set_Has_Gigi_Rep_Item
(E
);
23370 end Thread_Local_Storage
;
23376 -- pragma Time_Slice (static_duration_EXPRESSION);
23378 when Pragma_Time_Slice
=> Time_Slice
: declare
23384 Check_Arg_Count
(1);
23385 Check_No_Identifiers
;
23386 Check_In_Main_Program
;
23387 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
23389 if not Error_Posted
(Arg1
) then
23391 while Present
(Nod
) loop
23392 if Nkind
(Nod
) = N_Pragma
23393 and then Pragma_Name
(Nod
) = Name_Time_Slice
23395 Error_Msg_Name_1
:= Pname
;
23396 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
23403 -- Process only if in main unit
23405 if Get_Source_Unit
(Loc
) = Main_Unit
then
23406 Opt
.Time_Slice_Set
:= True;
23407 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
23409 if Val
<= Ureal_0
then
23410 Opt
.Time_Slice_Value
:= 0;
23412 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
23413 Opt
.Time_Slice_Value
:= 1_000_000_000
;
23416 Opt
.Time_Slice_Value
:=
23417 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
23426 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
23428 -- TITLING_OPTION ::=
23429 -- [Title =>] STRING_LITERAL
23430 -- | [Subtitle =>] STRING_LITERAL
23432 when Pragma_Title
=> Title
: declare
23433 Args
: Args_List
(1 .. 2);
23434 Names
: constant Name_List
(1 .. 2) := (
23440 Gather_Associations
(Names
, Args
);
23443 for J
in 1 .. 2 loop
23444 if Present
(Args
(J
)) then
23445 Check_Arg_Is_OK_Static_Expression
23446 (Args
(J
), Standard_String
);
23451 ----------------------------
23452 -- Type_Invariant[_Class] --
23453 ----------------------------
23455 -- pragma Type_Invariant[_Class]
23456 -- ([Entity =>] type_LOCAL_NAME,
23457 -- [Check =>] EXPRESSION);
23459 when Pragma_Type_Invariant
23460 | Pragma_Type_Invariant_Class
23462 Type_Invariant
: declare
23463 I_Pragma
: Node_Id
;
23466 Check_Arg_Count
(2);
23468 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
23469 -- setting Class_Present for the Type_Invariant_Class case.
23471 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
23472 I_Pragma
:= New_Copy
(N
);
23473 Set_Pragma_Identifier
23474 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
23475 Rewrite
(N
, I_Pragma
);
23476 Set_Analyzed
(N
, False);
23478 end Type_Invariant
;
23480 ---------------------
23481 -- Unchecked_Union --
23482 ---------------------
23484 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
23486 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
23487 Assoc
: constant Node_Id
:= Arg1
;
23488 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
23498 Check_No_Identifiers
;
23499 Check_Arg_Count
(1);
23500 Check_Arg_Is_Local_Name
(Arg1
);
23502 Find_Type
(Type_Id
);
23504 Typ
:= Entity
(Type_Id
);
23506 -- A pragma that applies to a Ghost entity becomes Ghost for the
23507 -- purposes of legality checks and removal of ignored Ghost code.
23509 Mark_Ghost_Pragma
(N
, Typ
);
23512 or else Rep_Item_Too_Early
(Typ
, N
)
23516 Typ
:= Underlying_Type
(Typ
);
23519 if Rep_Item_Too_Late
(Typ
, N
) then
23523 Check_First_Subtype
(Arg1
);
23525 -- Note remaining cases are references to a type in the current
23526 -- declarative part. If we find an error, we post the error on
23527 -- the relevant type declaration at an appropriate point.
23529 if not Is_Record_Type
(Typ
) then
23530 Error_Msg_N
("unchecked union must be record type", Typ
);
23533 elsif Is_Tagged_Type
(Typ
) then
23534 Error_Msg_N
("unchecked union must not be tagged", Typ
);
23537 elsif not Has_Discriminants
(Typ
) then
23539 ("unchecked union must have one discriminant", Typ
);
23542 -- Note: in previous versions of GNAT we used to check for limited
23543 -- types and give an error, but in fact the standard does allow
23544 -- Unchecked_Union on limited types, so this check was removed.
23546 -- Similarly, GNAT used to require that all discriminants have
23547 -- default values, but this is not mandated by the RM.
23549 -- Proceed with basic error checks completed
23552 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
23553 Clist
:= Component_List
(Tdef
);
23555 -- Check presence of component list and variant part
23557 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
23559 ("unchecked union must have variant part", Tdef
);
23563 -- Check components
23565 Comp
:= First_Non_Pragma
(Component_Items
(Clist
));
23566 while Present
(Comp
) loop
23567 Check_Component
(Comp
, Typ
);
23568 Next_Non_Pragma
(Comp
);
23571 -- Check variant part
23573 Vpart
:= Variant_Part
(Clist
);
23575 Variant
:= First_Non_Pragma
(Variants
(Vpart
));
23576 while Present
(Variant
) loop
23577 Check_Variant
(Variant
, Typ
);
23578 Next_Non_Pragma
(Variant
);
23582 Set_Is_Unchecked_Union
(Typ
);
23583 Set_Convention
(Typ
, Convention_C
);
23584 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
23585 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
23586 end Unchecked_Union
;
23588 ----------------------------
23589 -- Unevaluated_Use_Of_Old --
23590 ----------------------------
23592 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23594 when Pragma_Unevaluated_Use_Of_Old
=>
23596 Check_Arg_Count
(1);
23597 Check_No_Identifiers
;
23598 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
23600 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23601 -- a declarative part or a package spec.
23603 if not Is_Configuration_Pragma
then
23604 Check_Is_In_Decl_Part_Or_Package_Spec
;
23607 -- Store proper setting of Uneval_Old
23609 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23610 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
23612 ------------------------
23613 -- Unimplemented_Unit --
23614 ------------------------
23616 -- pragma Unimplemented_Unit;
23618 -- Note: this only gives an error if we are generating code, or if
23619 -- we are in a generic library unit (where the pragma appears in the
23620 -- body, not in the spec).
23622 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
23623 Cunitent
: constant Entity_Id
:=
23624 Cunit_Entity
(Get_Source_Unit
(Loc
));
23625 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
23629 Check_Arg_Count
(0);
23631 if Operating_Mode
= Generate_Code
23632 or else Ent_Kind
= E_Generic_Function
23633 or else Ent_Kind
= E_Generic_Procedure
23634 or else Ent_Kind
= E_Generic_Package
23636 Get_Name_String
(Chars
(Cunitent
));
23637 Set_Casing
(Mixed_Case
);
23638 Write_Str
(Name_Buffer
(1 .. Name_Len
));
23639 Write_Str
(" is not supported in this configuration");
23641 raise Unrecoverable_Error
;
23643 end Unimplemented_Unit
;
23645 ------------------------
23646 -- Universal_Aliasing --
23647 ------------------------
23649 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23651 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
23657 Check_Arg_Count
(1);
23658 Check_Optional_Identifier
(Arg2
, Name_Entity
);
23659 Check_Arg_Is_Local_Name
(Arg1
);
23660 E_Id
:= Get_Pragma_Arg
(Arg1
);
23662 if Etype
(E_Id
) = Any_Type
then
23666 E
:= Entity
(E_Id
);
23668 if not Is_Type
(E
) then
23669 Error_Pragma_Arg
("pragma% requires type", Arg1
);
23672 -- A pragma that applies to a Ghost entity becomes Ghost for the
23673 -- purposes of legality checks and removal of ignored Ghost code.
23675 Mark_Ghost_Pragma
(N
, E
);
23676 Set_Universal_Aliasing
(Base_Type
(E
));
23677 Record_Rep_Item
(E
, N
);
23678 end Universal_Alias
;
23680 --------------------
23681 -- Universal_Data --
23682 --------------------
23684 -- pragma Universal_Data [(library_unit_NAME)];
23686 when Pragma_Universal_Data
=>
23688 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
23694 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23696 when Pragma_Unmodified
=>
23697 Analyze_Unmodified_Or_Unused
;
23703 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23705 -- or when used in a context clause:
23707 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23709 when Pragma_Unreferenced
=>
23710 Analyze_Unreferenced_Or_Unused
;
23712 --------------------------
23713 -- Unreferenced_Objects --
23714 --------------------------
23716 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23718 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
23720 Arg_Expr
: Node_Id
;
23721 Arg_Id
: Entity_Id
;
23723 Ghost_Error_Posted
: Boolean := False;
23724 -- Flag set when an error concerning the illegal mix of Ghost and
23725 -- non-Ghost types is emitted.
23727 Ghost_Id
: Entity_Id
:= Empty
;
23728 -- The entity of the first Ghost type encountered while processing
23729 -- the arguments of the pragma.
23733 Check_At_Least_N_Arguments
(1);
23736 while Present
(Arg
) loop
23737 Check_No_Identifier
(Arg
);
23738 Check_Arg_Is_Local_Name
(Arg
);
23739 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
23741 if Is_Entity_Name
(Arg_Expr
) then
23742 Arg_Id
:= Entity
(Arg_Expr
);
23744 if Is_Type
(Arg_Id
) then
23745 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
23747 -- A pragma that applies to a Ghost entity becomes Ghost
23748 -- for the purposes of legality checks and removal of
23749 -- ignored Ghost code.
23751 Mark_Ghost_Pragma
(N
, Arg_Id
);
23753 -- Capture the entity of the first Ghost type being
23754 -- processed for error detection purposes.
23756 if Is_Ghost_Entity
(Arg_Id
) then
23757 if No
(Ghost_Id
) then
23758 Ghost_Id
:= Arg_Id
;
23761 -- Otherwise the type is non-Ghost. It is illegal to mix
23762 -- references to Ghost and non-Ghost entities
23765 elsif Present
(Ghost_Id
)
23766 and then not Ghost_Error_Posted
23768 Ghost_Error_Posted
:= True;
23770 Error_Msg_Name_1
:= Pname
;
23772 ("pragma % cannot mention ghost and non-ghost types",
23775 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
23776 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
23778 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
23779 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
23783 ("argument for pragma% must be type or subtype", Arg
);
23787 ("argument for pragma% must be type or subtype", Arg
);
23792 end Unreferenced_Objects
;
23794 ------------------------------
23795 -- Unreserve_All_Interrupts --
23796 ------------------------------
23798 -- pragma Unreserve_All_Interrupts;
23800 when Pragma_Unreserve_All_Interrupts
=>
23802 Check_Arg_Count
(0);
23804 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
23805 Unreserve_All_Interrupts
:= True;
23812 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23814 when Pragma_Unsuppress
=>
23816 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
23822 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23824 when Pragma_Unused
=>
23825 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
23826 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
23828 -------------------
23829 -- Use_VADS_Size --
23830 -------------------
23832 -- pragma Use_VADS_Size;
23834 when Pragma_Use_VADS_Size
=>
23836 Check_Arg_Count
(0);
23837 Check_Valid_Configuration_Pragma
;
23838 Use_VADS_Size
:= True;
23840 ---------------------
23841 -- Validity_Checks --
23842 ---------------------
23844 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23846 when Pragma_Validity_Checks
=> Validity_Checks
: declare
23847 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23853 Check_Arg_Count
(1);
23854 Check_No_Identifiers
;
23856 -- Pragma always active unless in CodePeer or GNATprove modes,
23857 -- which use a fixed configuration of validity checks.
23859 if not (CodePeer_Mode
or GNATprove_Mode
) then
23860 if Nkind
(A
) = N_String_Literal
then
23864 Slen
: constant Natural := Natural (String_Length
(S
));
23865 Options
: String (1 .. Slen
);
23869 -- Couldn't we use a for loop here over Options'Range???
23873 C
:= Get_String_Char
(S
, Pos
(J
));
23875 -- This is a weird test, it skips setting validity
23876 -- checks entirely if any element of S is out of
23877 -- range of Character, what is that about ???
23879 exit when not In_Character_Range
(C
);
23880 Options
(J
) := Get_Character
(C
);
23883 Set_Validity_Check_Options
(Options
);
23891 elsif Nkind
(A
) = N_Identifier
then
23892 if Chars
(A
) = Name_All_Checks
then
23893 Set_Validity_Check_Options
("a");
23894 elsif Chars
(A
) = Name_On
then
23895 Validity_Checks_On
:= True;
23896 elsif Chars
(A
) = Name_Off
then
23897 Validity_Checks_On
:= False;
23901 end Validity_Checks
;
23907 -- pragma Volatile (LOCAL_NAME);
23909 when Pragma_Volatile
=>
23910 Process_Atomic_Independent_Shared_Volatile
;
23912 -------------------------
23913 -- Volatile_Components --
23914 -------------------------
23916 -- pragma Volatile_Components (array_LOCAL_NAME);
23918 -- Volatile is handled by the same circuit as Atomic_Components
23920 --------------------------
23921 -- Volatile_Full_Access --
23922 --------------------------
23924 -- pragma Volatile_Full_Access (LOCAL_NAME);
23926 when Pragma_Volatile_Full_Access
=>
23928 Process_Atomic_Independent_Shared_Volatile
;
23930 -----------------------
23931 -- Volatile_Function --
23932 -----------------------
23934 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23936 when Pragma_Volatile_Function
=> Volatile_Function
: declare
23937 Over_Id
: Entity_Id
;
23938 Spec_Id
: Entity_Id
;
23939 Subp_Decl
: Node_Id
;
23943 Check_No_Identifiers
;
23944 Check_At_Most_N_Arguments
(1);
23947 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23949 -- Generic subprogram
23951 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23954 -- Body acts as spec
23956 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23957 and then No
(Corresponding_Spec
(Subp_Decl
))
23961 -- Body stub acts as spec
23963 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23964 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23970 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23978 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23980 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
23985 -- A pragma that applies to a Ghost entity becomes Ghost for the
23986 -- purposes of legality checks and removal of ignored Ghost code.
23988 Mark_Ghost_Pragma
(N
, Spec_Id
);
23990 -- Chain the pragma on the contract for completeness
23992 Add_Contract_Item
(N
, Spec_Id
);
23994 -- The legality checks of pragma Volatile_Function are affected by
23995 -- the SPARK mode in effect. Analyze all pragmas in a specific
23998 Analyze_If_Present
(Pragma_SPARK_Mode
);
24000 -- A volatile function cannot override a non-volatile function
24001 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
24002 -- in New_Overloaded_Entity, however at that point the pragma has
24003 -- not been processed yet.
24005 Over_Id
:= Overridden_Operation
(Spec_Id
);
24007 if Present
(Over_Id
)
24008 and then not Is_Volatile_Function
(Over_Id
)
24011 ("incompatible volatile function values in effect", Spec_Id
);
24013 Error_Msg_Sloc
:= Sloc
(Over_Id
);
24015 ("\& declared # with Volatile_Function value False",
24018 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
24020 ("\overridden # with Volatile_Function value True",
24024 -- Analyze the Boolean expression (if any)
24026 if Present
(Arg1
) then
24027 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
24029 end Volatile_Function
;
24031 ----------------------
24032 -- Warning_As_Error --
24033 ----------------------
24035 -- pragma Warning_As_Error (static_string_EXPRESSION);
24037 when Pragma_Warning_As_Error
=>
24039 Check_Arg_Count
(1);
24040 Check_No_Identifiers
;
24041 Check_Valid_Configuration_Pragma
;
24043 if not Is_Static_String_Expression
(Arg1
) then
24045 ("argument of pragma% must be static string expression",
24048 -- OK static string expression
24051 Acquire_Warning_Match_String
(Arg1
);
24052 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
24053 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
24054 new String'(Name_Buffer (1 .. Name_Len));
24061 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
24063 -- DETAILS ::= On | Off
24064 -- DETAILS ::= On | Off, local_NAME
24065 -- DETAILS ::= static_string_EXPRESSION
24066 -- DETAILS ::= On | Off, static_string_EXPRESSION
24068 -- TOOL_NAME ::= GNAT | GNATProve
24070 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
24072 -- Note: If the first argument matches an allowed tool name, it is
24073 -- always considered to be a tool name, even if there is a string
24074 -- variable of that name.
24076 -- Note if the second argument of DETAILS is a local_NAME then the
24077 -- second form is always understood. If the intention is to use
24078 -- the fourth form, then you can write NAME & "" to force the
24079 -- intepretation as a static_string_EXPRESSION.
24081 when Pragma_Warnings => Warnings : declare
24082 Reason : String_Id;
24086 Check_At_Least_N_Arguments (1);
24088 -- See if last argument is labeled Reason. If so, make sure we
24089 -- have a string literal or a concatenation of string literals,
24090 -- and acquire the REASON string. Then remove the REASON argument
24091 -- by decreasing Num_Args by one; Remaining processing looks only
24092 -- at first Num_Args arguments).
24095 Last_Arg : constant Node_Id :=
24096 Last (Pragma_Argument_Associations (N));
24099 if Nkind (Last_Arg) = N_Pragma_Argument_Association
24100 and then Chars (Last_Arg) = Name_Reason
24103 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
24104 Reason := End_String;
24105 Arg_Count := Arg_Count - 1;
24107 -- Not allowed in compiler units (bootstrap issues)
24109 Check_Compiler_Unit ("Reason for pragma Warnings", N);
24111 -- No REASON string, set null string as reason
24114 Reason := Null_String_Id;
24118 -- Now proceed with REASON taken care of and eliminated
24120 Check_No_Identifiers;
24122 -- If debug flag -gnatd.i is set, pragma is ignored
24124 if Debug_Flag_Dot_I then
24128 -- Process various forms of the pragma
24131 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
24132 Shifted_Args : List_Id;
24135 -- See if first argument is a tool name, currently either
24136 -- GNAT or GNATprove. If so, either ignore the pragma if the
24137 -- tool used does not match, or continue as if no tool name
24138 -- was given otherwise, by shifting the arguments.
24140 if Nkind (Argx) = N_Identifier
24141 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
24143 if Chars (Argx) = Name_Gnat then
24144 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
24145 Rewrite (N, Make_Null_Statement (Loc));
24150 elsif Chars (Argx) = Name_Gnatprove then
24151 if not GNATprove_Mode then
24152 Rewrite (N, Make_Null_Statement (Loc));
24158 raise Program_Error;
24161 -- At this point, the pragma Warnings applies to the tool,
24162 -- so continue with shifted arguments.
24164 Arg_Count := Arg_Count - 1;
24166 if Arg_Count = 1 then
24167 Shifted_Args := New_List (New_Copy (Arg2));
24168 elsif Arg_Count = 2 then
24169 Shifted_Args := New_List (New_Copy (Arg2),
24171 elsif Arg_Count = 3 then
24172 Shifted_Args := New_List (New_Copy (Arg2),
24176 raise Program_Error;
24181 Chars => Name_Warnings,
24182 Pragma_Argument_Associations => Shifted_Args));
24187 -- One argument case
24189 if Arg_Count = 1 then
24191 -- On/Off one argument case was processed by parser
24193 if Nkind (Argx) = N_Identifier
24194 and then Nam_In (Chars (Argx), Name_On, Name_Off)
24198 -- One argument case must be ON/OFF or static string expr
24200 elsif not Is_Static_String_Expression (Arg1) then
24202 ("argument of pragma% must be On/Off or static string "
24203 & "expression", Arg1);
24205 -- One argument string expression case
24209 Lit : constant Node_Id := Expr_Value_S (Argx);
24210 Str : constant String_Id := Strval (Lit);
24211 Len : constant Nat := String_Length (Str);
24219 while J <= Len loop
24220 C := Get_String_Char (Str, J);
24221 OK := In_Character_Range (C);
24224 Chr := Get_Character (C);
24226 -- Dash case: only -Wxxx is accepted
24233 C := Get_String_Char (Str, J);
24234 Chr := Get_Character (C);
24235 exit when Chr = 'W
';
24240 elsif J < Len and then Chr = '.' then
24242 C := Get_String_Char (Str, J);
24243 Chr := Get_Character (C);
24245 if not Set_Dot_Warning_Switch (Chr) then
24247 ("invalid warning switch character "
24248 & '.' & Chr, Arg1);
24254 OK := Set_Warning_Switch (Chr);
24259 ("invalid warning switch character " & Chr,
24265 ("invalid wide character in warning switch ",
24274 -- Two or more arguments (must be two)
24277 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
24278 Check_Arg_Count (2);
24286 E_Id := Get_Pragma_Arg (Arg2);
24289 -- In the expansion of an inlined body, a reference to
24290 -- the formal may be wrapped in a conversion if the
24291 -- actual is a conversion. Retrieve the real entity name.
24293 if (In_Instance_Body or In_Inlined_Body)
24294 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
24296 E_Id := Expression (E_Id);
24299 -- Entity name case
24301 if Is_Entity_Name (E_Id) then
24302 E := Entity (E_Id);
24309 (E, (Chars (Get_Pragma_Arg (Arg1)) =
24312 -- For OFF case, make entry in warnings off
24313 -- pragma table for later processing. But we do
24314 -- not do that within an instance, since these
24315 -- warnings are about what is needed in the
24316 -- template, not an instance of it.
24318 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
24319 and then Warn_On_Warnings_Off
24320 and then not In_Instance
24322 Warnings_Off_Pragmas.Append ((N, E, Reason));
24325 if Is_Enumeration_Type (E) then
24329 Lit := First_Literal (E);
24330 while Present (Lit) loop
24331 Set_Warnings_Off (Lit);
24332 Next_Literal (Lit);
24337 exit when No (Homonym (E));
24342 -- Error if not entity or static string expression case
24344 elsif not Is_Static_String_Expression (Arg2) then
24346 ("second argument of pragma% must be entity name "
24347 & "or static string expression", Arg2);
24349 -- Static string expression case
24352 Acquire_Warning_Match_String (Arg2);
24354 -- Note on configuration pragma case: If this is a
24355 -- configuration pragma, then for an OFF pragma, we
24356 -- just set Config True in the call, which is all
24357 -- that needs to be done. For the case of ON, this
24358 -- is normally an error, unless it is canceling the
24359 -- effect of a previous OFF pragma in the same file.
24360 -- In any other case, an error will be signalled (ON
24361 -- with no matching OFF).
24363 -- Note: We set Used if we are inside a generic to
24364 -- disable the test that the non-config case actually
24365 -- cancels a warning. That's because we can't be sure
24366 -- there isn't an instantiation in some other unit
24367 -- where a warning is suppressed.
24369 -- We could do a little better here by checking if the
24370 -- generic unit we are inside is public, but for now
24371 -- we don't bother with that refinement.
24373 if Chars (Argx) = Name_Off then
24374 Set_Specific_Warning_Off
24375 (Loc, Name_Buffer (1 .. Name_Len), Reason,
24376 Config => Is_Configuration_Pragma,
24377 Used => Inside_A_Generic or else In_Instance);
24379 elsif Chars (Argx) = Name_On then
24380 Set_Specific_Warning_On
24381 (Loc, Name_Buffer (1 .. Name_Len), Err);
24385 ("??pragma Warnings On with no matching "
24386 & "Warnings Off", Loc);
24395 -------------------
24396 -- Weak_External --
24397 -------------------
24399 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
24401 when Pragma_Weak_External => Weak_External : declare
24406 Check_Arg_Count (1);
24407 Check_Optional_Identifier (Arg1, Name_Entity);
24408 Check_Arg_Is_Library_Level_Local_Name (Arg1);
24409 Ent := Entity (Get_Pragma_Arg (Arg1));
24411 if Rep_Item_Too_Early (Ent, N) then
24414 Ent := Underlying_Type (Ent);
24417 -- The only processing required is to link this item on to the
24418 -- list of rep items for the given entity. This is accomplished
24419 -- by the call to Rep_Item_Too_Late (when no error is detected
24420 -- and False is returned).
24422 if Rep_Item_Too_Late (Ent, N) then
24425 Set_Has_Gigi_Rep_Item (Ent);
24429 -----------------------------
24430 -- Wide_Character_Encoding --
24431 -----------------------------
24433 -- pragma Wide_Character_Encoding (IDENTIFIER);
24435 when Pragma_Wide_Character_Encoding =>
24438 -- Nothing to do, handled in parser. Note that we do not enforce
24439 -- configuration pragma placement, this pragma can appear at any
24440 -- place in the source, allowing mixed encodings within a single
24445 --------------------
24446 -- Unknown_Pragma --
24447 --------------------
24449 -- Should be impossible, since the case of an unknown pragma is
24450 -- separately processed before the case statement is entered.
24452 when Unknown_Pragma =>
24453 raise Program_Error;
24456 -- AI05-0144: detect dangerous order dependence. Disabled for now,
24457 -- until AI is formally approved.
24459 -- Check_Order_Dependence;
24462 when Pragma_Exit => null;
24463 end Analyze_Pragma;
24465 ---------------------------------------------
24466 -- Analyze_Pre_Post_Condition_In_Decl_Part --
24467 ---------------------------------------------
24469 -- WARNING: This routine manages Ghost regions. Return statements must be
24470 -- replaced by gotos which jump to the end of the routine and restore the
24473 procedure Analyze_Pre_Post_Condition_In_Decl_Part
24475 Freeze_Id : Entity_Id := Empty)
24477 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
24478 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
24480 Disp_Typ : Entity_Id;
24481 -- The dispatching type of the subprogram subject to the pre- or
24484 function Check_References (Nod : Node_Id) return Traverse_Result;
24485 -- Check that expression Nod does not mention non-primitives of the
24486 -- type, global objects of the type, or other illegalities described
24487 -- and implied by AI12-0113.
24489 ----------------------
24490 -- Check_References --
24491 ----------------------
24493 function Check_References (Nod : Node_Id) return Traverse_Result is
24495 if Nkind (Nod) = N_Function_Call
24496 and then Is_Entity_Name (Name (Nod))
24499 Func : constant Entity_Id := Entity (Name (Nod));
24503 -- An operation of the type must be a primitive
24505 if No (Find_Dispatching_Type (Func)) then
24506 Form := First_Formal (Func);
24507 while Present (Form) loop
24508 if Etype (Form) = Disp_Typ then
24510 ("operation in class-wide condition must be "
24511 & "primitive of &", Nod, Disp_Typ);
24514 Next_Formal (Form);
24517 -- A return object of the type is illegal as well
24519 if Etype (Func) = Disp_Typ
24520 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24523 ("operation in class-wide condition must be primitive "
24524 & "of &", Nod, Disp_Typ);
24527 -- Otherwise we have a call to an overridden primitive, and we
24528 -- will create a common class-wide clone for the body of
24529 -- original operation and its eventual inherited versions. If
24530 -- the original operation dispatches on result it is never
24531 -- inherited and there is no need for a clone. There is not
24532 -- need for a clone either in GNATprove mode, as cases that
24533 -- would require it are rejected (when an inherited primitive
24534 -- calls an overridden operation in a class-wide contract), and
24535 -- the clone would make proof impossible in some cases.
24537 elsif not Is_Abstract_Subprogram (Spec_Id)
24538 and then No (Class_Wide_Clone (Spec_Id))
24539 and then not Has_Controlling_Result (Spec_Id)
24540 and then not GNATprove_Mode
24542 Build_Class_Wide_Clone_Decl (Spec_Id);
24546 elsif Is_Entity_Name (Nod)
24548 (Etype (Nod) = Disp_Typ
24549 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24550 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24553 ("object in class-wide condition must be formal of type &",
24556 elsif Nkind (Nod) = N_Explicit_Dereference
24557 and then (Etype (Nod) = Disp_Typ
24558 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24559 and then (not Is_Entity_Name (Prefix (Nod))
24560 or else not Is_Formal (Entity (Prefix (Nod))))
24563 ("operation in class-wide condition must be primitive of &",
24568 end Check_References;
24570 procedure Check_Class_Wide_Condition is
24571 new Traverse_Proc (Check_References);
24575 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24576 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24577 -- Save the Ghost mode to restore on exit
24580 Restore_Scope : Boolean := False;
24582 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24585 -- Do not analyze the pragma multiple times
24587 if Is_Analyzed_Pragma (N) then
24591 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24592 -- analysis of the pragma, the Ghost mode at point of declaration and
24593 -- point of analysis may not necessarily be the same. Use the mode in
24594 -- effect at the point of declaration.
24596 Set_Ghost_Mode (N);
24598 -- Ensure that the subprogram and its formals are visible when analyzing
24599 -- the expression of the pragma.
24601 if not In_Open_Scopes (Spec_Id) then
24602 Restore_Scope := True;
24603 Push_Scope (Spec_Id);
24605 if Is_Generic_Subprogram (Spec_Id) then
24606 Install_Generic_Formals (Spec_Id);
24608 Install_Formals (Spec_Id);
24612 Errors := Serious_Errors_Detected;
24613 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24615 -- Emit a clarification message when the expression contains at least
24616 -- one undefined reference, possibly due to contract freezing.
24618 if Errors /= Serious_Errors_Detected
24619 and then Present (Freeze_Id)
24620 and then Has_Undefined_Reference (Expr)
24622 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24625 if Class_Present (N) then
24627 -- Verify that a class-wide condition is legal, i.e. the operation is
24628 -- a primitive of a tagged type. Note that a generic subprogram is
24629 -- not a primitive operation.
24631 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24633 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24634 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24636 if From_Aspect_Specification (N) then
24638 ("aspect % can only be specified for a primitive operation "
24639 & "of a tagged type", Corresponding_Aspect (N));
24641 -- The pragma is a source construct
24645 ("pragma % can only be specified for a primitive operation "
24646 & "of a tagged type", N);
24649 -- Remaining semantic checks require a full tree traversal
24652 Check_Class_Wide_Condition (Expr);
24657 if Restore_Scope then
24661 -- If analysis of the condition indicates that a class-wide clone
24662 -- has been created, build and analyze its declaration.
24664 if Is_Subprogram (Spec_Id)
24665 and then Present (Class_Wide_Clone (Spec_Id))
24667 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
24670 -- Currently it is not possible to inline pre/postconditions on a
24671 -- subprogram subject to pragma Inline_Always.
24673 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24674 Set_Is_Analyzed_Pragma (N);
24676 Restore_Ghost_Mode (Saved_GM);
24677 end Analyze_Pre_Post_Condition_In_Decl_Part;
24679 ------------------------------------------
24680 -- Analyze_Refined_Depends_In_Decl_Part --
24681 ------------------------------------------
24683 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24684 procedure Check_Dependency_Clause
24685 (Spec_Id : Entity_Id;
24686 Dep_Clause : Node_Id;
24687 Dep_States : Elist_Id;
24688 Refinements : List_Id;
24689 Matched_Items : in out Elist_Id);
24690 -- Try to match a single dependency clause Dep_Clause against one or
24691 -- more refinement clauses found in list Refinements. Each successful
24692 -- match eliminates at least one refinement clause from Refinements.
24693 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24694 -- denotes the entities of all abstract states which appear in pragma
24695 -- Depends. Matched_Items contains the entities of all successfully
24696 -- matched items found in pragma Depends.
24698 procedure Check_Output_States
24699 (Spec_Id : Entity_Id;
24700 Spec_Inputs : Elist_Id;
24701 Spec_Outputs : Elist_Id;
24702 Body_Inputs : Elist_Id;
24703 Body_Outputs : Elist_Id);
24704 -- Determine whether pragma Depends contains an output state with a
24705 -- visible refinement and if so, ensure that pragma Refined_Depends
24706 -- mentions all its constituents as outputs. Spec_Id is the entity of
24707 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24708 -- inputs and outputs of the subprogram spec synthesized from pragma
24709 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24710 -- of the subprogram body synthesized from pragma Refined_Depends.
24712 function Collect_States (Clauses : List_Id) return Elist_Id;
24713 -- Given a normalized list of dependencies obtained from calling
24714 -- Normalize_Clauses, return a list containing the entities of all
24715 -- states appearing in dependencies. It helps in checking refinements
24716 -- involving a state and a corresponding constituent which is not a
24717 -- direct constituent of the state.
24719 procedure Normalize_Clauses (Clauses : List_Id);
24720 -- Given a list of dependence or refinement clauses Clauses, normalize
24721 -- each clause by creating multiple dependencies with exactly one input
24724 procedure Remove_Extra_Clauses
24725 (Clauses : List_Id;
24726 Matched_Items : Elist_Id);
24727 -- Given a list of refinement clauses Clauses, remove all clauses whose
24728 -- inputs and/or outputs have been previously matched. See the body for
24729 -- all special cases. Matched_Items contains the entities of all matched
24730 -- items found in pragma Depends.
24732 procedure Report_Extra_Clauses
24733 (Spec_Id : Entity_Id;
24734 Clauses : List_Id);
24735 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24736 -- denotes the entity of the related subprogram.
24738 -----------------------------
24739 -- Check_Dependency_Clause --
24740 -----------------------------
24742 procedure Check_Dependency_Clause
24743 (Spec_Id : Entity_Id;
24744 Dep_Clause : Node_Id;
24745 Dep_States : Elist_Id;
24746 Refinements : List_Id;
24747 Matched_Items : in out Elist_Id)
24749 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24750 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24752 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24753 -- Determine whether dependency item Dep_Item has been matched in a
24754 -- previous clause.
24756 function Is_In_Out_State_Clause return Boolean;
24757 -- Determine whether dependence clause Dep_Clause denotes an abstract
24758 -- state that depends on itself (State => State).
24760 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24761 -- Determine whether item Item denotes an abstract state with visible
24762 -- null refinement.
24764 procedure Match_Items
24765 (Dep_Item : Node_Id;
24766 Ref_Item : Node_Id;
24767 Matched : out Boolean);
24768 -- Try to match dependence item Dep_Item against refinement item
24769 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24770 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24771 -- the following conformance scenarios is in effect:
24772 -- 1) Both items denote null
24773 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24774 -- 3) Both items denote attribute 'Result
24775 -- 4) Both items denote the same object
24776 -- 5) Both items denote the same formal parameter
24777 -- 6) Both items denote the same current instance of a type
24778 -- 7) Both items denote the same discriminant
24779 -- 8) Dep_Item is an abstract state with visible null refinement
24780 -- and Ref_Item denotes null.
24781 -- 9) Dep_Item is an abstract state with visible null refinement
24782 -- and Ref_Item is Empty (special case).
24783 -- 10) Dep_Item is an abstract state with full or partial visible
24784 -- non-null refinement and Ref_Item denotes one of its
24786 -- 11) Dep_Item is an abstract state without a full visible
24787 -- refinement and Ref_Item denotes the same state.
24788 -- When scenario 10 is in effect, the entity of the abstract state
24789 -- denoted by Dep_Item is added to list Refined_States.
24791 procedure Record_Item
(Item_Id
: Entity_Id
);
24792 -- Store the entity of an item denoted by Item_Id in Matched_Items
24794 ------------------------
24795 -- Is_Already_Matched --
24796 ------------------------
24798 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
24799 Item_Id
: Entity_Id
:= Empty
;
24802 -- When the dependency item denotes attribute 'Result, check for
24803 -- the entity of the related subprogram.
24805 if Is_Attribute_Result
(Dep_Item
) then
24806 Item_Id
:= Spec_Id
;
24808 elsif Is_Entity_Name
(Dep_Item
) then
24809 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24813 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
24814 end Is_Already_Matched
;
24816 ----------------------------
24817 -- Is_In_Out_State_Clause --
24818 ----------------------------
24820 function Is_In_Out_State_Clause
return Boolean is
24821 Dep_Input_Id
: Entity_Id
;
24822 Dep_Output_Id
: Entity_Id
;
24825 -- Detect the following clause:
24828 if Is_Entity_Name
(Dep_Input
)
24829 and then Is_Entity_Name
(Dep_Output
)
24831 -- Handle abstract views generated for limited with clauses
24833 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
24834 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
24837 Ekind
(Dep_Input_Id
) = E_Abstract_State
24838 and then Dep_Input_Id
= Dep_Output_Id
;
24842 end Is_In_Out_State_Clause
;
24844 ---------------------------
24845 -- Is_Null_Refined_State --
24846 ---------------------------
24848 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
24849 Item_Id
: Entity_Id
;
24852 if Is_Entity_Name
(Item
) then
24854 -- Handle abstract views generated for limited with clauses
24856 Item_Id
:= Available_View
(Entity_Of
(Item
));
24859 Ekind
(Item_Id
) = E_Abstract_State
24860 and then Has_Null_Visible_Refinement
(Item_Id
);
24864 end Is_Null_Refined_State
;
24870 procedure Match_Items
24871 (Dep_Item
: Node_Id
;
24872 Ref_Item
: Node_Id
;
24873 Matched
: out Boolean)
24875 Dep_Item_Id
: Entity_Id
;
24876 Ref_Item_Id
: Entity_Id
;
24879 -- Assume that the two items do not match
24883 -- A null matches null or Empty (special case)
24885 if Nkind
(Dep_Item
) = N_Null
24886 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24890 -- Attribute 'Result matches attribute 'Result
24892 elsif Is_Attribute_Result
(Dep_Item
)
24893 and then Is_Attribute_Result
(Ref_Item
)
24895 -- Put the entity of the related function on the list of
24896 -- matched items because attribute 'Result does not carry
24897 -- an entity similar to states and constituents.
24899 Record_Item
(Spec_Id
);
24902 -- Abstract states, current instances of concurrent types,
24903 -- discriminants, formal parameters and objects.
24905 elsif Is_Entity_Name
(Dep_Item
) then
24907 -- Handle abstract views generated for limited with clauses
24909 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24911 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
24913 -- An abstract state with visible null refinement matches
24914 -- null or Empty (special case).
24916 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
24917 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24919 Record_Item
(Dep_Item_Id
);
24922 -- An abstract state with visible non-null refinement
24923 -- matches one of its constituents, or itself for an
24924 -- abstract state with partial visible refinement.
24926 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
24927 if Is_Entity_Name
(Ref_Item
) then
24928 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
24930 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
24933 and then Present
(Encapsulating_State
(Ref_Item_Id
))
24934 and then Find_Encapsulating_State
24935 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
24937 Record_Item
(Dep_Item_Id
);
24940 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
24941 and then Ref_Item_Id
= Dep_Item_Id
24943 Record_Item
(Dep_Item_Id
);
24948 -- An abstract state without a visible refinement matches
24951 elsif Is_Entity_Name
(Ref_Item
)
24952 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24954 Record_Item
(Dep_Item_Id
);
24958 -- A current instance of a concurrent type, discriminant,
24959 -- formal parameter or an object matches itself.
24961 elsif Is_Entity_Name
(Ref_Item
)
24962 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24964 Record_Item
(Dep_Item_Id
);
24974 procedure Record_Item
(Item_Id
: Entity_Id
) is
24976 if No
(Matched_Items
) then
24977 Matched_Items
:= New_Elmt_List
;
24980 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
24985 Clause_Matched
: Boolean := False;
24986 Dummy
: Boolean := False;
24987 Inputs_Match
: Boolean;
24988 Next_Ref_Clause
: Node_Id
;
24989 Outputs_Match
: Boolean;
24990 Ref_Clause
: Node_Id
;
24991 Ref_Input
: Node_Id
;
24992 Ref_Output
: Node_Id
;
24994 -- Start of processing for Check_Dependency_Clause
24997 -- Do not perform this check in an instance because it was already
24998 -- performed successfully in the generic template.
25000 if Is_Generic_Instance
(Spec_Id
) then
25004 -- Examine all refinement clauses and compare them against the
25005 -- dependence clause.
25007 Ref_Clause
:= First
(Refinements
);
25008 while Present
(Ref_Clause
) loop
25009 Next_Ref_Clause
:= Next
(Ref_Clause
);
25011 -- Obtain the attributes of the current refinement clause
25013 Ref_Input
:= Expression
(Ref_Clause
);
25014 Ref_Output
:= First
(Choices
(Ref_Clause
));
25016 -- The current refinement clause matches the dependence clause
25017 -- when both outputs match and both inputs match. See routine
25018 -- Match_Items for all possible conformance scenarios.
25020 -- Depends Dep_Output => Dep_Input
25024 -- Refined_Depends Ref_Output => Ref_Input
25027 (Dep_Item
=> Dep_Input
,
25028 Ref_Item
=> Ref_Input
,
25029 Matched
=> Inputs_Match
);
25032 (Dep_Item
=> Dep_Output
,
25033 Ref_Item
=> Ref_Output
,
25034 Matched
=> Outputs_Match
);
25036 -- An In_Out state clause may be matched against a refinement with
25037 -- a null input or null output as long as the non-null side of the
25038 -- relation contains a valid constituent of the In_Out_State.
25040 if Is_In_Out_State_Clause
then
25042 -- Depends => (State => State)
25043 -- Refined_Depends => (null => Constit) -- OK
25046 and then not Outputs_Match
25047 and then Nkind
(Ref_Output
) = N_Null
25049 Outputs_Match
:= True;
25052 -- Depends => (State => State)
25053 -- Refined_Depends => (Constit => null) -- OK
25055 if not Inputs_Match
25056 and then Outputs_Match
25057 and then Nkind
(Ref_Input
) = N_Null
25059 Inputs_Match
:= True;
25063 -- The current refinement clause is legally constructed following
25064 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
25065 -- the pool of candidates. The seach continues because a single
25066 -- dependence clause may have multiple matching refinements.
25068 if Inputs_Match
and Outputs_Match
then
25069 Clause_Matched
:= True;
25070 Remove
(Ref_Clause
);
25073 Ref_Clause
:= Next_Ref_Clause
;
25076 -- Depending on the order or composition of refinement clauses, an
25077 -- In_Out state clause may not be directly refinable.
25079 -- Refined_State => (State => (Constit_1, Constit_2))
25080 -- Depends => ((Output, State) => (Input, State))
25081 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
25083 -- Matching normalized clause (State => State) fails because there is
25084 -- no direct refinement capable of satisfying this relation. Another
25085 -- similar case arises when clauses (Constit_1 => Input) and (Output
25086 -- => Constit_2) are matched first, leaving no candidates for clause
25087 -- (State => State). Both scenarios are legal as long as one of the
25088 -- previous clauses mentioned a valid constituent of State.
25090 if not Clause_Matched
25091 and then Is_In_Out_State_Clause
25092 and then Is_Already_Matched
(Dep_Input
)
25094 Clause_Matched
:= True;
25097 -- A clause where the input is an abstract state with visible null
25098 -- refinement or a 'Result attribute is implicitly matched when the
25099 -- output has already been matched in a previous clause.
25101 -- Refined_State => (State => null)
25102 -- Depends => (Output => State) -- implicitly OK
25103 -- Refined_Depends => (Output => ...)
25104 -- Depends => (...'Result => State) -- implicitly OK
25105 -- Refined_Depends => (...'Result => ...)
25107 if not Clause_Matched
25108 and then Is_Null_Refined_State
(Dep_Input
)
25109 and then Is_Already_Matched
(Dep_Output
)
25111 Clause_Matched
:= True;
25114 -- A clause where the output is an abstract state with visible null
25115 -- refinement is implicitly matched when the input has already been
25116 -- matched in a previous clause.
25118 -- Refined_State => (State => null)
25119 -- Depends => (State => Input) -- implicitly OK
25120 -- Refined_Depends => (... => Input)
25122 if not Clause_Matched
25123 and then Is_Null_Refined_State
(Dep_Output
)
25124 and then Is_Already_Matched
(Dep_Input
)
25126 Clause_Matched
:= True;
25129 -- At this point either all refinement clauses have been examined or
25130 -- pragma Refined_Depends contains a solitary null. Only an abstract
25131 -- state with null refinement can possibly match these cases.
25133 -- Refined_State => (State => null)
25134 -- Depends => (State => null)
25135 -- Refined_Depends => null -- OK
25137 if not Clause_Matched
then
25139 (Dep_Item
=> Dep_Input
,
25141 Matched
=> Inputs_Match
);
25144 (Dep_Item
=> Dep_Output
,
25146 Matched
=> Outputs_Match
);
25148 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
25151 -- If the contents of Refined_Depends are legal, then the current
25152 -- dependence clause should be satisfied either by an explicit match
25153 -- or by one of the special cases.
25155 if not Clause_Matched
then
25157 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
25158 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
25160 end Check_Dependency_Clause
;
25162 -------------------------
25163 -- Check_Output_States --
25164 -------------------------
25166 procedure Check_Output_States
25167 (Spec_Id
: Entity_Id
;
25168 Spec_Inputs
: Elist_Id
;
25169 Spec_Outputs
: Elist_Id
;
25170 Body_Inputs
: Elist_Id
;
25171 Body_Outputs
: Elist_Id
)
25173 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25174 -- Determine whether all constituents of state State_Id with full
25175 -- visible refinement are used as outputs in pragma Refined_Depends.
25176 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
25178 -----------------------------
25179 -- Check_Constituent_Usage --
25180 -----------------------------
25182 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25183 Constits
: constant Elist_Id
:=
25184 Partial_Refinement_Constituents
(State_Id
);
25185 Constit_Elmt
: Elmt_Id
;
25186 Constit_Id
: Entity_Id
;
25187 Only_Partial
: constant Boolean :=
25188 not Has_Visible_Refinement
(State_Id
);
25189 Posted
: Boolean := False;
25192 if Present
(Constits
) then
25193 Constit_Elmt
:= First_Elmt
(Constits
);
25194 while Present
(Constit_Elmt
) loop
25195 Constit_Id
:= Node
(Constit_Elmt
);
25197 -- Issue an error when a constituent of State_Id is used,
25198 -- and State_Id has only partial visible refinement
25199 -- (SPARK RM 7.2.4(3d)).
25201 if Only_Partial
then
25202 if (Present
(Body_Inputs
)
25203 and then Appears_In
(Body_Inputs
, Constit_Id
))
25205 (Present
(Body_Outputs
)
25206 and then Appears_In
(Body_Outputs
, Constit_Id
))
25208 Error_Msg_Name_1
:= Chars
(State_Id
);
25210 ("constituent & of state % cannot be used in "
25211 & "dependence refinement", N
, Constit_Id
);
25212 Error_Msg_Name_1
:= Chars
(State_Id
);
25213 SPARK_Msg_N
("\use state % instead", N
);
25216 -- The constituent acts as an input (SPARK RM 7.2.5(3))
25218 elsif Present
(Body_Inputs
)
25219 and then Appears_In
(Body_Inputs
, Constit_Id
)
25221 Error_Msg_Name_1
:= Chars
(State_Id
);
25223 ("constituent & of state % must act as output in "
25224 & "dependence refinement", N
, Constit_Id
);
25226 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25228 elsif No
(Body_Outputs
)
25229 or else not Appears_In
(Body_Outputs
, Constit_Id
)
25234 ("output state & must be replaced by all its "
25235 & "constituents in dependence refinement",
25240 ("\constituent & is missing in output list",
25244 Next_Elmt
(Constit_Elmt
);
25247 end Check_Constituent_Usage
;
25252 Item_Elmt
: Elmt_Id
;
25253 Item_Id
: Entity_Id
;
25255 -- Start of processing for Check_Output_States
25258 -- Do not perform this check in an instance because it was already
25259 -- performed successfully in the generic template.
25261 if Is_Generic_Instance
(Spec_Id
) then
25264 -- Inspect the outputs of pragma Depends looking for a state with a
25265 -- visible refinement.
25267 elsif Present
(Spec_Outputs
) then
25268 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
25269 while Present
(Item_Elmt
) loop
25270 Item
:= Node
(Item_Elmt
);
25272 -- Deal with the mixed nature of the input and output lists
25274 if Nkind
(Item
) = N_Defining_Identifier
then
25277 Item_Id
:= Available_View
(Entity_Of
(Item
));
25280 if Ekind
(Item_Id
) = E_Abstract_State
then
25282 -- The state acts as an input-output, skip it
25284 if Present
(Spec_Inputs
)
25285 and then Appears_In
(Spec_Inputs
, Item_Id
)
25289 -- Ensure that all of the constituents are utilized as
25290 -- outputs in pragma Refined_Depends.
25292 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25293 Check_Constituent_Usage
(Item_Id
);
25297 Next_Elmt
(Item_Elmt
);
25300 end Check_Output_States
;
25302 --------------------
25303 -- Collect_States --
25304 --------------------
25306 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
25307 procedure Collect_State
25309 States
: in out Elist_Id
);
25310 -- Add the entity of Item to list States when it denotes to a state
25312 -------------------
25313 -- Collect_State --
25314 -------------------
25316 procedure Collect_State
25318 States
: in out Elist_Id
)
25323 if Is_Entity_Name
(Item
) then
25324 Id
:= Entity_Of
(Item
);
25326 if Ekind
(Id
) = E_Abstract_State
then
25327 if No
(States
) then
25328 States
:= New_Elmt_List
;
25331 Append_Unique_Elmt
(Id
, States
);
25341 States
: Elist_Id
:= No_Elist
;
25343 -- Start of processing for Collect_States
25346 Clause
:= First
(Clauses
);
25347 while Present
(Clause
) loop
25348 Input
:= Expression
(Clause
);
25349 Output
:= First
(Choices
(Clause
));
25351 Collect_State
(Input
, States
);
25352 Collect_State
(Output
, States
);
25358 end Collect_States
;
25360 -----------------------
25361 -- Normalize_Clauses --
25362 -----------------------
25364 procedure Normalize_Clauses
(Clauses
: List_Id
) is
25365 procedure Normalize_Inputs
(Clause
: Node_Id
);
25366 -- Normalize clause Clause by creating multiple clauses for each
25367 -- input item of Clause. It is assumed that Clause has exactly one
25368 -- output. The transformation is as follows:
25370 -- Output => (Input_1, Input_2) -- original
25372 -- Output => Input_1 -- normalizations
25373 -- Output => Input_2
25375 procedure Normalize_Outputs
(Clause
: Node_Id
);
25376 -- Normalize clause Clause by creating multiple clause for each
25377 -- output item of Clause. The transformation is as follows:
25379 -- (Output_1, Output_2) => Input -- original
25381 -- Output_1 => Input -- normalization
25382 -- Output_2 => Input
25384 ----------------------
25385 -- Normalize_Inputs --
25386 ----------------------
25388 procedure Normalize_Inputs
(Clause
: Node_Id
) is
25389 Inputs
: constant Node_Id
:= Expression
(Clause
);
25390 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25391 Output
: constant List_Id
:= Choices
(Clause
);
25392 Last_Input
: Node_Id
;
25394 New_Clause
: Node_Id
;
25395 Next_Input
: Node_Id
;
25398 -- Normalization is performed only when the original clause has
25399 -- more than one input. Multiple inputs appear as an aggregate.
25401 if Nkind
(Inputs
) = N_Aggregate
then
25402 Last_Input
:= Last
(Expressions
(Inputs
));
25404 -- Create a new clause for each input
25406 Input
:= First
(Expressions
(Inputs
));
25407 while Present
(Input
) loop
25408 Next_Input
:= Next
(Input
);
25410 -- Unhook the current input from the original input list
25411 -- because it will be relocated to a new clause.
25415 -- Special processing for the last input. At this point the
25416 -- original aggregate has been stripped down to one element.
25417 -- Replace the aggregate by the element itself.
25419 if Input
= Last_Input
then
25420 Rewrite
(Inputs
, Input
);
25422 -- Generate a clause of the form:
25427 Make_Component_Association
(Loc
,
25428 Choices
=> New_Copy_List_Tree
(Output
),
25429 Expression
=> Input
);
25431 -- The new clause contains replicated content that has
25432 -- already been analyzed, mark the clause as analyzed.
25434 Set_Analyzed
(New_Clause
);
25435 Insert_After
(Clause
, New_Clause
);
25438 Input
:= Next_Input
;
25441 end Normalize_Inputs
;
25443 -----------------------
25444 -- Normalize_Outputs --
25445 -----------------------
25447 procedure Normalize_Outputs
(Clause
: Node_Id
) is
25448 Inputs
: constant Node_Id
:= Expression
(Clause
);
25449 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
25450 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
25451 Last_Output
: Node_Id
;
25452 New_Clause
: Node_Id
;
25453 Next_Output
: Node_Id
;
25457 -- Multiple outputs appear as an aggregate. Nothing to do when
25458 -- the clause has exactly one output.
25460 if Nkind
(Outputs
) = N_Aggregate
then
25461 Last_Output
:= Last
(Expressions
(Outputs
));
25463 -- Create a clause for each output. Note that each time a new
25464 -- clause is created, the original output list slowly shrinks
25465 -- until there is one item left.
25467 Output
:= First
(Expressions
(Outputs
));
25468 while Present
(Output
) loop
25469 Next_Output
:= Next
(Output
);
25471 -- Unhook the output from the original output list as it
25472 -- will be relocated to a new clause.
25476 -- Special processing for the last output. At this point
25477 -- the original aggregate has been stripped down to one
25478 -- element. Replace the aggregate by the element itself.
25480 if Output
= Last_Output
then
25481 Rewrite
(Outputs
, Output
);
25484 -- Generate a clause of the form:
25485 -- (Output => Inputs)
25488 Make_Component_Association
(Loc
,
25489 Choices
=> New_List
(Output
),
25490 Expression
=> New_Copy_Tree
(Inputs
));
25492 -- The new clause contains replicated content that has
25493 -- already been analyzed. There is not need to reanalyze
25496 Set_Analyzed
(New_Clause
);
25497 Insert_After
(Clause
, New_Clause
);
25500 Output
:= Next_Output
;
25503 end Normalize_Outputs
;
25509 -- Start of processing for Normalize_Clauses
25512 Clause
:= First
(Clauses
);
25513 while Present
(Clause
) loop
25514 Normalize_Outputs
(Clause
);
25518 Clause
:= First
(Clauses
);
25519 while Present
(Clause
) loop
25520 Normalize_Inputs
(Clause
);
25523 end Normalize_Clauses
;
25525 --------------------------
25526 -- Remove_Extra_Clauses --
25527 --------------------------
25529 procedure Remove_Extra_Clauses
25530 (Clauses
: List_Id
;
25531 Matched_Items
: Elist_Id
)
25535 Input_Id
: Entity_Id
;
25536 Next_Clause
: Node_Id
;
25538 State_Id
: Entity_Id
;
25541 Clause
:= First
(Clauses
);
25542 while Present
(Clause
) loop
25543 Next_Clause
:= Next
(Clause
);
25545 Input
:= Expression
(Clause
);
25546 Output
:= First
(Choices
(Clause
));
25548 -- Recognize a clause of the form
25552 -- where Input is a constituent of a state which was already
25553 -- successfully matched. This clause must be removed because it
25554 -- simply indicates that some of the constituents of the state
25557 -- Refined_State => (State => (Constit_1, Constit_2))
25558 -- Depends => (Output => State)
25559 -- Refined_Depends => ((Output => Constit_1), -- State matched
25560 -- (null => Constit_2)) -- OK
25562 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
25564 -- Handle abstract views generated for limited with clauses
25566 Input_Id
:= Available_View
(Entity_Of
(Input
));
25568 -- The input must be a constituent of a state
25570 if Ekind_In
(Input_Id
, E_Abstract_State
,
25573 and then Present
(Encapsulating_State
(Input_Id
))
25575 State_Id
:= Encapsulating_State
(Input_Id
);
25577 -- The state must have a non-null visible refinement and be
25578 -- matched in a previous clause.
25580 if Has_Non_Null_Visible_Refinement
(State_Id
)
25581 and then Contains
(Matched_Items
, State_Id
)
25587 -- Recognize a clause of the form
25591 -- where Output is an arbitrary item. This clause must be removed
25592 -- because a null input legitimately matches anything.
25594 elsif Nkind
(Input
) = N_Null
then
25598 Clause
:= Next_Clause
;
25600 end Remove_Extra_Clauses
;
25602 --------------------------
25603 -- Report_Extra_Clauses --
25604 --------------------------
25606 procedure Report_Extra_Clauses
25607 (Spec_Id
: Entity_Id
;
25613 -- Do not perform this check in an instance because it was already
25614 -- performed successfully in the generic template.
25616 if Is_Generic_Instance
(Spec_Id
) then
25619 elsif Present
(Clauses
) then
25620 Clause
:= First
(Clauses
);
25621 while Present
(Clause
) loop
25623 ("unmatched or extra clause in dependence refinement",
25629 end Report_Extra_Clauses
;
25633 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25634 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25635 Errors
: constant Nat
:= Serious_Errors_Detected
;
25642 Body_Inputs
: Elist_Id
:= No_Elist
;
25643 Body_Outputs
: Elist_Id
:= No_Elist
;
25644 -- The inputs and outputs of the subprogram body synthesized from pragma
25645 -- Refined_Depends.
25647 Dependencies
: List_Id
:= No_List
;
25649 -- The corresponding Depends pragma along with its clauses
25651 Matched_Items
: Elist_Id
:= No_Elist
;
25652 -- A list containing the entities of all successfully matched items
25653 -- found in pragma Depends.
25655 Refinements
: List_Id
:= No_List
;
25656 -- The clauses of pragma Refined_Depends
25658 Spec_Id
: Entity_Id
;
25659 -- The entity of the subprogram subject to pragma Refined_Depends
25661 Spec_Inputs
: Elist_Id
:= No_Elist
;
25662 Spec_Outputs
: Elist_Id
:= No_Elist
;
25663 -- The inputs and outputs of the subprogram spec synthesized from pragma
25666 States
: Elist_Id
:= No_Elist
;
25667 -- A list containing the entities of all states whose constituents
25668 -- appear in pragma Depends.
25670 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25673 -- Do not analyze the pragma multiple times
25675 if Is_Analyzed_Pragma
(N
) then
25679 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25681 -- Use the anonymous object as the proper spec when Refined_Depends
25682 -- applies to the body of a single task type. The object carries the
25683 -- proper Chars as well as all non-refined versions of pragmas.
25685 if Is_Single_Concurrent_Type
(Spec_Id
) then
25686 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25689 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25691 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25692 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25694 if No
(Depends
) then
25696 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25697 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
25701 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25703 -- A null dependency relation renders the refinement useless because it
25704 -- cannot possibly mention abstract states with visible refinement. Note
25705 -- that the inverse is not true as states may be refined to null
25706 -- (SPARK RM 7.2.5(2)).
25708 if Nkind
(Deps
) = N_Null
then
25710 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25711 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
25715 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25716 -- This ensures that the categorization of all refined dependency items
25717 -- is consistent with their role.
25719 Analyze_Depends_In_Decl_Part
(N
);
25721 -- Do not match dependencies against refinements if Refined_Depends is
25722 -- illegal to avoid emitting misleading error.
25724 if Serious_Errors_Detected
= Errors
then
25726 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25727 -- the inputs and outputs of the subprogram spec and body to verify
25728 -- the use of states with visible refinement and their constituents.
25730 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
25731 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
25733 Collect_Subprogram_Inputs_Outputs
25734 (Subp_Id
=> Spec_Id
,
25735 Synthesize
=> True,
25736 Subp_Inputs
=> Spec_Inputs
,
25737 Subp_Outputs
=> Spec_Outputs
,
25738 Global_Seen
=> Dummy
);
25740 Collect_Subprogram_Inputs_Outputs
25741 (Subp_Id
=> Body_Id
,
25742 Synthesize
=> True,
25743 Subp_Inputs
=> Body_Inputs
,
25744 Subp_Outputs
=> Body_Outputs
,
25745 Global_Seen
=> Dummy
);
25747 -- For an output state with a visible refinement, ensure that all
25748 -- constituents appear as outputs in the dependency refinement.
25750 Check_Output_States
25751 (Spec_Id
=> Spec_Id
,
25752 Spec_Inputs
=> Spec_Inputs
,
25753 Spec_Outputs
=> Spec_Outputs
,
25754 Body_Inputs
=> Body_Inputs
,
25755 Body_Outputs
=> Body_Outputs
);
25758 -- Matching is disabled in ASIS because clauses are not normalized as
25759 -- this is a tree altering activity similar to expansion.
25765 -- Multiple dependency clauses appear as component associations of an
25766 -- aggregate. Note that the clauses are copied because the algorithm
25767 -- modifies them and this should not be visible in Depends.
25769 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
25770 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
25771 Normalize_Clauses
(Dependencies
);
25773 -- Gather all states which appear in Depends
25775 States
:= Collect_States
(Dependencies
);
25777 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
25779 if Nkind
(Refs
) = N_Null
then
25780 Refinements
:= No_List
;
25782 -- Multiple dependency clauses appear as component associations of an
25783 -- aggregate. Note that the clauses are copied because the algorithm
25784 -- modifies them and this should not be visible in Refined_Depends.
25786 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
25787 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
25788 Normalize_Clauses
(Refinements
);
25791 -- At this point the clauses of pragmas Depends and Refined_Depends
25792 -- have been normalized into simple dependencies between one output
25793 -- and one input. Examine all clauses of pragma Depends looking for
25794 -- matching clauses in pragma Refined_Depends.
25796 Clause
:= First
(Dependencies
);
25797 while Present
(Clause
) loop
25798 Check_Dependency_Clause
25799 (Spec_Id
=> Spec_Id
,
25800 Dep_Clause
=> Clause
,
25801 Dep_States
=> States
,
25802 Refinements
=> Refinements
,
25803 Matched_Items
=> Matched_Items
);
25808 -- Pragma Refined_Depends may contain multiple clarification clauses
25809 -- which indicate that certain constituents do not influence the data
25810 -- flow in any way. Such clauses must be removed as long as the state
25811 -- has been matched, otherwise they will be incorrectly flagged as
25814 -- Refined_State => (State => (Constit_1, Constit_2))
25815 -- Depends => (Output => State)
25816 -- Refined_Depends => ((Output => Constit_1), -- State matched
25817 -- (null => Constit_2)) -- must be removed
25819 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
25821 if Serious_Errors_Detected
= Errors
then
25822 Report_Extra_Clauses
(Spec_Id
, Refinements
);
25827 Set_Is_Analyzed_Pragma
(N
);
25828 end Analyze_Refined_Depends_In_Decl_Part
;
25830 -----------------------------------------
25831 -- Analyze_Refined_Global_In_Decl_Part --
25832 -----------------------------------------
25834 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
25836 -- The corresponding Global pragma
25838 Has_In_State
: Boolean := False;
25839 Has_In_Out_State
: Boolean := False;
25840 Has_Out_State
: Boolean := False;
25841 Has_Proof_In_State
: Boolean := False;
25842 -- These flags are set when the corresponding Global pragma has a state
25843 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25846 Has_Null_State
: Boolean := False;
25847 -- This flag is set when the corresponding Global pragma has at least
25848 -- one state with a null refinement.
25850 In_Constits
: Elist_Id
:= No_Elist
;
25851 In_Out_Constits
: Elist_Id
:= No_Elist
;
25852 Out_Constits
: Elist_Id
:= No_Elist
;
25853 Proof_In_Constits
: Elist_Id
:= No_Elist
;
25854 -- These lists contain the entities of all Input, In_Out, Output and
25855 -- Proof_In constituents that appear in Refined_Global and participate
25856 -- in state refinement.
25858 In_Items
: Elist_Id
:= No_Elist
;
25859 In_Out_Items
: Elist_Id
:= No_Elist
;
25860 Out_Items
: Elist_Id
:= No_Elist
;
25861 Proof_In_Items
: Elist_Id
:= No_Elist
;
25862 -- These lists contain the entities of all Input, In_Out, Output and
25863 -- Proof_In items defined in the corresponding Global pragma.
25865 Repeat_Items
: Elist_Id
:= No_Elist
;
25866 -- A list of all global items without full visible refinement found
25867 -- in pragma Global. These states should be repeated in the global
25868 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25869 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25871 Spec_Id
: Entity_Id
;
25872 -- The entity of the subprogram subject to pragma Refined_Global
25874 States
: Elist_Id
:= No_Elist
;
25875 -- A list of all states with full or partial visible refinement found in
25878 procedure Check_In_Out_States
;
25879 -- Determine whether the corresponding Global pragma mentions In_Out
25880 -- states with visible refinement and if so, ensure that one of the
25881 -- following completions apply to the constituents of the state:
25882 -- 1) there is at least one constituent of mode In_Out
25883 -- 2) there is at least one Input and one Output constituent
25884 -- 3) not all constituents are present and one of them is of mode
25886 -- This routine may remove elements from In_Constits, In_Out_Constits,
25887 -- Out_Constits and Proof_In_Constits.
25889 procedure Check_Input_States
;
25890 -- Determine whether the corresponding Global pragma mentions Input
25891 -- states with visible refinement and if so, ensure that at least one of
25892 -- its constituents appears as an Input item in Refined_Global.
25893 -- This routine may remove elements from In_Constits, In_Out_Constits,
25894 -- Out_Constits and Proof_In_Constits.
25896 procedure Check_Output_States
;
25897 -- Determine whether the corresponding Global pragma mentions Output
25898 -- states with visible refinement and if so, ensure that all of its
25899 -- constituents appear as Output items in Refined_Global.
25900 -- This routine may remove elements from In_Constits, In_Out_Constits,
25901 -- Out_Constits and Proof_In_Constits.
25903 procedure Check_Proof_In_States
;
25904 -- Determine whether the corresponding Global pragma mentions Proof_In
25905 -- states with visible refinement and if so, ensure that at least one of
25906 -- its constituents appears as a Proof_In item in Refined_Global.
25907 -- This routine may remove elements from In_Constits, In_Out_Constits,
25908 -- Out_Constits and Proof_In_Constits.
25910 procedure Check_Refined_Global_List
25912 Global_Mode
: Name_Id
:= Name_Input
);
25913 -- Verify the legality of a single global list declaration. Global_Mode
25914 -- denotes the current mode in effect.
25916 procedure Collect_Global_Items
25918 Mode
: Name_Id
:= Name_Input
);
25919 -- Gather all Input, In_Out, Output and Proof_In items from node List
25920 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25921 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25922 -- and Has_Proof_In_State are set when there is at least one abstract
25923 -- state with full or partial visible refinement available in the
25924 -- corresponding mode. Flag Has_Null_State is set when at least state
25925 -- has a null refinement. Mode denotes the current global mode in
25928 function Present_Then_Remove
25930 Item
: Entity_Id
) return Boolean;
25931 -- Search List for a particular entity Item. If Item has been found,
25932 -- remove it from List. This routine is used to strip lists In_Constits,
25933 -- In_Out_Constits and Out_Constits of valid constituents.
25935 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
25936 -- Same as function Present_Then_Remove, but do not report the presence
25937 -- of Item in List.
25939 procedure Report_Extra_Constituents
;
25940 -- Emit an error for each constituent found in lists In_Constits,
25941 -- In_Out_Constits and Out_Constits.
25943 procedure Report_Missing_Items
;
25944 -- Emit an error for each global item not repeated found in list
25947 -------------------------
25948 -- Check_In_Out_States --
25949 -------------------------
25951 procedure Check_In_Out_States
is
25952 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25953 -- Determine whether one of the following coverage scenarios is in
25955 -- 1) there is at least one constituent of mode In_Out or Output
25956 -- 2) there is at least one pair of constituents with modes Input
25957 -- and Output, or Proof_In and Output.
25958 -- 3) there is at least one constituent of mode Output and not all
25959 -- constituents are present.
25960 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25962 -----------------------------
25963 -- Check_Constituent_Usage --
25964 -----------------------------
25966 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25967 Constits
: constant Elist_Id
:=
25968 Partial_Refinement_Constituents
(State_Id
);
25969 Constit_Elmt
: Elmt_Id
;
25970 Constit_Id
: Entity_Id
;
25971 Has_Missing
: Boolean := False;
25972 In_Out_Seen
: Boolean := False;
25973 Input_Seen
: Boolean := False;
25974 Output_Seen
: Boolean := False;
25975 Proof_In_Seen
: Boolean := False;
25978 -- Process all the constituents of the state and note their modes
25979 -- within the global refinement.
25981 if Present
(Constits
) then
25982 Constit_Elmt
:= First_Elmt
(Constits
);
25983 while Present
(Constit_Elmt
) loop
25984 Constit_Id
:= Node
(Constit_Elmt
);
25986 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25987 Input_Seen
:= True;
25989 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
25990 In_Out_Seen
:= True;
25992 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25993 Output_Seen
:= True;
25995 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25997 Proof_In_Seen
:= True;
26000 Has_Missing
:= True;
26003 Next_Elmt
(Constit_Elmt
);
26007 -- An In_Out constituent is a valid completion
26009 if In_Out_Seen
then
26012 -- A pair of one Input/Proof_In and one Output constituent is a
26013 -- valid completion.
26015 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
26018 elsif Output_Seen
then
26020 -- A single Output constituent is a valid completion only when
26021 -- some of the other constituents are missing.
26023 if Has_Missing
then
26026 -- Otherwise all constituents are of mode Output
26030 ("global refinement of state & must include at least one "
26031 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
26035 -- The state lacks a completion. When full refinement is visible,
26036 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
26037 -- refinement is visible, emit an error if the abstract state
26038 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
26039 -- both are utilized, Check_State_And_Constituent_Use. will issue
26042 elsif not Input_Seen
26043 and then not In_Out_Seen
26044 and then not Output_Seen
26045 and then not Proof_In_Seen
26047 if Has_Visible_Refinement
(State_Id
)
26048 or else Contains
(Repeat_Items
, State_Id
)
26051 ("missing global refinement of state &", N
, State_Id
);
26054 -- Otherwise the state has a malformed completion where at least
26055 -- one of the constituents has a different mode.
26059 ("global refinement of state & redefines the mode of its "
26060 & "constituents", N
, State_Id
);
26062 end Check_Constituent_Usage
;
26066 Item_Elmt
: Elmt_Id
;
26067 Item_Id
: Entity_Id
;
26069 -- Start of processing for Check_In_Out_States
26072 -- Do not perform this check in an instance because it was already
26073 -- performed successfully in the generic template.
26075 if Is_Generic_Instance
(Spec_Id
) then
26078 -- Inspect the In_Out items of the corresponding Global pragma
26079 -- looking for a state with a visible refinement.
26081 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
26082 Item_Elmt
:= First_Elmt
(In_Out_Items
);
26083 while Present
(Item_Elmt
) loop
26084 Item_Id
:= Node
(Item_Elmt
);
26086 -- Ensure that one of the three coverage variants is satisfied
26088 if Ekind
(Item_Id
) = E_Abstract_State
26089 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26091 Check_Constituent_Usage
(Item_Id
);
26094 Next_Elmt
(Item_Elmt
);
26097 end Check_In_Out_States
;
26099 ------------------------
26100 -- Check_Input_States --
26101 ------------------------
26103 procedure Check_Input_States
is
26104 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26105 -- Determine whether at least one constituent of state State_Id with
26106 -- full or partial visible refinement is used and has mode Input.
26107 -- Ensure that the remaining constituents do not have In_Out or
26108 -- Output modes. Emit an error if this is not the case
26109 -- (SPARK RM 7.2.4(5)).
26111 -----------------------------
26112 -- Check_Constituent_Usage --
26113 -----------------------------
26115 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26116 Constits
: constant Elist_Id
:=
26117 Partial_Refinement_Constituents
(State_Id
);
26118 Constit_Elmt
: Elmt_Id
;
26119 Constit_Id
: Entity_Id
;
26120 In_Seen
: Boolean := False;
26123 if Present
(Constits
) then
26124 Constit_Elmt
:= First_Elmt
(Constits
);
26125 while Present
(Constit_Elmt
) loop
26126 Constit_Id
:= Node
(Constit_Elmt
);
26128 -- At least one of the constituents appears as an Input
26130 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
26133 -- A Proof_In constituent can refine an Input state as long
26134 -- as there is at least one Input constituent present.
26136 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26140 -- The constituent appears in the global refinement, but has
26141 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
26143 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26144 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26146 Error_Msg_Name_1
:= Chars
(State_Id
);
26148 ("constituent & of state % must have mode `Input` in "
26149 & "global refinement", N
, Constit_Id
);
26152 Next_Elmt
(Constit_Elmt
);
26156 -- Not one of the constituents appeared as Input. Always emit an
26157 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
26158 -- When only partial refinement is visible, emit an error if the
26159 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26160 -- the case where both are utilized, an error will be issued in
26161 -- Check_State_And_Constituent_Use.
26164 and then (Has_Visible_Refinement
(State_Id
)
26165 or else Contains
(Repeat_Items
, State_Id
))
26168 ("global refinement of state & must include at least one "
26169 & "constituent of mode `Input`", N
, State_Id
);
26171 end Check_Constituent_Usage
;
26175 Item_Elmt
: Elmt_Id
;
26176 Item_Id
: Entity_Id
;
26178 -- Start of processing for Check_Input_States
26181 -- Do not perform this check in an instance because it was already
26182 -- performed successfully in the generic template.
26184 if Is_Generic_Instance
(Spec_Id
) then
26187 -- Inspect the Input items of the corresponding Global pragma looking
26188 -- for a state with a visible refinement.
26190 elsif Has_In_State
and then Present
(In_Items
) then
26191 Item_Elmt
:= First_Elmt
(In_Items
);
26192 while Present
(Item_Elmt
) loop
26193 Item_Id
:= Node
(Item_Elmt
);
26195 -- When full refinement is visible, ensure that at least one of
26196 -- the constituents is utilized and is of mode Input. When only
26197 -- partial refinement is visible, ensure that either one of
26198 -- the constituents is utilized and is of mode Input, or the
26199 -- abstract state is repeated and no constituent is utilized.
26201 if Ekind
(Item_Id
) = E_Abstract_State
26202 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26204 Check_Constituent_Usage
(Item_Id
);
26207 Next_Elmt
(Item_Elmt
);
26210 end Check_Input_States
;
26212 -------------------------
26213 -- Check_Output_States --
26214 -------------------------
26216 procedure Check_Output_States
is
26217 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26218 -- Determine whether all constituents of state State_Id with full
26219 -- visible refinement are used and have mode Output. Emit an error
26220 -- if this is not the case (SPARK RM 7.2.4(5)).
26222 -----------------------------
26223 -- Check_Constituent_Usage --
26224 -----------------------------
26226 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26227 Constits
: constant Elist_Id
:=
26228 Partial_Refinement_Constituents
(State_Id
);
26229 Only_Partial
: constant Boolean :=
26230 not Has_Visible_Refinement
(State_Id
);
26231 Constit_Elmt
: Elmt_Id
;
26232 Constit_Id
: Entity_Id
;
26233 Posted
: Boolean := False;
26236 if Present
(Constits
) then
26237 Constit_Elmt
:= First_Elmt
(Constits
);
26238 while Present
(Constit_Elmt
) loop
26239 Constit_Id
:= Node
(Constit_Elmt
);
26241 -- Issue an error when a constituent of State_Id is utilized
26242 -- and State_Id has only partial visible refinement
26243 -- (SPARK RM 7.2.4(3d)).
26245 if Only_Partial
then
26246 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
26247 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
26249 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26251 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26253 Error_Msg_Name_1
:= Chars
(State_Id
);
26255 ("constituent & of state % cannot be used in global "
26256 & "refinement", N
, Constit_Id
);
26257 Error_Msg_Name_1
:= Chars
(State_Id
);
26258 SPARK_Msg_N
("\use state % instead", N
);
26261 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
26264 -- The constituent appears in the global refinement, but has
26265 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
26267 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26268 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26269 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
26271 Error_Msg_Name_1
:= Chars
(State_Id
);
26273 ("constituent & of state % must have mode `Output` in "
26274 & "global refinement", N
, Constit_Id
);
26276 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
26282 ("`Output` state & must be replaced by all its "
26283 & "constituents in global refinement", N
, State_Id
);
26287 ("\constituent & is missing in output list",
26291 Next_Elmt
(Constit_Elmt
);
26294 end Check_Constituent_Usage
;
26298 Item_Elmt
: Elmt_Id
;
26299 Item_Id
: Entity_Id
;
26301 -- Start of processing for Check_Output_States
26304 -- Do not perform this check in an instance because it was already
26305 -- performed successfully in the generic template.
26307 if Is_Generic_Instance
(Spec_Id
) then
26310 -- Inspect the Output items of the corresponding Global pragma
26311 -- looking for a state with a visible refinement.
26313 elsif Has_Out_State
and then Present
(Out_Items
) then
26314 Item_Elmt
:= First_Elmt
(Out_Items
);
26315 while Present
(Item_Elmt
) loop
26316 Item_Id
:= Node
(Item_Elmt
);
26318 -- When full refinement is visible, ensure that all of the
26319 -- constituents are utilized and they have mode Output. When
26320 -- only partial refinement is visible, ensure that no
26321 -- constituent is utilized.
26323 if Ekind
(Item_Id
) = E_Abstract_State
26324 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26326 Check_Constituent_Usage
(Item_Id
);
26329 Next_Elmt
(Item_Elmt
);
26332 end Check_Output_States
;
26334 ---------------------------
26335 -- Check_Proof_In_States --
26336 ---------------------------
26338 procedure Check_Proof_In_States
is
26339 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
26340 -- Determine whether at least one constituent of state State_Id with
26341 -- full or partial visible refinement is used and has mode Proof_In.
26342 -- Ensure that the remaining constituents do not have Input, In_Out,
26343 -- or Output modes. Emit an error if this is not the case
26344 -- (SPARK RM 7.2.4(5)).
26346 -----------------------------
26347 -- Check_Constituent_Usage --
26348 -----------------------------
26350 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
26351 Constits
: constant Elist_Id
:=
26352 Partial_Refinement_Constituents
(State_Id
);
26353 Constit_Elmt
: Elmt_Id
;
26354 Constit_Id
: Entity_Id
;
26355 Proof_In_Seen
: Boolean := False;
26358 if Present
(Constits
) then
26359 Constit_Elmt
:= First_Elmt
(Constits
);
26360 while Present
(Constit_Elmt
) loop
26361 Constit_Id
:= Node
(Constit_Elmt
);
26363 -- At least one of the constituents appears as Proof_In
26365 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
26366 Proof_In_Seen
:= True;
26368 -- The constituent appears in the global refinement, but has
26369 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
26371 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
26372 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
26373 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
26375 Error_Msg_Name_1
:= Chars
(State_Id
);
26377 ("constituent & of state % must have mode `Proof_In` "
26378 & "in global refinement", N
, Constit_Id
);
26381 Next_Elmt
(Constit_Elmt
);
26385 -- Not one of the constituents appeared as Proof_In. Always emit
26386 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
26387 -- When only partial refinement is visible, emit an error if the
26388 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
26389 -- the case where both are utilized, an error will be issued by
26390 -- Check_State_And_Constituent_Use.
26392 if not Proof_In_Seen
26393 and then (Has_Visible_Refinement
(State_Id
)
26394 or else Contains
(Repeat_Items
, State_Id
))
26397 ("global refinement of state & must include at least one "
26398 & "constituent of mode `Proof_In`", N
, State_Id
);
26400 end Check_Constituent_Usage
;
26404 Item_Elmt
: Elmt_Id
;
26405 Item_Id
: Entity_Id
;
26407 -- Start of processing for Check_Proof_In_States
26410 -- Do not perform this check in an instance because it was already
26411 -- performed successfully in the generic template.
26413 if Is_Generic_Instance
(Spec_Id
) then
26416 -- Inspect the Proof_In items of the corresponding Global pragma
26417 -- looking for a state with a visible refinement.
26419 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
26420 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
26421 while Present
(Item_Elmt
) loop
26422 Item_Id
:= Node
(Item_Elmt
);
26424 -- Ensure that at least one of the constituents is utilized
26425 -- and is of mode Proof_In. When only partial refinement is
26426 -- visible, ensure that either one of the constituents is
26427 -- utilized and is of mode Proof_In, or the abstract state
26428 -- is repeated and no constituent is utilized.
26430 if Ekind
(Item_Id
) = E_Abstract_State
26431 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
26433 Check_Constituent_Usage
(Item_Id
);
26436 Next_Elmt
(Item_Elmt
);
26439 end Check_Proof_In_States
;
26441 -------------------------------
26442 -- Check_Refined_Global_List --
26443 -------------------------------
26445 procedure Check_Refined_Global_List
26447 Global_Mode
: Name_Id
:= Name_Input
)
26449 procedure Check_Refined_Global_Item
26451 Global_Mode
: Name_Id
);
26452 -- Verify the legality of a single global item declaration. Parameter
26453 -- Global_Mode denotes the current mode in effect.
26455 -------------------------------
26456 -- Check_Refined_Global_Item --
26457 -------------------------------
26459 procedure Check_Refined_Global_Item
26461 Global_Mode
: Name_Id
)
26463 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
26465 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
26466 -- Issue a common error message for all mode mismatches. Expect
26467 -- denotes the expected mode.
26469 -----------------------------
26470 -- Inconsistent_Mode_Error --
26471 -----------------------------
26473 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
26476 ("global item & has inconsistent modes", Item
, Item_Id
);
26478 Error_Msg_Name_1
:= Global_Mode
;
26479 Error_Msg_Name_2
:= Expect
;
26480 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
26481 end Inconsistent_Mode_Error
;
26485 Enc_State
: Entity_Id
:= Empty
;
26486 -- Encapsulating state for constituent, Empty otherwise
26488 -- Start of processing for Check_Refined_Global_Item
26491 if Ekind_In
(Item_Id
, E_Abstract_State
,
26495 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
26498 -- When the state or object acts as a constituent of another
26499 -- state with a visible refinement, collect it for the state
26500 -- completeness checks performed later on. Note that the item
26501 -- acts as a constituent only when the encapsulating state is
26502 -- present in pragma Global.
26504 if Present
(Enc_State
)
26505 and then (Has_Visible_Refinement
(Enc_State
)
26506 or else Has_Partial_Visible_Refinement
(Enc_State
))
26507 and then Contains
(States
, Enc_State
)
26509 -- If the state has only partial visible refinement, remove it
26510 -- from the list of items that should be repeated from pragma
26513 if not Has_Visible_Refinement
(Enc_State
) then
26514 Present_Then_Remove
(Repeat_Items
, Enc_State
);
26517 if Global_Mode
= Name_Input
then
26518 Append_New_Elmt
(Item_Id
, In_Constits
);
26520 elsif Global_Mode
= Name_In_Out
then
26521 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
26523 elsif Global_Mode
= Name_Output
then
26524 Append_New_Elmt
(Item_Id
, Out_Constits
);
26526 elsif Global_Mode
= Name_Proof_In
then
26527 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
26530 -- When not a constituent, ensure that both occurrences of the
26531 -- item in pragmas Global and Refined_Global match. Also remove
26532 -- it when present from the list of items that should be repeated
26533 -- from pragma Global.
26536 Present_Then_Remove
(Repeat_Items
, Item_Id
);
26538 if Contains
(In_Items
, Item_Id
) then
26539 if Global_Mode
/= Name_Input
then
26540 Inconsistent_Mode_Error
(Name_Input
);
26543 elsif Contains
(In_Out_Items
, Item_Id
) then
26544 if Global_Mode
/= Name_In_Out
then
26545 Inconsistent_Mode_Error
(Name_In_Out
);
26548 elsif Contains
(Out_Items
, Item_Id
) then
26549 if Global_Mode
/= Name_Output
then
26550 Inconsistent_Mode_Error
(Name_Output
);
26553 elsif Contains
(Proof_In_Items
, Item_Id
) then
26556 -- The item does not appear in the corresponding Global pragma,
26557 -- it must be an extra (SPARK RM 7.2.4(3)).
26560 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
26563 end Check_Refined_Global_Item
;
26569 -- Start of processing for Check_Refined_Global_List
26572 -- Do not perform this check in an instance because it was already
26573 -- performed successfully in the generic template.
26575 if Is_Generic_Instance
(Spec_Id
) then
26578 elsif Nkind
(List
) = N_Null
then
26581 -- Single global item declaration
26583 elsif Nkind_In
(List
, N_Expanded_Name
,
26585 N_Selected_Component
)
26587 Check_Refined_Global_Item
(List
, Global_Mode
);
26589 -- Simple global list or moded global list declaration
26591 elsif Nkind
(List
) = N_Aggregate
then
26593 -- The declaration of a simple global list appear as a collection
26596 if Present
(Expressions
(List
)) then
26597 Item
:= First
(Expressions
(List
));
26598 while Present
(Item
) loop
26599 Check_Refined_Global_Item
(Item
, Global_Mode
);
26603 -- The declaration of a moded global list appears as a collection
26604 -- of component associations where individual choices denote
26607 elsif Present
(Component_Associations
(List
)) then
26608 Item
:= First
(Component_Associations
(List
));
26609 while Present
(Item
) loop
26610 Check_Refined_Global_List
26611 (List
=> Expression
(Item
),
26612 Global_Mode
=> Chars
(First
(Choices
(Item
))));
26620 raise Program_Error
;
26626 raise Program_Error
;
26628 end Check_Refined_Global_List
;
26630 --------------------------
26631 -- Collect_Global_Items --
26632 --------------------------
26634 procedure Collect_Global_Items
26636 Mode
: Name_Id
:= Name_Input
)
26638 procedure Collect_Global_Item
26640 Item_Mode
: Name_Id
);
26641 -- Add a single item to the appropriate list. Item_Mode denotes the
26642 -- current mode in effect.
26644 -------------------------
26645 -- Collect_Global_Item --
26646 -------------------------
26648 procedure Collect_Global_Item
26650 Item_Mode
: Name_Id
)
26652 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
26653 -- The above handles abstract views of variables and states built
26654 -- for limited with clauses.
26657 -- Signal that the global list contains at least one abstract
26658 -- state with a visible refinement. Note that the refinement may
26659 -- be null in which case there are no constituents.
26661 if Ekind
(Item_Id
) = E_Abstract_State
then
26662 if Has_Null_Visible_Refinement
(Item_Id
) then
26663 Has_Null_State
:= True;
26665 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26666 Append_New_Elmt
(Item_Id
, States
);
26668 if Item_Mode
= Name_Input
then
26669 Has_In_State
:= True;
26670 elsif Item_Mode
= Name_In_Out
then
26671 Has_In_Out_State
:= True;
26672 elsif Item_Mode
= Name_Output
then
26673 Has_Out_State
:= True;
26674 elsif Item_Mode
= Name_Proof_In
then
26675 Has_Proof_In_State
:= True;
26680 -- Record global items without full visible refinement found in
26681 -- pragma Global which should be repeated in the global refinement
26682 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26684 if Ekind
(Item_Id
) /= E_Abstract_State
26685 or else not Has_Visible_Refinement
(Item_Id
)
26687 Append_New_Elmt
(Item_Id
, Repeat_Items
);
26690 -- Add the item to the proper list
26692 if Item_Mode
= Name_Input
then
26693 Append_New_Elmt
(Item_Id
, In_Items
);
26694 elsif Item_Mode
= Name_In_Out
then
26695 Append_New_Elmt
(Item_Id
, In_Out_Items
);
26696 elsif Item_Mode
= Name_Output
then
26697 Append_New_Elmt
(Item_Id
, Out_Items
);
26698 elsif Item_Mode
= Name_Proof_In
then
26699 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
26701 end Collect_Global_Item
;
26707 -- Start of processing for Collect_Global_Items
26710 if Nkind
(List
) = N_Null
then
26713 -- Single global item declaration
26715 elsif Nkind_In
(List
, N_Expanded_Name
,
26717 N_Selected_Component
)
26719 Collect_Global_Item
(List
, Mode
);
26721 -- Single global list or moded global list declaration
26723 elsif Nkind
(List
) = N_Aggregate
then
26725 -- The declaration of a simple global list appear as a collection
26728 if Present
(Expressions
(List
)) then
26729 Item
:= First
(Expressions
(List
));
26730 while Present
(Item
) loop
26731 Collect_Global_Item
(Item
, Mode
);
26735 -- The declaration of a moded global list appears as a collection
26736 -- of component associations where individual choices denote mode.
26738 elsif Present
(Component_Associations
(List
)) then
26739 Item
:= First
(Component_Associations
(List
));
26740 while Present
(Item
) loop
26741 Collect_Global_Items
26742 (List
=> Expression
(Item
),
26743 Mode
=> Chars
(First
(Choices
(Item
))));
26751 raise Program_Error
;
26754 -- To accommodate partial decoration of disabled SPARK features, this
26755 -- routine may be called with illegal input. If this is the case, do
26756 -- not raise Program_Error.
26761 end Collect_Global_Items
;
26763 -------------------------
26764 -- Present_Then_Remove --
26765 -------------------------
26767 function Present_Then_Remove
26769 Item
: Entity_Id
) return Boolean
26774 if Present
(List
) then
26775 Elmt
:= First_Elmt
(List
);
26776 while Present
(Elmt
) loop
26777 if Node
(Elmt
) = Item
then
26778 Remove_Elmt
(List
, Elmt
);
26787 end Present_Then_Remove
;
26789 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
26792 Ignore
:= Present_Then_Remove
(List
, Item
);
26793 end Present_Then_Remove
;
26795 -------------------------------
26796 -- Report_Extra_Constituents --
26797 -------------------------------
26799 procedure Report_Extra_Constituents
is
26800 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
26801 -- Emit an error for every element of List
26803 ---------------------------------------
26804 -- Report_Extra_Constituents_In_List --
26805 ---------------------------------------
26807 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
26808 Constit_Elmt
: Elmt_Id
;
26811 if Present
(List
) then
26812 Constit_Elmt
:= First_Elmt
(List
);
26813 while Present
(Constit_Elmt
) loop
26814 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
26815 Next_Elmt
(Constit_Elmt
);
26818 end Report_Extra_Constituents_In_List
;
26820 -- Start of processing for Report_Extra_Constituents
26823 -- Do not perform this check in an instance because it was already
26824 -- performed successfully in the generic template.
26826 if Is_Generic_Instance
(Spec_Id
) then
26830 Report_Extra_Constituents_In_List
(In_Constits
);
26831 Report_Extra_Constituents_In_List
(In_Out_Constits
);
26832 Report_Extra_Constituents_In_List
(Out_Constits
);
26833 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
26835 end Report_Extra_Constituents
;
26837 --------------------------
26838 -- Report_Missing_Items --
26839 --------------------------
26841 procedure Report_Missing_Items
is
26842 Item_Elmt
: Elmt_Id
;
26843 Item_Id
: Entity_Id
;
26846 -- Do not perform this check in an instance because it was already
26847 -- performed successfully in the generic template.
26849 if Is_Generic_Instance
(Spec_Id
) then
26853 if Present
(Repeat_Items
) then
26854 Item_Elmt
:= First_Elmt
(Repeat_Items
);
26855 while Present
(Item_Elmt
) loop
26856 Item_Id
:= Node
(Item_Elmt
);
26857 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
26858 Next_Elmt
(Item_Elmt
);
26862 end Report_Missing_Items
;
26866 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26867 Errors
: constant Nat
:= Serious_Errors_Detected
;
26869 No_Constit
: Boolean;
26871 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26874 -- Do not analyze the pragma multiple times
26876 if Is_Analyzed_Pragma
(N
) then
26880 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26882 -- Use the anonymous object as the proper spec when Refined_Global
26883 -- applies to the body of a single task type. The object carries the
26884 -- proper Chars as well as all non-refined versions of pragmas.
26886 if Is_Single_Concurrent_Type
(Spec_Id
) then
26887 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26890 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
26891 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
26893 -- The subprogram declaration lacks pragma Global. This renders
26894 -- Refined_Global useless as there is nothing to refine.
26896 if No
(Global
) then
26898 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26899 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
26903 -- Extract all relevant items from the corresponding Global pragma
26905 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26907 -- Package and subprogram bodies are instantiated individually in
26908 -- a separate compiler pass. Due to this mode of instantiation, the
26909 -- refinement of a state may no longer be visible when a subprogram
26910 -- body contract is instantiated. Since the generic template is legal,
26911 -- do not perform this check in the instance to circumvent this oddity.
26913 if Is_Generic_Instance
(Spec_Id
) then
26916 -- Non-instance case
26919 -- The corresponding Global pragma must mention at least one
26920 -- state with a visible refinement at the point Refined_Global
26921 -- is processed. States with null refinements need Refined_Global
26922 -- pragma (SPARK RM 7.2.4(2)).
26924 if not Has_In_State
26925 and then not Has_In_Out_State
26926 and then not Has_Out_State
26927 and then not Has_Proof_In_State
26928 and then not Has_Null_State
26931 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26932 & "depend on abstract state with visible refinement"),
26936 -- The global refinement of inputs and outputs cannot be null when
26937 -- the corresponding Global pragma contains at least one item except
26938 -- in the case where we have states with null refinements.
26940 elsif Nkind
(Items
) = N_Null
26942 (Present
(In_Items
)
26943 or else Present
(In_Out_Items
)
26944 or else Present
(Out_Items
)
26945 or else Present
(Proof_In_Items
))
26946 and then not Has_Null_State
26949 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
26950 & "global items"), N
, Spec_Id
);
26955 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26956 -- This ensures that the categorization of all refined global items is
26957 -- consistent with their role.
26959 Analyze_Global_In_Decl_Part
(N
);
26961 -- Perform all refinement checks with respect to completeness and mode
26964 if Serious_Errors_Detected
= Errors
then
26965 Check_Refined_Global_List
(Items
);
26968 -- Store the information that no constituent is used in the global
26969 -- refinement, prior to calling checking procedures which remove items
26970 -- from the list of constituents.
26974 and then No
(In_Out_Constits
)
26975 and then No
(Out_Constits
)
26976 and then No
(Proof_In_Constits
);
26978 -- For Input states with visible refinement, at least one constituent
26979 -- must be used as an Input in the global refinement.
26981 if Serious_Errors_Detected
= Errors
then
26982 Check_Input_States
;
26985 -- Verify all possible completion variants for In_Out states with
26986 -- visible refinement.
26988 if Serious_Errors_Detected
= Errors
then
26989 Check_In_Out_States
;
26992 -- For Output states with visible refinement, all constituents must be
26993 -- used as Outputs in the global refinement.
26995 if Serious_Errors_Detected
= Errors
then
26996 Check_Output_States
;
26999 -- For Proof_In states with visible refinement, at least one constituent
27000 -- must be used as Proof_In in the global refinement.
27002 if Serious_Errors_Detected
= Errors
then
27003 Check_Proof_In_States
;
27006 -- Emit errors for all constituents that belong to other states with
27007 -- visible refinement that do not appear in Global.
27009 if Serious_Errors_Detected
= Errors
then
27010 Report_Extra_Constituents
;
27013 -- Emit errors for all items in Global that are not repeated in the
27014 -- global refinement and for which there is no full visible refinement
27015 -- and, in the case of states with partial visible refinement, no
27016 -- constituent is mentioned in the global refinement.
27018 if Serious_Errors_Detected
= Errors
then
27019 Report_Missing_Items
;
27022 -- Emit an error if no constituent is used in the global refinement
27023 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
27024 -- one may be issued by the checking procedures. Do not perform this
27025 -- check in an instance because it was already performed successfully
27026 -- in the generic template.
27028 if Serious_Errors_Detected
= Errors
27029 and then not Is_Generic_Instance
(Spec_Id
)
27030 and then not Has_Null_State
27031 and then No_Constit
27033 SPARK_Msg_N
("missing refinement", N
);
27037 Set_Is_Analyzed_Pragma
(N
);
27038 end Analyze_Refined_Global_In_Decl_Part
;
27040 ----------------------------------------
27041 -- Analyze_Refined_State_In_Decl_Part --
27042 ----------------------------------------
27044 procedure Analyze_Refined_State_In_Decl_Part
27046 Freeze_Id
: Entity_Id
:= Empty
)
27048 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
27049 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
27050 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
27052 Available_States
: Elist_Id
:= No_Elist
;
27053 -- A list of all abstract states defined in the package declaration that
27054 -- are available for refinement. The list is used to report unrefined
27057 Body_States
: Elist_Id
:= No_Elist
;
27058 -- A list of all hidden states that appear in the body of the related
27059 -- package. The list is used to report unused hidden states.
27061 Constituents_Seen
: Elist_Id
:= No_Elist
;
27062 -- A list that contains all constituents processed so far. The list is
27063 -- used to detect multiple uses of the same constituent.
27065 Freeze_Posted
: Boolean := False;
27066 -- A flag that controls the output of a freezing-related error (see use
27069 Refined_States_Seen
: Elist_Id
:= No_Elist
;
27070 -- A list that contains all refined states processed so far. The list is
27071 -- used to detect duplicate refinements.
27073 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
27074 -- Perform full analysis of a single refinement clause
27076 procedure Report_Unrefined_States
(States
: Elist_Id
);
27077 -- Emit errors for all unrefined abstract states found in list States
27079 -------------------------------
27080 -- Analyze_Refinement_Clause --
27081 -------------------------------
27083 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
27084 AR_Constit
: Entity_Id
:= Empty
;
27085 AW_Constit
: Entity_Id
:= Empty
;
27086 ER_Constit
: Entity_Id
:= Empty
;
27087 EW_Constit
: Entity_Id
:= Empty
;
27088 -- The entities of external constituents that contain one of the
27089 -- following enabled properties: Async_Readers, Async_Writers,
27090 -- Effective_Reads and Effective_Writes.
27092 External_Constit_Seen
: Boolean := False;
27093 -- Flag used to mark when at least one external constituent is part
27094 -- of the state refinement.
27096 Non_Null_Seen
: Boolean := False;
27097 Null_Seen
: Boolean := False;
27098 -- Flags used to detect multiple uses of null in a single clause or a
27099 -- mixture of null and non-null constituents.
27101 Part_Of_Constits
: Elist_Id
:= No_Elist
;
27102 -- A list of all candidate constituents subject to indicator Part_Of
27103 -- where the encapsulating state is the current state.
27106 State_Id
: Entity_Id
;
27107 -- The current state being refined
27109 procedure Analyze_Constituent
(Constit
: Node_Id
);
27110 -- Perform full analysis of a single constituent
27112 procedure Check_External_Property
27113 (Prop_Nam
: Name_Id
;
27115 Constit
: Entity_Id
);
27116 -- Determine whether a property denoted by name Prop_Nam is present
27117 -- in the refined state. Emit an error if this is not the case. Flag
27118 -- Enabled should be set when the property applies to the refined
27119 -- state. Constit denotes the constituent (if any) which introduces
27120 -- the property in the refinement.
27122 procedure Match_State
;
27123 -- Determine whether the state being refined appears in list
27124 -- Available_States. Emit an error when attempting to re-refine the
27125 -- state or when the state is not defined in the package declaration,
27126 -- otherwise remove the state from Available_States.
27128 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
27129 -- Emit errors for all unused Part_Of constituents in list Constits
27131 -------------------------
27132 -- Analyze_Constituent --
27133 -------------------------
27135 procedure Analyze_Constituent
(Constit
: Node_Id
) is
27136 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
27137 -- Determine whether constituent Constit denoted by its entity
27138 -- Constit_Id appears in Body_States. Emit an error when the
27139 -- constituent is not a valid hidden state of the related package
27140 -- or when it is used more than once. Otherwise remove the
27141 -- constituent from Body_States.
27143 -----------------------
27144 -- Match_Constituent --
27145 -----------------------
27147 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
27148 procedure Collect_Constituent
;
27149 -- Verify the legality of constituent Constit_Id and add it to
27150 -- the refinements of State_Id.
27152 -------------------------
27153 -- Collect_Constituent --
27154 -------------------------
27156 procedure Collect_Constituent
is
27157 Constits
: Elist_Id
;
27160 -- The Ghost policy in effect at the point of abstract state
27161 -- declaration and constituent must match (SPARK RM 6.9(15))
27163 Check_Ghost_Refinement
27164 (State
, State_Id
, Constit
, Constit_Id
);
27166 -- A synchronized state must be refined by a synchronized
27167 -- object or another synchronized state (SPARK RM 9.6).
27169 if Is_Synchronized_State
(State_Id
)
27170 and then not Is_Synchronized_Object
(Constit_Id
)
27171 and then not Is_Synchronized_State
(Constit_Id
)
27174 ("constituent of synchronized state & must be "
27175 & "synchronized", Constit
, State_Id
);
27178 -- Add the constituent to the list of processed items to aid
27179 -- with the detection of duplicates.
27181 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
27183 -- Collect the constituent in the list of refinement items
27184 -- and establish a relation between the refined state and
27187 Constits
:= Refinement_Constituents
(State_Id
);
27189 if No
(Constits
) then
27190 Constits
:= New_Elmt_List
;
27191 Set_Refinement_Constituents
(State_Id
, Constits
);
27194 Append_Elmt
(Constit_Id
, Constits
);
27195 Set_Encapsulating_State
(Constit_Id
, State_Id
);
27197 -- The state has at least one legal constituent, mark the
27198 -- start of the refinement region. The region ends when the
27199 -- body declarations end (see routine Analyze_Declarations).
27201 Set_Has_Visible_Refinement
(State_Id
);
27203 -- When the constituent is external, save its relevant
27204 -- property for further checks.
27206 if Async_Readers_Enabled
(Constit_Id
) then
27207 AR_Constit
:= Constit_Id
;
27208 External_Constit_Seen
:= True;
27211 if Async_Writers_Enabled
(Constit_Id
) then
27212 AW_Constit
:= Constit_Id
;
27213 External_Constit_Seen
:= True;
27216 if Effective_Reads_Enabled
(Constit_Id
) then
27217 ER_Constit
:= Constit_Id
;
27218 External_Constit_Seen
:= True;
27221 if Effective_Writes_Enabled
(Constit_Id
) then
27222 EW_Constit
:= Constit_Id
;
27223 External_Constit_Seen
:= True;
27225 end Collect_Constituent
;
27229 State_Elmt
: Elmt_Id
;
27231 -- Start of processing for Match_Constituent
27234 -- Detect a duplicate use of a constituent
27236 if Contains
(Constituents_Seen
, Constit_Id
) then
27238 ("duplicate use of constituent &", Constit
, Constit_Id
);
27242 -- The constituent is subject to a Part_Of indicator
27244 if Present
(Encapsulating_State
(Constit_Id
)) then
27245 if Encapsulating_State
(Constit_Id
) = State_Id
then
27246 Remove
(Part_Of_Constits
, Constit_Id
);
27247 Collect_Constituent
;
27249 -- The constituent is part of another state and is used
27250 -- incorrectly in the refinement of the current state.
27253 Error_Msg_Name_1
:= Chars
(State_Id
);
27255 ("& cannot act as constituent of state %",
27256 Constit
, Constit_Id
);
27258 ("\Part_Of indicator specifies encapsulator &",
27259 Constit
, Encapsulating_State
(Constit_Id
));
27262 -- The only other source of legal constituents is the body
27263 -- state space of the related package.
27266 if Present
(Body_States
) then
27267 State_Elmt
:= First_Elmt
(Body_States
);
27268 while Present
(State_Elmt
) loop
27270 -- Consume a valid constituent to signal that it has
27271 -- been encountered.
27273 if Node
(State_Elmt
) = Constit_Id
then
27274 Remove_Elmt
(Body_States
, State_Elmt
);
27275 Collect_Constituent
;
27279 Next_Elmt
(State_Elmt
);
27283 -- Constants are part of the hidden state of a package, but
27284 -- the compiler cannot determine whether they have variable
27285 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
27286 -- hidden state. Accept the constant quietly even if it is
27287 -- a visible state or lacks a Part_Of indicator.
27289 if Ekind
(Constit_Id
) = E_Constant
then
27290 Collect_Constituent
;
27292 -- If we get here, then the constituent is not a hidden
27293 -- state of the related package and may not be used in a
27294 -- refinement (SPARK RM 7.2.2(9)).
27297 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27299 ("cannot use & in refinement, constituent is not a "
27300 & "hidden state of package %", Constit
, Constit_Id
);
27303 end Match_Constituent
;
27307 Constit_Id
: Entity_Id
;
27308 Constits
: Elist_Id
;
27310 -- Start of processing for Analyze_Constituent
27313 -- Detect multiple uses of null in a single refinement clause or a
27314 -- mixture of null and non-null constituents.
27316 if Nkind
(Constit
) = N_Null
then
27319 ("multiple null constituents not allowed", Constit
);
27321 elsif Non_Null_Seen
then
27323 ("cannot mix null and non-null constituents", Constit
);
27328 -- Collect the constituent in the list of refinement items
27330 Constits
:= Refinement_Constituents
(State_Id
);
27332 if No
(Constits
) then
27333 Constits
:= New_Elmt_List
;
27334 Set_Refinement_Constituents
(State_Id
, Constits
);
27337 Append_Elmt
(Constit
, Constits
);
27339 -- The state has at least one legal constituent, mark the
27340 -- start of the refinement region. The region ends when the
27341 -- body declarations end (see Analyze_Declarations).
27343 Set_Has_Visible_Refinement
(State_Id
);
27346 -- Non-null constituents
27349 Non_Null_Seen
:= True;
27353 ("cannot mix null and non-null constituents", Constit
);
27357 Resolve_State
(Constit
);
27359 -- Ensure that the constituent denotes a valid state or a
27360 -- whole object (SPARK RM 7.2.2(5)).
27362 if Is_Entity_Name
(Constit
) then
27363 Constit_Id
:= Entity_Of
(Constit
);
27365 -- When a constituent is declared after a subprogram body
27366 -- that caused freezing of the related contract where
27367 -- pragma Refined_State resides, the constituent appears
27368 -- undefined and carries Any_Id as its entity.
27370 -- package body Pack
27371 -- with Refined_State => (State => Constit)
27374 -- with Refined_Global => (Input => Constit)
27382 if Constit_Id
= Any_Id
then
27383 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
27385 -- Emit a specialized info message when the contract of
27386 -- the related package body was "frozen" by another body.
27387 -- Note that it is not possible to precisely identify why
27388 -- the constituent is undefined because it is not visible
27389 -- when pragma Refined_State is analyzed. This message is
27390 -- a reasonable approximation.
27392 if Present
(Freeze_Id
) and then not Freeze_Posted
then
27393 Freeze_Posted
:= True;
27395 Error_Msg_Name_1
:= Chars
(Body_Id
);
27396 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27398 ("body & declared # freezes the contract of %",
27401 ("\all constituents must be declared before body #",
27404 -- A misplaced constituent is a critical error because
27405 -- pragma Refined_Depends or Refined_Global depends on
27406 -- the proper link between a state and a constituent.
27407 -- Stop the compilation, as this leads to a multitude
27408 -- of misleading cascaded errors.
27410 raise Unrecoverable_Error
;
27413 -- The constituent is a valid state or object
27415 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
27419 Match_Constituent
(Constit_Id
);
27421 -- The variable may eventually become a constituent of a
27422 -- single protected/task type. Record the reference now
27423 -- and verify its legality when analyzing the contract of
27424 -- the variable (SPARK RM 9.3).
27426 if Ekind
(Constit_Id
) = E_Variable
then
27427 Record_Possible_Part_Of_Reference
27428 (Var_Id
=> Constit_Id
,
27432 -- Otherwise the constituent is illegal
27436 ("constituent & must denote object or state",
27437 Constit
, Constit_Id
);
27440 -- The constituent is illegal
27443 SPARK_Msg_N
("malformed constituent", Constit
);
27446 end Analyze_Constituent
;
27448 -----------------------------
27449 -- Check_External_Property --
27450 -----------------------------
27452 procedure Check_External_Property
27453 (Prop_Nam
: Name_Id
;
27455 Constit
: Entity_Id
)
27458 -- The property is missing in the declaration of the state, but
27459 -- a constituent is introducing it in the state refinement
27460 -- (SPARK RM 7.2.8(2)).
27462 if not Enabled
and then Present
(Constit
) then
27463 Error_Msg_Name_1
:= Prop_Nam
;
27464 Error_Msg_Name_2
:= Chars
(State_Id
);
27466 ("constituent & introduces external property % in refinement "
27467 & "of state %", State
, Constit
);
27469 Error_Msg_Sloc
:= Sloc
(State_Id
);
27471 ("\property is missing in abstract state declaration #",
27474 end Check_External_Property
;
27480 procedure Match_State
is
27481 State_Elmt
: Elmt_Id
;
27484 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
27486 if Contains
(Refined_States_Seen
, State_Id
) then
27488 ("duplicate refinement of state &", State
, State_Id
);
27492 -- Inspect the abstract states defined in the package declaration
27493 -- looking for a match.
27495 State_Elmt
:= First_Elmt
(Available_States
);
27496 while Present
(State_Elmt
) loop
27498 -- A valid abstract state is being refined in the body. Add
27499 -- the state to the list of processed refined states to aid
27500 -- with the detection of duplicate refinements. Remove the
27501 -- state from Available_States to signal that it has already
27504 if Node
(State_Elmt
) = State_Id
then
27505 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
27506 Remove_Elmt
(Available_States
, State_Elmt
);
27510 Next_Elmt
(State_Elmt
);
27513 -- If we get here, we are refining a state that is not defined in
27514 -- the package declaration.
27516 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27518 ("cannot refine state, & is not defined in package %",
27522 --------------------------------
27523 -- Report_Unused_Constituents --
27524 --------------------------------
27526 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
27527 Constit_Elmt
: Elmt_Id
;
27528 Constit_Id
: Entity_Id
;
27529 Posted
: Boolean := False;
27532 if Present
(Constits
) then
27533 Constit_Elmt
:= First_Elmt
(Constits
);
27534 while Present
(Constit_Elmt
) loop
27535 Constit_Id
:= Node
(Constit_Elmt
);
27537 -- Generate an error message of the form:
27539 -- state ... has unused Part_Of constituents
27540 -- abstract state ... defined at ...
27541 -- constant ... defined at ...
27542 -- variable ... defined at ...
27547 ("state & has unused Part_Of constituents",
27551 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
27553 if Ekind
(Constit_Id
) = E_Abstract_State
then
27555 ("\abstract state & defined #", State
, Constit_Id
);
27557 elsif Ekind
(Constit_Id
) = E_Constant
then
27559 ("\constant & defined #", State
, Constit_Id
);
27562 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
27563 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
27566 Next_Elmt
(Constit_Elmt
);
27569 end Report_Unused_Constituents
;
27571 -- Local declarations
27573 Body_Ref
: Node_Id
;
27574 Body_Ref_Elmt
: Elmt_Id
;
27576 Extra_State
: Node_Id
;
27578 -- Start of processing for Analyze_Refinement_Clause
27581 -- A refinement clause appears as a component association where the
27582 -- sole choice is the state and the expressions are the constituents.
27583 -- This is a syntax error, always report.
27585 if Nkind
(Clause
) /= N_Component_Association
then
27586 Error_Msg_N
("malformed state refinement clause", Clause
);
27590 -- Analyze the state name of a refinement clause
27592 State
:= First
(Choices
(Clause
));
27595 Resolve_State
(State
);
27597 -- Ensure that the state name denotes a valid abstract state that is
27598 -- defined in the spec of the related package.
27600 if Is_Entity_Name
(State
) then
27601 State_Id
:= Entity_Of
(State
);
27603 -- When the abstract state is undefined, it appears as Any_Id. Do
27604 -- not continue with the analysis of the clause.
27606 if State_Id
= Any_Id
then
27609 -- Catch any attempts to re-refine a state or refine a state that
27610 -- is not defined in the package declaration.
27612 elsif Ekind
(State_Id
) = E_Abstract_State
then
27616 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
27620 -- References to a state with visible refinement are illegal.
27621 -- When nested packages are involved, detecting such references is
27622 -- tricky because pragma Refined_State is analyzed later than the
27623 -- offending pragma Depends or Global. References that occur in
27624 -- such nested context are stored in a list. Emit errors for all
27625 -- references found in Body_References (SPARK RM 6.1.4(8)).
27627 if Present
(Body_References
(State_Id
)) then
27628 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
27629 while Present
(Body_Ref_Elmt
) loop
27630 Body_Ref
:= Node
(Body_Ref_Elmt
);
27632 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
27633 Error_Msg_Sloc
:= Sloc
(State
);
27634 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
27636 Next_Elmt
(Body_Ref_Elmt
);
27640 -- The state name is illegal. This is a syntax error, always report.
27643 Error_Msg_N
("malformed state name in refinement clause", State
);
27647 -- A refinement clause may only refine one state at a time
27649 Extra_State
:= Next
(State
);
27651 if Present
(Extra_State
) then
27653 ("refinement clause cannot cover multiple states", Extra_State
);
27656 -- Replicate the Part_Of constituents of the refined state because
27657 -- the algorithm will consume items.
27659 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
27661 -- Analyze all constituents of the refinement. Multiple constituents
27662 -- appear as an aggregate.
27664 Constit
:= Expression
(Clause
);
27666 if Nkind
(Constit
) = N_Aggregate
then
27667 if Present
(Component_Associations
(Constit
)) then
27669 ("constituents of refinement clause must appear in "
27670 & "positional form", Constit
);
27672 else pragma Assert
(Present
(Expressions
(Constit
)));
27673 Constit
:= First
(Expressions
(Constit
));
27674 while Present
(Constit
) loop
27675 Analyze_Constituent
(Constit
);
27680 -- Various forms of a single constituent. Note that these may include
27681 -- malformed constituents.
27684 Analyze_Constituent
(Constit
);
27687 -- Verify that external constituents do not introduce new external
27688 -- property in the state refinement (SPARK RM 7.2.8(2)).
27690 if Is_External_State
(State_Id
) then
27691 Check_External_Property
27692 (Prop_Nam
=> Name_Async_Readers
,
27693 Enabled
=> Async_Readers_Enabled
(State_Id
),
27694 Constit
=> AR_Constit
);
27696 Check_External_Property
27697 (Prop_Nam
=> Name_Async_Writers
,
27698 Enabled
=> Async_Writers_Enabled
(State_Id
),
27699 Constit
=> AW_Constit
);
27701 Check_External_Property
27702 (Prop_Nam
=> Name_Effective_Reads
,
27703 Enabled
=> Effective_Reads_Enabled
(State_Id
),
27704 Constit
=> ER_Constit
);
27706 Check_External_Property
27707 (Prop_Nam
=> Name_Effective_Writes
,
27708 Enabled
=> Effective_Writes_Enabled
(State_Id
),
27709 Constit
=> EW_Constit
);
27711 -- When a refined state is not external, it should not have external
27712 -- constituents (SPARK RM 7.2.8(1)).
27714 elsif External_Constit_Seen
then
27716 ("non-external state & cannot contain external constituents in "
27717 & "refinement", State
, State_Id
);
27720 -- Ensure that all Part_Of candidate constituents have been mentioned
27721 -- in the refinement clause.
27723 Report_Unused_Constituents
(Part_Of_Constits
);
27724 end Analyze_Refinement_Clause
;
27726 -----------------------------
27727 -- Report_Unrefined_States --
27728 -----------------------------
27730 procedure Report_Unrefined_States
(States
: Elist_Id
) is
27731 State_Elmt
: Elmt_Id
;
27734 if Present
(States
) then
27735 State_Elmt
:= First_Elmt
(States
);
27736 while Present
(State_Elmt
) loop
27738 ("abstract state & must be refined", Node
(State_Elmt
));
27740 Next_Elmt
(State_Elmt
);
27743 end Report_Unrefined_States
;
27745 -- Local declarations
27747 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
27750 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27753 -- Do not analyze the pragma multiple times
27755 if Is_Analyzed_Pragma
(N
) then
27759 -- Replicate the abstract states declared by the package because the
27760 -- matching algorithm will consume states.
27762 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
27764 -- Gather all abstract states and objects declared in the visible
27765 -- state space of the package body. These items must be utilized as
27766 -- constituents in a state refinement.
27768 Body_States
:= Collect_Body_States
(Body_Id
);
27770 -- Multiple non-null state refinements appear as an aggregate
27772 if Nkind
(Clauses
) = N_Aggregate
then
27773 if Present
(Expressions
(Clauses
)) then
27775 ("state refinements must appear as component associations",
27778 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
27779 Clause
:= First
(Component_Associations
(Clauses
));
27780 while Present
(Clause
) loop
27781 Analyze_Refinement_Clause
(Clause
);
27786 -- Various forms of a single state refinement. Note that these may
27787 -- include malformed refinements.
27790 Analyze_Refinement_Clause
(Clauses
);
27793 -- List all abstract states that were left unrefined
27795 Report_Unrefined_States
(Available_States
);
27797 Set_Is_Analyzed_Pragma
(N
);
27798 end Analyze_Refined_State_In_Decl_Part
;
27800 ------------------------------------
27801 -- Analyze_Test_Case_In_Decl_Part --
27802 ------------------------------------
27804 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
27805 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27806 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27808 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
27809 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27810 -- denoted by Arg_Nam.
27812 ------------------------------
27813 -- Preanalyze_Test_Case_Arg --
27814 ------------------------------
27816 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
27820 -- Preanalyze the original aspect argument for ASIS or for a generic
27821 -- subprogram to properly capture global references.
27823 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
27827 Arg_Nam
=> Arg_Nam
,
27828 From_Aspect
=> True);
27830 if Present
(Arg
) then
27831 Preanalyze_Assert_Expression
27832 (Expression
(Arg
), Standard_Boolean
);
27836 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
27838 if Present
(Arg
) then
27839 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
27841 end Preanalyze_Test_Case_Arg
;
27845 Restore_Scope
: Boolean := False;
27847 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27850 -- Do not analyze the pragma multiple times
27852 if Is_Analyzed_Pragma
(N
) then
27856 -- Ensure that the formal parameters are visible when analyzing all
27857 -- clauses. This falls out of the general rule of aspects pertaining
27858 -- to subprogram declarations.
27860 if not In_Open_Scopes
(Spec_Id
) then
27861 Restore_Scope
:= True;
27862 Push_Scope
(Spec_Id
);
27864 if Is_Generic_Subprogram
(Spec_Id
) then
27865 Install_Generic_Formals
(Spec_Id
);
27867 Install_Formals
(Spec_Id
);
27871 Preanalyze_Test_Case_Arg
(Name_Requires
);
27872 Preanalyze_Test_Case_Arg
(Name_Ensures
);
27874 if Restore_Scope
then
27878 -- Currently it is not possible to inline pre/postconditions on a
27879 -- subprogram subject to pragma Inline_Always.
27881 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
27883 Set_Is_Analyzed_Pragma
(N
);
27884 end Analyze_Test_Case_In_Decl_Part
;
27890 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
27895 if Present
(List
) then
27896 Elmt
:= First_Elmt
(List
);
27897 while Present
(Elmt
) loop
27898 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
27901 Id
:= Entity_Of
(Node
(Elmt
));
27904 if Id
= Item_Id
then
27915 -----------------------------------
27916 -- Build_Pragma_Check_Equivalent --
27917 -----------------------------------
27919 function Build_Pragma_Check_Equivalent
27921 Subp_Id
: Entity_Id
:= Empty
;
27922 Inher_Id
: Entity_Id
:= Empty
;
27923 Keep_Pragma_Id
: Boolean := False) return Node_Id
27925 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
27926 -- Detect whether node N references a formal parameter subject to
27927 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27928 -- to False to suppress the generation of a reference when analyzing
27931 ------------------------
27932 -- Suppress_Reference --
27933 ------------------------
27935 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
27936 Formal
: Entity_Id
;
27939 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27940 Formal
:= Entity
(N
);
27942 -- The formal parameter is subject to pragma Unreferenced. Prevent
27943 -- the generation of references by resetting the Comes_From_Source
27946 if Is_Formal
(Formal
)
27947 and then Has_Pragma_Unreferenced
(Formal
)
27949 Set_Comes_From_Source
(N
, False);
27954 end Suppress_Reference
;
27956 procedure Suppress_References
is
27957 new Traverse_Proc
(Suppress_Reference
);
27961 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
27962 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
27963 Check_Prag
: Node_Id
;
27967 Needs_Wrapper
: Boolean;
27968 pragma Unreferenced
(Needs_Wrapper
);
27970 -- Start of processing for Build_Pragma_Check_Equivalent
27973 -- When the pre- or postcondition is inherited, map the formals of the
27974 -- inherited subprogram to those of the current subprogram. In addition,
27975 -- map primitive operations of the parent type into the corresponding
27976 -- primitive operations of the descendant.
27978 if Present
(Inher_Id
) then
27979 pragma Assert
(Present
(Subp_Id
));
27981 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
27983 -- Use generic machinery to copy inherited pragma, as if it were an
27984 -- instantiation, resetting source locations appropriately, so that
27985 -- expressions inside the inherited pragma use chained locations.
27986 -- This is used in particular in GNATprove to locate precisely
27987 -- messages on a given inherited pragma.
27989 Set_Copied_Sloc_For_Inherited_Pragma
27990 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
27991 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27993 -- Build the inherited class-wide condition
27995 Build_Class_Wide_Expression
27996 (Prag
=> Check_Prag
,
27998 Par_Subp
=> Inher_Id
,
27999 Adjust_Sloc
=> True,
28000 Needs_Wrapper
=> Needs_Wrapper
);
28002 -- If not an inherited condition simply copy the original pragma
28005 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
28008 -- Mark the pragma as being internally generated and reset the Analyzed
28011 Set_Analyzed
(Check_Prag
, False);
28012 Set_Comes_From_Source
(Check_Prag
, False);
28014 -- The tree of the original pragma may contain references to the
28015 -- formal parameters of the related subprogram. At the same time
28016 -- the corresponding body may mark the formals as unreferenced:
28018 -- procedure Proc (Formal : ...)
28019 -- with Pre => Formal ...;
28021 -- procedure Proc (Formal : ...) is
28022 -- pragma Unreferenced (Formal);
28025 -- This creates problems because all pragma Check equivalents are
28026 -- analyzed at the end of the body declarations. Since all source
28027 -- references have already been accounted for, reset any references
28028 -- to such formals in the generated pragma Check equivalent.
28030 Suppress_References
(Check_Prag
);
28032 if Present
(Corresponding_Aspect
(Prag
)) then
28033 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
28038 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
28039 -- the copied pragma in the newly created pragma, convert the copy into
28040 -- pragma Check by correcting the name and adding a check_kind argument.
28042 if not Keep_Pragma_Id
then
28043 Set_Class_Present
(Check_Prag
, False);
28045 Set_Pragma_Identifier
28046 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
28048 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
28049 Make_Pragma_Argument_Association
(Loc
,
28050 Expression
=> Make_Identifier
(Loc
, Nam
)));
28053 -- Update the error message when the pragma is inherited
28055 if Present
(Inher_Id
) then
28056 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
28058 if Chars
(Msg_Arg
) = Name_Message
then
28059 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
28061 -- Insert "inherited" to improve the error message
28063 if Name_Buffer
(1 .. 8) = "failed p" then
28064 Insert_Str_In_Name_Buffer
("inherited ", 8);
28065 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
28071 end Build_Pragma_Check_Equivalent
;
28073 -----------------------------
28074 -- Check_Applicable_Policy --
28075 -----------------------------
28077 procedure Check_Applicable_Policy
(N
: Node_Id
) is
28081 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
28084 -- No effect if not valid assertion kind name
28086 if not Is_Valid_Assertion_Kind
(Ename
) then
28090 -- Loop through entries in check policy list
28092 PP
:= Opt
.Check_Policy_List
;
28093 while Present
(PP
) loop
28095 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28096 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28100 or else Pnm
= Name_Assertion
28101 or else (Pnm
= Name_Statement_Assertions
28102 and then Nam_In
(Ename
, Name_Assert
,
28103 Name_Assert_And_Cut
,
28105 Name_Loop_Invariant
,
28106 Name_Loop_Variant
))
28108 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
28114 Set_Is_Ignored
(N
, True);
28115 Set_Is_Checked
(N
, False);
28120 Set_Is_Checked
(N
, True);
28121 Set_Is_Ignored
(N
, False);
28123 when Name_Disable
=>
28124 Set_Is_Ignored
(N
, True);
28125 Set_Is_Checked
(N
, False);
28126 Set_Is_Disabled
(N
, True);
28128 -- That should be exhaustive, the null here is a defence
28129 -- against a malformed tree from previous errors.
28138 PP
:= Next_Pragma
(PP
);
28142 -- If there are no specific entries that matched, then we let the
28143 -- setting of assertions govern. Note that this provides the needed
28144 -- compatibility with the RM for the cases of assertion, invariant,
28145 -- precondition, predicate, and postcondition.
28147 if Assertions_Enabled
then
28148 Set_Is_Checked
(N
, True);
28149 Set_Is_Ignored
(N
, False);
28151 Set_Is_Checked
(N
, False);
28152 Set_Is_Ignored
(N
, True);
28154 end Check_Applicable_Policy
;
28156 -------------------------------
28157 -- Check_External_Properties --
28158 -------------------------------
28160 procedure Check_External_Properties
28168 -- All properties enabled
28170 if AR
and AW
and ER
and EW
then
28173 -- Async_Readers + Effective_Writes
28174 -- Async_Readers + Async_Writers + Effective_Writes
28176 elsif AR
and EW
and not ER
then
28179 -- Async_Writers + Effective_Reads
28180 -- Async_Readers + Async_Writers + Effective_Reads
28182 elsif AW
and ER
and not EW
then
28185 -- Async_Readers + Async_Writers
28187 elsif AR
and AW
and not ER
and not EW
then
28192 elsif AR
and not AW
and not ER
and not EW
then
28197 elsif AW
and not AR
and not ER
and not EW
then
28202 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
28205 end Check_External_Properties
;
28211 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
28215 -- Loop through entries in check policy list
28217 PP
:= Opt
.Check_Policy_List
;
28218 while Present
(PP
) loop
28220 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
28221 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
28225 or else (Pnm
= Name_Assertion
28226 and then Is_Valid_Assertion_Kind
(Nam
))
28227 or else (Pnm
= Name_Statement_Assertions
28228 and then Nam_In
(Nam
, Name_Assert
,
28229 Name_Assert_And_Cut
,
28231 Name_Loop_Invariant
,
28232 Name_Loop_Variant
))
28234 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
28243 return Name_Ignore
;
28245 when Name_Disable
=>
28246 return Name_Disable
;
28249 raise Program_Error
;
28253 PP
:= Next_Pragma
(PP
);
28258 -- If there are no specific entries that matched, then we let the
28259 -- setting of assertions govern. Note that this provides the needed
28260 -- compatibility with the RM for the cases of assertion, invariant,
28261 -- precondition, predicate, and postcondition.
28263 if Assertions_Enabled
then
28266 return Name_Ignore
;
28270 ---------------------------
28271 -- Check_Missing_Part_Of --
28272 ---------------------------
28274 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
28275 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
28276 -- Determine whether a package denoted by Pack_Id declares at least one
28279 -----------------------
28280 -- Has_Visible_State --
28281 -----------------------
28283 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
28284 Item_Id
: Entity_Id
;
28287 -- Traverse the entity chain of the package trying to find at least
28288 -- one visible abstract state, variable or a package [instantiation]
28289 -- that declares a visible state.
28291 Item_Id
:= First_Entity
(Pack_Id
);
28292 while Present
(Item_Id
)
28293 and then not In_Private_Part
(Item_Id
)
28295 -- Do not consider internally generated items
28297 if not Comes_From_Source
(Item_Id
) then
28300 -- A visible state has been found
28302 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
28305 -- Recursively peek into nested packages and instantiations
28307 elsif Ekind
(Item_Id
) = E_Package
28308 and then Has_Visible_State
(Item_Id
)
28313 Next_Entity
(Item_Id
);
28317 end Has_Visible_State
;
28321 Pack_Id
: Entity_Id
;
28322 Placement
: State_Space_Kind
;
28324 -- Start of processing for Check_Missing_Part_Of
28327 -- Do not consider abstract states, variables or package instantiations
28328 -- coming from an instance as those always inherit the Part_Of indicator
28329 -- of the instance itself.
28331 if In_Instance
then
28334 -- Do not consider internally generated entities as these can never
28335 -- have a Part_Of indicator.
28337 elsif not Comes_From_Source
(Item_Id
) then
28340 -- Perform these checks only when SPARK_Mode is enabled as they will
28341 -- interfere with standard Ada rules and produce false positives.
28343 elsif SPARK_Mode
/= On
then
28346 -- Do not consider constants, because the compiler cannot accurately
28347 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
28348 -- act as a hidden state of a package.
28350 elsif Ekind
(Item_Id
) = E_Constant
then
28354 -- Find where the abstract state, variable or package instantiation
28355 -- lives with respect to the state space.
28357 Find_Placement_In_State_Space
28358 (Item_Id
=> Item_Id
,
28359 Placement
=> Placement
,
28360 Pack_Id
=> Pack_Id
);
28362 -- Items that appear in a non-package construct (subprogram, block, etc)
28363 -- do not require a Part_Of indicator because they can never act as a
28366 if Placement
= Not_In_Package
then
28369 -- An item declared in the body state space of a package always act as a
28370 -- constituent and does not need explicit Part_Of indicator.
28372 elsif Placement
= Body_State_Space
then
28375 -- In general an item declared in the visible state space of a package
28376 -- does not require a Part_Of indicator. The only exception is when the
28377 -- related package is a private child unit in which case Part_Of must
28378 -- denote a state in the parent unit or in one of its descendants.
28380 elsif Placement
= Visible_State_Space
then
28381 if Is_Child_Unit
(Pack_Id
)
28382 and then Is_Private_Descendant
(Pack_Id
)
28384 -- A package instantiation does not need a Part_Of indicator when
28385 -- the related generic template has no visible state.
28387 if Ekind
(Item_Id
) = E_Package
28388 and then Is_Generic_Instance
(Item_Id
)
28389 and then not Has_Visible_State
(Item_Id
)
28393 -- All other cases require Part_Of
28397 ("indicator Part_Of is required in this context "
28398 & "(SPARK RM 7.2.6(3))", Item_Id
);
28399 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28401 ("\& is declared in the visible part of private child "
28402 & "unit %", Item_Id
);
28406 -- When the item appears in the private state space of a package, it
28407 -- must be a part of some state declared by the said package.
28409 else pragma Assert
(Placement
= Private_State_Space
);
28411 -- The related package does not declare a state, the item cannot act
28412 -- as a Part_Of constituent.
28414 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
28417 -- A package instantiation does not need a Part_Of indicator when the
28418 -- related generic template has no visible state.
28420 elsif Ekind
(Pack_Id
) = E_Package
28421 and then Is_Generic_Instance
(Pack_Id
)
28422 and then not Has_Visible_State
(Pack_Id
)
28426 -- All other cases require Part_Of
28430 ("indicator Part_Of is required in this context "
28431 & "(SPARK RM 7.2.6(2))", Item_Id
);
28432 Error_Msg_Name_1
:= Chars
(Pack_Id
);
28434 ("\& is declared in the private part of package %", Item_Id
);
28437 end Check_Missing_Part_Of
;
28439 ---------------------------------------------------
28440 -- Check_Postcondition_Use_In_Inlined_Subprogram --
28441 ---------------------------------------------------
28443 procedure Check_Postcondition_Use_In_Inlined_Subprogram
28445 Spec_Id
: Entity_Id
)
28448 if Warn_On_Redundant_Constructs
28449 and then Has_Pragma_Inline_Always
(Spec_Id
)
28450 and then Assertions_Enabled
28452 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28454 if From_Aspect_Specification
(Prag
) then
28456 ("aspect % not enforced on inlined subprogram &?r?",
28457 Corresponding_Aspect
(Prag
), Spec_Id
);
28460 ("pragma % not enforced on inlined subprogram &?r?",
28464 end Check_Postcondition_Use_In_Inlined_Subprogram
;
28466 -------------------------------------
28467 -- Check_State_And_Constituent_Use --
28468 -------------------------------------
28470 procedure Check_State_And_Constituent_Use
28471 (States
: Elist_Id
;
28472 Constits
: Elist_Id
;
28475 Constit_Elmt
: Elmt_Id
;
28476 Constit_Id
: Entity_Id
;
28477 State_Id
: Entity_Id
;
28480 -- Nothing to do if there are no states or constituents
28482 if No
(States
) or else No
(Constits
) then
28486 -- Inspect the list of constituents and try to determine whether its
28487 -- encapsulating state is in list States.
28489 Constit_Elmt
:= First_Elmt
(Constits
);
28490 while Present
(Constit_Elmt
) loop
28491 Constit_Id
:= Node
(Constit_Elmt
);
28493 -- Determine whether the constituent is part of an encapsulating
28494 -- state that appears in the same context and if this is the case,
28495 -- emit an error (SPARK RM 7.2.6(7)).
28497 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
28499 if Present
(State_Id
) then
28500 Error_Msg_Name_1
:= Chars
(Constit_Id
);
28502 ("cannot mention state & and its constituent % in the same "
28503 & "context", Context
, State_Id
);
28507 Next_Elmt
(Constit_Elmt
);
28509 end Check_State_And_Constituent_Use
;
28511 ---------------------------------------------
28512 -- Collect_Inherited_Class_Wide_Conditions --
28513 ---------------------------------------------
28515 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
28516 Parent_Subp
: constant Entity_Id
:=
28517 Ultimate_Alias
(Overridden_Operation
(Subp
));
28518 -- The Overridden_Operation may itself be inherited and as such have no
28519 -- explicit contract.
28521 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
28522 In_Spec_Expr
: Boolean;
28523 Installed
: Boolean;
28525 New_Prag
: Node_Id
;
28528 Installed
:= False;
28530 -- Iterate over the contract of the overridden subprogram to find all
28531 -- inherited class-wide pre- and postconditions.
28533 if Present
(Prags
) then
28534 Prag
:= Pre_Post_Conditions
(Prags
);
28536 while Present
(Prag
) loop
28537 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
28538 Name_Precondition
, Name_Postcondition
)
28539 and then Class_Present
(Prag
)
28541 -- The generated pragma must be analyzed in the context of
28542 -- the subprogram, to make its formals visible. In addition,
28543 -- we must inhibit freezing and full analysis because the
28544 -- controlling type of the subprogram is not frozen yet, and
28545 -- may have further primitives.
28547 if not Installed
then
28550 Install_Formals
(Subp
);
28551 In_Spec_Expr
:= In_Spec_Expression
;
28552 In_Spec_Expression
:= True;
28556 Build_Pragma_Check_Equivalent
28557 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
28559 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
28560 Preanalyze
(New_Prag
);
28562 -- Prevent further analysis in subsequent processing of the
28563 -- current list of declarations
28565 Set_Analyzed
(New_Prag
);
28568 Prag
:= Next_Pragma
(Prag
);
28572 In_Spec_Expression
:= In_Spec_Expr
;
28576 end Collect_Inherited_Class_Wide_Conditions
;
28578 ---------------------------------------
28579 -- Collect_Subprogram_Inputs_Outputs --
28580 ---------------------------------------
28582 procedure Collect_Subprogram_Inputs_Outputs
28583 (Subp_Id
: Entity_Id
;
28584 Synthesize
: Boolean := False;
28585 Subp_Inputs
: in out Elist_Id
;
28586 Subp_Outputs
: in out Elist_Id
;
28587 Global_Seen
: out Boolean)
28589 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
28590 -- Collect all relevant items from a dependency clause
28592 procedure Collect_Global_List
28594 Mode
: Name_Id
:= Name_Input
);
28595 -- Collect all relevant items from a global list
28597 -------------------------------
28598 -- Collect_Dependency_Clause --
28599 -------------------------------
28601 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
28602 procedure Collect_Dependency_Item
28604 Is_Input
: Boolean);
28605 -- Add an item to the proper subprogram input or output collection
28607 -----------------------------
28608 -- Collect_Dependency_Item --
28609 -----------------------------
28611 procedure Collect_Dependency_Item
28613 Is_Input
: Boolean)
28618 -- Nothing to collect when the item is null
28620 if Nkind
(Item
) = N_Null
then
28623 -- Ditto for attribute 'Result
28625 elsif Is_Attribute_Result
(Item
) then
28628 -- Multiple items appear as an aggregate
28630 elsif Nkind
(Item
) = N_Aggregate
then
28631 Extra
:= First
(Expressions
(Item
));
28632 while Present
(Extra
) loop
28633 Collect_Dependency_Item
(Extra
, Is_Input
);
28637 -- Otherwise this is a solitary item
28641 Append_New_Elmt
(Item
, Subp_Inputs
);
28643 Append_New_Elmt
(Item
, Subp_Outputs
);
28646 end Collect_Dependency_Item
;
28648 -- Start of processing for Collect_Dependency_Clause
28651 if Nkind
(Clause
) = N_Null
then
28654 -- A dependency clause appears as component association
28656 elsif Nkind
(Clause
) = N_Component_Association
then
28657 Collect_Dependency_Item
28658 (Item
=> Expression
(Clause
),
28661 Collect_Dependency_Item
28662 (Item
=> First
(Choices
(Clause
)),
28663 Is_Input
=> False);
28665 -- To accommodate partial decoration of disabled SPARK features, this
28666 -- routine may be called with illegal input. If this is the case, do
28667 -- not raise Program_Error.
28672 end Collect_Dependency_Clause
;
28674 -------------------------
28675 -- Collect_Global_List --
28676 -------------------------
28678 procedure Collect_Global_List
28680 Mode
: Name_Id
:= Name_Input
)
28682 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
28683 -- Add an item to the proper subprogram input or output collection
28685 -------------------------
28686 -- Collect_Global_Item --
28687 -------------------------
28689 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
28691 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
28692 Append_New_Elmt
(Item
, Subp_Inputs
);
28695 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
28696 Append_New_Elmt
(Item
, Subp_Outputs
);
28698 end Collect_Global_Item
;
28705 -- Start of processing for Collect_Global_List
28708 if Nkind
(List
) = N_Null
then
28711 -- Single global item declaration
28713 elsif Nkind_In
(List
, N_Expanded_Name
,
28715 N_Selected_Component
)
28717 Collect_Global_Item
(List
, Mode
);
28719 -- Simple global list or moded global list declaration
28721 elsif Nkind
(List
) = N_Aggregate
then
28722 if Present
(Expressions
(List
)) then
28723 Item
:= First
(Expressions
(List
));
28724 while Present
(Item
) loop
28725 Collect_Global_Item
(Item
, Mode
);
28730 Assoc
:= First
(Component_Associations
(List
));
28731 while Present
(Assoc
) loop
28732 Collect_Global_List
28733 (List
=> Expression
(Assoc
),
28734 Mode
=> Chars
(First
(Choices
(Assoc
))));
28739 -- To accommodate partial decoration of disabled SPARK features, this
28740 -- routine may be called with illegal input. If this is the case, do
28741 -- not raise Program_Error.
28746 end Collect_Global_List
;
28753 Formal
: Entity_Id
;
28755 Spec_Id
: Entity_Id
:= Empty
;
28756 Subp_Decl
: Node_Id
;
28759 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28762 Global_Seen
:= False;
28764 -- Process all formal parameters of entries, [generic] subprograms, and
28767 if Ekind_In
(Subp_Id
, E_Entry
,
28770 E_Generic_Function
,
28771 E_Generic_Procedure
,
28775 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
28776 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28778 -- Process all formal parameters
28780 Formal
:= First_Entity
(Spec_Id
);
28781 while Present
(Formal
) loop
28782 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_In_Parameter
) then
28783 Append_New_Elmt
(Formal
, Subp_Inputs
);
28786 if Ekind_In
(Formal
, E_In_Out_Parameter
, E_Out_Parameter
) then
28787 Append_New_Elmt
(Formal
, Subp_Outputs
);
28789 -- Out parameters can act as inputs when the related type is
28790 -- tagged, unconstrained array, unconstrained record, or record
28791 -- with unconstrained components.
28793 if Ekind
(Formal
) = E_Out_Parameter
28794 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
28796 Append_New_Elmt
(Formal
, Subp_Inputs
);
28800 Next_Entity
(Formal
);
28803 -- Otherwise the input denotes a task type, a task body, or the
28804 -- anonymous object created for a single task type.
28806 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
28807 or else Is_Single_Task_Object
(Subp_Id
)
28809 Subp_Decl
:= Declaration_Node
(Subp_Id
);
28810 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28813 -- When processing an entry, subprogram or task body, look for pragmas
28814 -- Refined_Depends and Refined_Global as they specify the inputs and
28817 if Is_Entry_Body
(Subp_Id
)
28818 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
28820 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
28821 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
28823 -- Subprogram declaration or stand-alone body case, look for pragmas
28824 -- Depends and Global
28827 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
28828 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28831 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28832 -- because it provides finer granularity of inputs and outputs.
28834 if Present
(Global
) then
28835 Global_Seen
:= True;
28836 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28838 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28839 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28840 -- the inputs and outputs from [Refined_]Depends.
28842 elsif Synthesize
and then Present
(Depends
) then
28843 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
28845 -- Multiple dependency clauses appear as an aggregate
28847 if Nkind
(Clauses
) = N_Aggregate
then
28848 Clause
:= First
(Component_Associations
(Clauses
));
28849 while Present
(Clause
) loop
28850 Collect_Dependency_Clause
(Clause
);
28854 -- Otherwise this is a single dependency clause
28857 Collect_Dependency_Clause
(Clauses
);
28861 -- The current instance of a protected type acts as a formal parameter
28862 -- of mode IN for functions and IN OUT for entries and procedures
28863 -- (SPARK RM 6.1.4).
28865 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
28866 Typ
:= Scope
(Spec_Id
);
28868 -- Use the anonymous object when the type is single protected
28870 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28871 Typ
:= Anonymous_Object
(Typ
);
28874 Append_New_Elmt
(Typ
, Subp_Inputs
);
28876 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
28877 Append_New_Elmt
(Typ
, Subp_Outputs
);
28880 -- The current instance of a task type acts as a formal parameter of
28881 -- mode IN OUT (SPARK RM 6.1.4).
28883 elsif Ekind
(Spec_Id
) = E_Task_Type
then
28886 -- Use the anonymous object when the type is single task
28888 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28889 Typ
:= Anonymous_Object
(Typ
);
28892 Append_New_Elmt
(Typ
, Subp_Inputs
);
28893 Append_New_Elmt
(Typ
, Subp_Outputs
);
28895 elsif Is_Single_Task_Object
(Spec_Id
) then
28896 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
28897 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
28899 end Collect_Subprogram_Inputs_Outputs
;
28901 ---------------------------
28902 -- Contract_Freeze_Error --
28903 ---------------------------
28905 procedure Contract_Freeze_Error
28906 (Contract_Id
: Entity_Id
;
28907 Freeze_Id
: Entity_Id
)
28910 Error_Msg_Name_1
:= Chars
(Contract_Id
);
28911 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28914 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
28916 ("\all contractual items must be declared before body #", Contract_Id
);
28917 end Contract_Freeze_Error
;
28919 ---------------------------------
28920 -- Delay_Config_Pragma_Analyze --
28921 ---------------------------------
28923 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
28925 return Nam_In
(Pragma_Name_Unmapped
(N
),
28926 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
28927 end Delay_Config_Pragma_Analyze
;
28929 -----------------------
28930 -- Duplication_Error --
28931 -----------------------
28933 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
28934 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
28935 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
28938 Error_Msg_Sloc
:= Sloc
(Prev
);
28939 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28941 -- Emit a precise message to distinguish between source pragmas and
28942 -- pragmas generated from aspects. The ordering of the two pragmas is
28946 -- Prag -- duplicate
28948 -- No error is emitted when both pragmas come from aspects because this
28949 -- is already detected by the general aspect analysis mechanism.
28951 if Prag_From_Asp
and Prev_From_Asp
then
28953 elsif Prag_From_Asp
then
28954 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
28955 elsif Prev_From_Asp
then
28956 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
28958 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
28960 end Duplication_Error
;
28962 ------------------------------
28963 -- Find_Encapsulating_State --
28964 ------------------------------
28966 function Find_Encapsulating_State
28967 (States
: Elist_Id
;
28968 Constit_Id
: Entity_Id
) return Entity_Id
28970 State_Id
: Entity_Id
;
28973 -- Since a constituent may be part of a larger constituent set, climb
28974 -- the encapsulating state chain looking for a state that appears in
28977 State_Id
:= Encapsulating_State
(Constit_Id
);
28978 while Present
(State_Id
) loop
28979 if Contains
(States
, State_Id
) then
28983 State_Id
:= Encapsulating_State
(State_Id
);
28987 end Find_Encapsulating_State
;
28989 --------------------------
28990 -- Find_Related_Context --
28991 --------------------------
28993 function Find_Related_Context
28995 Do_Checks
: Boolean := False) return Node_Id
29000 Stmt
:= Prev
(Prag
);
29001 while Present
(Stmt
) loop
29003 -- Skip prior pragmas, but check for duplicates
29005 if Nkind
(Stmt
) = N_Pragma
then
29007 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
29014 -- Skip internally generated code
29016 elsif not Comes_From_Source
(Stmt
) then
29018 -- The anonymous object created for a single concurrent type is a
29019 -- suitable context.
29021 if Nkind
(Stmt
) = N_Object_Declaration
29022 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29027 -- Return the current source construct
29037 end Find_Related_Context
;
29039 --------------------------------------
29040 -- Find_Related_Declaration_Or_Body --
29041 --------------------------------------
29043 function Find_Related_Declaration_Or_Body
29045 Do_Checks
: Boolean := False) return Node_Id
29047 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
29049 procedure Expression_Function_Error
;
29050 -- Emit an error concerning pragma Prag that illegaly applies to an
29051 -- expression function.
29053 -------------------------------
29054 -- Expression_Function_Error --
29055 -------------------------------
29057 procedure Expression_Function_Error
is
29059 Error_Msg_Name_1
:= Prag_Nam
;
29061 -- Emit a precise message to distinguish between source pragmas and
29062 -- pragmas generated from aspects.
29064 if From_Aspect_Specification
(Prag
) then
29066 ("aspect % cannot apply to a stand alone expression function",
29070 ("pragma % cannot apply to a stand alone expression function",
29073 end Expression_Function_Error
;
29077 Context
: constant Node_Id
:= Parent
(Prag
);
29080 Look_For_Body
: constant Boolean :=
29081 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
29082 Name_Refined_Global
,
29084 Name_Refined_State
);
29085 -- Refinement pragmas must be associated with a subprogram body [stub]
29087 -- Start of processing for Find_Related_Declaration_Or_Body
29090 Stmt
:= Prev
(Prag
);
29091 while Present
(Stmt
) loop
29093 -- Skip prior pragmas, but check for duplicates. Pragmas produced
29094 -- by splitting a complex pre/postcondition are not considered to
29097 if Nkind
(Stmt
) = N_Pragma
then
29099 and then not Split_PPC
(Stmt
)
29100 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
29107 -- Emit an error when a refinement pragma appears on an expression
29108 -- function without a completion.
29111 and then Look_For_Body
29112 and then Nkind
(Stmt
) = N_Subprogram_Declaration
29113 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
29114 and then not Has_Completion
(Defining_Entity
(Stmt
))
29116 Expression_Function_Error
;
29119 -- The refinement pragma applies to a subprogram body stub
29121 elsif Look_For_Body
29122 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
29126 -- Skip internally generated code
29128 elsif not Comes_From_Source
(Stmt
) then
29130 -- The anonymous object created for a single concurrent type is a
29131 -- suitable context.
29133 if Nkind
(Stmt
) = N_Object_Declaration
29134 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
29138 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
29140 -- The subprogram declaration is an internally generated spec
29141 -- for an expression function.
29143 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29146 -- The subprogram is actually an instance housed within an
29147 -- anonymous wrapper package.
29149 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29154 -- Return the current construct which is either a subprogram body,
29155 -- a subprogram declaration or is illegal.
29164 -- If we fall through, then the pragma was either the first declaration
29165 -- or it was preceded by other pragmas and no source constructs.
29167 -- The pragma is associated with a library-level subprogram
29169 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
29170 return Unit
(Parent
(Context
));
29172 -- The pragma appears inside the declarations of an entry body
29174 elsif Nkind
(Context
) = N_Entry_Body
then
29177 -- The pragma appears inside the statements of a subprogram body. This
29178 -- placement is the result of subprogram contract expansion.
29180 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
29181 return Parent
(Context
);
29183 -- The pragma appears inside the declarative part of a package body
29185 elsif Nkind
(Context
) = N_Package_Body
then
29188 -- The pragma appears inside the declarative part of a subprogram body
29190 elsif Nkind
(Context
) = N_Subprogram_Body
then
29193 -- The pragma appears inside the declarative part of a task body
29195 elsif Nkind
(Context
) = N_Task_Body
then
29198 -- The pragma appears inside the visible part of a package specification
29200 elsif Nkind
(Context
) = N_Package_Specification
then
29201 return Parent
(Context
);
29203 -- The pragma is a byproduct of aspect expansion, return the related
29204 -- context of the original aspect. This case has a lower priority as
29205 -- the above circuitry pinpoints precisely the related context.
29207 elsif Present
(Corresponding_Aspect
(Prag
)) then
29208 return Parent
(Corresponding_Aspect
(Prag
));
29210 -- No candidate subprogram [body] found
29215 end Find_Related_Declaration_Or_Body
;
29217 ----------------------------------
29218 -- Find_Related_Package_Or_Body --
29219 ----------------------------------
29221 function Find_Related_Package_Or_Body
29223 Do_Checks
: Boolean := False) return Node_Id
29225 Context
: constant Node_Id
:= Parent
(Prag
);
29226 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
29230 Stmt
:= Prev
(Prag
);
29231 while Present
(Stmt
) loop
29233 -- Skip prior pragmas, but check for duplicates
29235 if Nkind
(Stmt
) = N_Pragma
then
29236 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
29242 -- Skip internally generated code
29244 elsif not Comes_From_Source
(Stmt
) then
29245 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
29247 -- The subprogram declaration is an internally generated spec
29248 -- for an expression function.
29250 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
29253 -- The subprogram is actually an instance housed within an
29254 -- anonymous wrapper package.
29256 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
29261 -- Return the current source construct which is illegal
29270 -- If we fall through, then the pragma was either the first declaration
29271 -- or it was preceded by other pragmas and no source constructs.
29273 -- The pragma is associated with a package. The immediate context in
29274 -- this case is the specification of the package.
29276 if Nkind
(Context
) = N_Package_Specification
then
29277 return Parent
(Context
);
29279 -- The pragma appears in the declarations of a package body
29281 elsif Nkind
(Context
) = N_Package_Body
then
29284 -- The pragma appears in the statements of a package body
29286 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
29287 and then Nkind
(Parent
(Context
)) = N_Package_Body
29289 return Parent
(Context
);
29291 -- The pragma is a byproduct of aspect expansion, return the related
29292 -- context of the original aspect. This case has a lower priority as
29293 -- the above circuitry pinpoints precisely the related context.
29295 elsif Present
(Corresponding_Aspect
(Prag
)) then
29296 return Parent
(Corresponding_Aspect
(Prag
));
29298 -- No candidate package [body] found
29303 end Find_Related_Package_Or_Body
;
29309 function Get_Argument
29311 Context_Id
: Entity_Id
:= Empty
) return Node_Id
29313 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
29316 -- Use the expression of the original aspect when compiling for ASIS or
29317 -- when analyzing the template of a generic unit. In both cases the
29318 -- aspect's tree must be decorated to allow for ASIS queries or to save
29319 -- the global references in the generic context.
29321 if From_Aspect_Specification
(Prag
)
29322 and then (ASIS_Mode
or else (Present
(Context_Id
)
29323 and then Is_Generic_Unit
(Context_Id
)))
29325 return Corresponding_Aspect
(Prag
);
29327 -- Otherwise use the expression of the pragma
29329 elsif Present
(Args
) then
29330 return First
(Args
);
29337 -------------------------
29338 -- Get_Base_Subprogram --
29339 -------------------------
29341 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
29342 Result
: Entity_Id
;
29345 -- Follow subprogram renaming chain
29349 if Is_Subprogram
(Result
)
29351 Nkind
(Parent
(Declaration_Node
(Result
))) =
29352 N_Subprogram_Renaming_Declaration
29353 and then Present
(Alias
(Result
))
29355 Result
:= Alias
(Result
);
29359 end Get_Base_Subprogram
;
29361 -----------------------
29362 -- Get_SPARK_Mode_Type --
29363 -----------------------
29365 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
29367 if N
= Name_On
then
29369 elsif N
= Name_Off
then
29372 -- Any other argument is illegal. Assume that no SPARK mode applies to
29373 -- avoid potential cascaded errors.
29378 end Get_SPARK_Mode_Type
;
29380 ------------------------------------
29381 -- Get_SPARK_Mode_From_Annotation --
29382 ------------------------------------
29384 function Get_SPARK_Mode_From_Annotation
29385 (N
: Node_Id
) return SPARK_Mode_Type
29390 if Nkind
(N
) = N_Aspect_Specification
then
29391 Mode
:= Expression
(N
);
29393 else pragma Assert
(Nkind
(N
) = N_Pragma
);
29394 Mode
:= First
(Pragma_Argument_Associations
(N
));
29396 if Present
(Mode
) then
29397 Mode
:= Get_Pragma_Arg
(Mode
);
29401 -- Aspect or pragma SPARK_Mode specifies an explicit mode
29403 if Present
(Mode
) then
29404 if Nkind
(Mode
) = N_Identifier
then
29405 return Get_SPARK_Mode_Type
(Chars
(Mode
));
29407 -- In case of a malformed aspect or pragma, return the default None
29413 -- Otherwise the lack of an expression defaults SPARK_Mode to On
29418 end Get_SPARK_Mode_From_Annotation
;
29420 ---------------------------
29421 -- Has_Extra_Parentheses --
29422 ---------------------------
29424 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
29428 -- The aggregate should not have an expression list because a clause
29429 -- is always interpreted as a component association. The only way an
29430 -- expression list can sneak in is by adding extra parentheses around
29431 -- the individual clauses:
29433 -- Depends (Output => Input) -- proper form
29434 -- Depends ((Output => Input)) -- extra parentheses
29436 -- Since the extra parentheses are not allowed by the syntax of the
29437 -- pragma, flag them now to avoid emitting misleading errors down the
29440 if Nkind
(Clause
) = N_Aggregate
29441 and then Present
(Expressions
(Clause
))
29443 Expr
:= First
(Expressions
(Clause
));
29444 while Present
(Expr
) loop
29446 -- A dependency clause surrounded by extra parentheses appears
29447 -- as an aggregate of component associations with an optional
29448 -- Paren_Count set.
29450 if Nkind
(Expr
) = N_Aggregate
29451 and then Present
(Component_Associations
(Expr
))
29454 ("dependency clause contains extra parentheses", Expr
);
29456 -- Otherwise the expression is a malformed construct
29459 SPARK_Msg_N
("malformed dependency clause", Expr
);
29469 end Has_Extra_Parentheses
;
29475 procedure Initialize
is
29486 Dummy
:= Dummy
+ 1;
29489 -----------------------------
29490 -- Is_Config_Static_String --
29491 -----------------------------
29493 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29495 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
29496 -- This is an internal recursive function that is just like the outer
29497 -- function except that it adds the string to the name buffer rather
29498 -- than placing the string in the name buffer.
29500 ------------------------------
29501 -- Add_Config_Static_String --
29502 ------------------------------
29504 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
29511 if Nkind
(N
) = N_Op_Concat
then
29512 if Add_Config_Static_String
(Left_Opnd
(N
)) then
29513 N
:= Right_Opnd
(N
);
29519 if Nkind
(N
) /= N_String_Literal
then
29520 Error_Msg_N
("string literal expected for pragma argument", N
);
29524 for J
in 1 .. String_Length
(Strval
(N
)) loop
29525 C
:= Get_String_Char
(Strval
(N
), J
);
29527 if not In_Character_Range
(C
) then
29529 ("string literal contains invalid wide character",
29530 Sloc
(N
) + 1 + Source_Ptr
(J
));
29534 Add_Char_To_Name_Buffer
(Get_Character
(C
));
29539 end Add_Config_Static_String
;
29541 -- Start of processing for Is_Config_Static_String
29546 return Add_Config_Static_String
(Arg
);
29547 end Is_Config_Static_String
;
29549 -------------------------------
29550 -- Is_Elaboration_SPARK_Mode --
29551 -------------------------------
29553 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
29556 (Nkind
(N
) = N_Pragma
29557 and then Pragma_Name
(N
) = Name_SPARK_Mode
29558 and then Is_List_Member
(N
));
29560 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29561 -- appears in the statement part of the body.
29564 Present
(Parent
(N
))
29565 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
29566 and then List_Containing
(N
) = Statements
(Parent
(N
))
29567 and then Present
(Parent
(Parent
(N
)))
29568 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
29569 end Is_Elaboration_SPARK_Mode
;
29571 -----------------------
29572 -- Is_Enabled_Pragma --
29573 -----------------------
29575 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
29579 if Present
(Prag
) then
29580 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29582 if Present
(Arg
) then
29583 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
29585 -- The lack of a Boolean argument automatically enables the pragma
29591 -- The pragma is missing, therefore it is not enabled
29596 end Is_Enabled_Pragma
;
29598 -----------------------------------------
29599 -- Is_Non_Significant_Pragma_Reference --
29600 -----------------------------------------
29602 -- This function makes use of the following static table which indicates
29603 -- whether appearance of some name in a given pragma is to be considered
29604 -- as a reference for the purposes of warnings about unreferenced objects.
29606 -- -1 indicates that appearence in any argument is significant
29607 -- 0 indicates that appearance in any argument is not significant
29608 -- +n indicates that appearance as argument n is significant, but all
29609 -- other arguments are not significant
29610 -- 9n arguments from n on are significant, before n insignificant
29612 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
29613 (Pragma_Abort_Defer
=> -1,
29614 Pragma_Abstract_State
=> -1,
29615 Pragma_Ada_83
=> -1,
29616 Pragma_Ada_95
=> -1,
29617 Pragma_Ada_05
=> -1,
29618 Pragma_Ada_2005
=> -1,
29619 Pragma_Ada_12
=> -1,
29620 Pragma_Ada_2012
=> -1,
29621 Pragma_Ada_2020
=> -1,
29622 Pragma_All_Calls_Remote
=> -1,
29623 Pragma_Allow_Integer_Address
=> -1,
29624 Pragma_Annotate
=> 93,
29625 Pragma_Assert
=> -1,
29626 Pragma_Assert_And_Cut
=> -1,
29627 Pragma_Assertion_Policy
=> 0,
29628 Pragma_Assume
=> -1,
29629 Pragma_Assume_No_Invalid_Values
=> 0,
29630 Pragma_Async_Readers
=> 0,
29631 Pragma_Async_Writers
=> 0,
29632 Pragma_Asynchronous
=> 0,
29633 Pragma_Atomic
=> 0,
29634 Pragma_Atomic_Components
=> 0,
29635 Pragma_Attach_Handler
=> -1,
29636 Pragma_Attribute_Definition
=> 92,
29637 Pragma_Check
=> -1,
29638 Pragma_Check_Float_Overflow
=> 0,
29639 Pragma_Check_Name
=> 0,
29640 Pragma_Check_Policy
=> 0,
29641 Pragma_CPP_Class
=> 0,
29642 Pragma_CPP_Constructor
=> 0,
29643 Pragma_CPP_Virtual
=> 0,
29644 Pragma_CPP_Vtable
=> 0,
29646 Pragma_C_Pass_By_Copy
=> 0,
29647 Pragma_Comment
=> -1,
29648 Pragma_Common_Object
=> 0,
29649 Pragma_Compile_Time_Error
=> -1,
29650 Pragma_Compile_Time_Warning
=> -1,
29651 Pragma_Compiler_Unit
=> -1,
29652 Pragma_Compiler_Unit_Warning
=> -1,
29653 Pragma_Complete_Representation
=> 0,
29654 Pragma_Complex_Representation
=> 0,
29655 Pragma_Component_Alignment
=> 0,
29656 Pragma_Constant_After_Elaboration
=> 0,
29657 Pragma_Contract_Cases
=> -1,
29658 Pragma_Controlled
=> 0,
29659 Pragma_Convention
=> 0,
29660 Pragma_Convention_Identifier
=> 0,
29661 Pragma_Deadline_Floor
=> -1,
29662 Pragma_Debug
=> -1,
29663 Pragma_Debug_Policy
=> 0,
29664 Pragma_Detect_Blocking
=> 0,
29665 Pragma_Default_Initial_Condition
=> -1,
29666 Pragma_Default_Scalar_Storage_Order
=> 0,
29667 Pragma_Default_Storage_Pool
=> 0,
29668 Pragma_Depends
=> -1,
29669 Pragma_Disable_Atomic_Synchronization
=> 0,
29670 Pragma_Discard_Names
=> 0,
29671 Pragma_Dispatching_Domain
=> -1,
29672 Pragma_Effective_Reads
=> 0,
29673 Pragma_Effective_Writes
=> 0,
29674 Pragma_Elaborate
=> 0,
29675 Pragma_Elaborate_All
=> 0,
29676 Pragma_Elaborate_Body
=> 0,
29677 Pragma_Elaboration_Checks
=> 0,
29678 Pragma_Eliminate
=> 0,
29679 Pragma_Enable_Atomic_Synchronization
=> 0,
29680 Pragma_Export
=> -1,
29681 Pragma_Export_Function
=> -1,
29682 Pragma_Export_Object
=> -1,
29683 Pragma_Export_Procedure
=> -1,
29684 Pragma_Export_Value
=> -1,
29685 Pragma_Export_Valued_Procedure
=> -1,
29686 Pragma_Extend_System
=> -1,
29687 Pragma_Extensions_Allowed
=> 0,
29688 Pragma_Extensions_Visible
=> 0,
29689 Pragma_External
=> -1,
29690 Pragma_Favor_Top_Level
=> 0,
29691 Pragma_External_Name_Casing
=> 0,
29692 Pragma_Fast_Math
=> 0,
29693 Pragma_Finalize_Storage_Only
=> 0,
29695 Pragma_Global
=> -1,
29696 Pragma_Ident
=> -1,
29697 Pragma_Ignore_Pragma
=> 0,
29698 Pragma_Implementation_Defined
=> -1,
29699 Pragma_Implemented
=> -1,
29700 Pragma_Implicit_Packing
=> 0,
29701 Pragma_Import
=> 93,
29702 Pragma_Import_Function
=> 0,
29703 Pragma_Import_Object
=> 0,
29704 Pragma_Import_Procedure
=> 0,
29705 Pragma_Import_Valued_Procedure
=> 0,
29706 Pragma_Independent
=> 0,
29707 Pragma_Independent_Components
=> 0,
29708 Pragma_Initial_Condition
=> -1,
29709 Pragma_Initialize_Scalars
=> 0,
29710 Pragma_Initializes
=> -1,
29711 Pragma_Inline
=> 0,
29712 Pragma_Inline_Always
=> 0,
29713 Pragma_Inline_Generic
=> 0,
29714 Pragma_Inspection_Point
=> -1,
29715 Pragma_Interface
=> 92,
29716 Pragma_Interface_Name
=> 0,
29717 Pragma_Interrupt_Handler
=> -1,
29718 Pragma_Interrupt_Priority
=> -1,
29719 Pragma_Interrupt_State
=> -1,
29720 Pragma_Invariant
=> -1,
29721 Pragma_Keep_Names
=> 0,
29722 Pragma_License
=> 0,
29723 Pragma_Link_With
=> -1,
29724 Pragma_Linker_Alias
=> -1,
29725 Pragma_Linker_Constructor
=> -1,
29726 Pragma_Linker_Destructor
=> -1,
29727 Pragma_Linker_Options
=> -1,
29728 Pragma_Linker_Section
=> -1,
29730 Pragma_Lock_Free
=> 0,
29731 Pragma_Locking_Policy
=> 0,
29732 Pragma_Loop_Invariant
=> -1,
29733 Pragma_Loop_Optimize
=> 0,
29734 Pragma_Loop_Variant
=> -1,
29735 Pragma_Machine_Attribute
=> -1,
29737 Pragma_Main_Storage
=> -1,
29738 Pragma_Max_Queue_Length
=> 0,
29739 Pragma_Memory_Size
=> 0,
29740 Pragma_No_Return
=> 0,
29741 Pragma_No_Body
=> 0,
29742 Pragma_No_Component_Reordering
=> -1,
29743 Pragma_No_Elaboration_Code_All
=> 0,
29744 Pragma_No_Heap_Finalization
=> 0,
29745 Pragma_No_Inline
=> 0,
29746 Pragma_No_Run_Time
=> -1,
29747 Pragma_No_Strict_Aliasing
=> -1,
29748 Pragma_No_Tagged_Streams
=> 0,
29749 Pragma_Normalize_Scalars
=> 0,
29750 Pragma_Obsolescent
=> 0,
29751 Pragma_Optimize
=> 0,
29752 Pragma_Optimize_Alignment
=> 0,
29753 Pragma_Overflow_Mode
=> 0,
29754 Pragma_Overriding_Renamings
=> 0,
29755 Pragma_Ordered
=> 0,
29758 Pragma_Part_Of
=> 0,
29759 Pragma_Partition_Elaboration_Policy
=> 0,
29760 Pragma_Passive
=> 0,
29761 Pragma_Persistent_BSS
=> 0,
29762 Pragma_Polling
=> 0,
29763 Pragma_Prefix_Exception_Messages
=> 0,
29765 Pragma_Postcondition
=> -1,
29766 Pragma_Post_Class
=> -1,
29768 Pragma_Precondition
=> -1,
29769 Pragma_Predicate
=> -1,
29770 Pragma_Predicate_Failure
=> -1,
29771 Pragma_Preelaborable_Initialization
=> -1,
29772 Pragma_Preelaborate
=> 0,
29773 Pragma_Pre_Class
=> -1,
29774 Pragma_Priority
=> -1,
29775 Pragma_Priority_Specific_Dispatching
=> 0,
29776 Pragma_Profile
=> 0,
29777 Pragma_Profile_Warnings
=> 0,
29778 Pragma_Propagate_Exceptions
=> 0,
29779 Pragma_Provide_Shift_Operators
=> 0,
29780 Pragma_Psect_Object
=> 0,
29782 Pragma_Pure_Function
=> 0,
29783 Pragma_Queuing_Policy
=> 0,
29784 Pragma_Rational
=> 0,
29785 Pragma_Ravenscar
=> 0,
29786 Pragma_Refined_Depends
=> -1,
29787 Pragma_Refined_Global
=> -1,
29788 Pragma_Refined_Post
=> -1,
29789 Pragma_Refined_State
=> -1,
29790 Pragma_Relative_Deadline
=> 0,
29791 Pragma_Rename_Pragma
=> 0,
29792 Pragma_Remote_Access_Type
=> -1,
29793 Pragma_Remote_Call_Interface
=> -1,
29794 Pragma_Remote_Types
=> -1,
29795 Pragma_Restricted_Run_Time
=> 0,
29796 Pragma_Restriction_Warnings
=> 0,
29797 Pragma_Restrictions
=> 0,
29798 Pragma_Reviewable
=> -1,
29799 Pragma_Secondary_Stack_Size
=> -1,
29800 Pragma_Short_Circuit_And_Or
=> 0,
29801 Pragma_Share_Generic
=> 0,
29802 Pragma_Shared
=> 0,
29803 Pragma_Shared_Passive
=> 0,
29804 Pragma_Short_Descriptors
=> 0,
29805 Pragma_Simple_Storage_Pool_Type
=> 0,
29806 Pragma_Source_File_Name
=> 0,
29807 Pragma_Source_File_Name_Project
=> 0,
29808 Pragma_Source_Reference
=> 0,
29809 Pragma_SPARK_Mode
=> 0,
29810 Pragma_Storage_Size
=> -1,
29811 Pragma_Storage_Unit
=> 0,
29812 Pragma_Static_Elaboration_Desired
=> 0,
29813 Pragma_Stream_Convert
=> 0,
29814 Pragma_Style_Checks
=> 0,
29815 Pragma_Subtitle
=> 0,
29816 Pragma_Suppress
=> 0,
29817 Pragma_Suppress_Exception_Locations
=> 0,
29818 Pragma_Suppress_All
=> 0,
29819 Pragma_Suppress_Debug_Info
=> 0,
29820 Pragma_Suppress_Initialization
=> 0,
29821 Pragma_System_Name
=> 0,
29822 Pragma_Task_Dispatching_Policy
=> 0,
29823 Pragma_Task_Info
=> -1,
29824 Pragma_Task_Name
=> -1,
29825 Pragma_Task_Storage
=> -1,
29826 Pragma_Test_Case
=> -1,
29827 Pragma_Thread_Local_Storage
=> -1,
29828 Pragma_Time_Slice
=> -1,
29830 Pragma_Type_Invariant
=> -1,
29831 Pragma_Type_Invariant_Class
=> -1,
29832 Pragma_Unchecked_Union
=> 0,
29833 Pragma_Unevaluated_Use_Of_Old
=> 0,
29834 Pragma_Unimplemented_Unit
=> 0,
29835 Pragma_Universal_Aliasing
=> 0,
29836 Pragma_Universal_Data
=> 0,
29837 Pragma_Unmodified
=> 0,
29838 Pragma_Unreferenced
=> 0,
29839 Pragma_Unreferenced_Objects
=> 0,
29840 Pragma_Unreserve_All_Interrupts
=> 0,
29841 Pragma_Unsuppress
=> 0,
29842 Pragma_Unused
=> 0,
29843 Pragma_Use_VADS_Size
=> 0,
29844 Pragma_Validity_Checks
=> 0,
29845 Pragma_Volatile
=> 0,
29846 Pragma_Volatile_Components
=> 0,
29847 Pragma_Volatile_Full_Access
=> 0,
29848 Pragma_Volatile_Function
=> 0,
29849 Pragma_Warning_As_Error
=> 0,
29850 Pragma_Warnings
=> 0,
29851 Pragma_Weak_External
=> 0,
29852 Pragma_Wide_Character_Encoding
=> 0,
29853 Unknown_Pragma
=> 0);
29855 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
29861 function Arg_No
return Nat
;
29862 -- Returns an integer showing what argument we are in. A value of
29863 -- zero means we are not in any of the arguments.
29869 function Arg_No
return Nat
is
29874 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
29888 -- Start of processing for Non_Significant_Pragma_Reference
29893 if Nkind
(P
) /= N_Pragma_Argument_Association
then
29897 Id
:= Get_Pragma_Id
(Parent
(P
));
29898 C
:= Sig_Flags
(Id
);
29913 return AN
< (C
- 90);
29919 end Is_Non_Significant_Pragma_Reference
;
29921 ------------------------------
29922 -- Is_Pragma_String_Literal --
29923 ------------------------------
29925 -- This function returns true if the corresponding pragma argument is a
29926 -- static string expression. These are the only cases in which string
29927 -- literals can appear as pragma arguments. We also allow a string literal
29928 -- as the first argument to pragma Assert (although it will of course
29929 -- always generate a type error).
29931 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
29932 Pragn
: constant Node_Id
:= Parent
(Par
);
29933 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
29934 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
29940 N
:= First
(Assoc
);
29947 if Pname
= Name_Assert
then
29950 elsif Pname
= Name_Export
then
29953 elsif Pname
= Name_Ident
then
29956 elsif Pname
= Name_Import
then
29959 elsif Pname
= Name_Interface_Name
then
29962 elsif Pname
= Name_Linker_Alias
then
29965 elsif Pname
= Name_Linker_Section
then
29968 elsif Pname
= Name_Machine_Attribute
then
29971 elsif Pname
= Name_Source_File_Name
then
29974 elsif Pname
= Name_Source_Reference
then
29977 elsif Pname
= Name_Title
then
29980 elsif Pname
= Name_Subtitle
then
29986 end Is_Pragma_String_Literal
;
29988 ---------------------------
29989 -- Is_Private_SPARK_Mode --
29990 ---------------------------
29992 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
29995 (Nkind
(N
) = N_Pragma
29996 and then Pragma_Name
(N
) = Name_SPARK_Mode
29997 and then Is_List_Member
(N
));
29999 -- For pragma SPARK_Mode to be private, it has to appear in the private
30000 -- declarations of a package.
30003 Present
(Parent
(N
))
30004 and then Nkind
(Parent
(N
)) = N_Package_Specification
30005 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
30006 end Is_Private_SPARK_Mode
;
30008 -------------------------------------
30009 -- Is_Unconstrained_Or_Tagged_Item --
30010 -------------------------------------
30012 function Is_Unconstrained_Or_Tagged_Item
30013 (Item
: Entity_Id
) return Boolean
30015 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
30016 -- Determine whether record type Typ has at least one unconstrained
30019 ---------------------------------
30020 -- Has_Unconstrained_Component --
30021 ---------------------------------
30023 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
30027 Comp
:= First_Component
(Typ
);
30028 while Present
(Comp
) loop
30029 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
30033 Next_Component
(Comp
);
30037 end Has_Unconstrained_Component
;
30041 Typ
: constant Entity_Id
:= Etype
(Item
);
30043 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
30046 if Is_Tagged_Type
(Typ
) then
30049 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
30052 elsif Is_Record_Type
(Typ
) then
30053 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
30056 return Has_Unconstrained_Component
(Typ
);
30059 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
30065 end Is_Unconstrained_Or_Tagged_Item
;
30067 -----------------------------
30068 -- Is_Valid_Assertion_Kind --
30069 -----------------------------
30071 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
30078 | Name_Assertion_Policy
30079 | Name_Static_Predicate
30080 | Name_Dynamic_Predicate
30085 | Name_Type_Invariant
30086 | Name_uType_Invariant
30090 | Name_Assert_And_Cut
30092 | Name_Contract_Cases
30094 | Name_Default_Initial_Condition
30096 | Name_Initial_Condition
30099 | Name_Loop_Invariant
30100 | Name_Loop_Variant
30101 | Name_Postcondition
30102 | Name_Precondition
30104 | Name_Refined_Post
30105 | Name_Statement_Assertions
30112 end Is_Valid_Assertion_Kind
;
30114 --------------------------------------
30115 -- Process_Compilation_Unit_Pragmas --
30116 --------------------------------------
30118 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
30120 -- A special check for pragma Suppress_All, a very strange DEC pragma,
30121 -- strange because it comes at the end of the unit. Rational has the
30122 -- same name for a pragma, but treats it as a program unit pragma, In
30123 -- GNAT we just decide to allow it anywhere at all. If it appeared then
30124 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
30125 -- node, and we insert a pragma Suppress (All_Checks) at the start of
30126 -- the context clause to ensure the correct processing.
30128 if Has_Pragma_Suppress_All
(N
) then
30129 Prepend_To
(Context_Items
(N
),
30130 Make_Pragma
(Sloc
(N
),
30131 Chars
=> Name_Suppress
,
30132 Pragma_Argument_Associations
=> New_List
(
30133 Make_Pragma_Argument_Association
(Sloc
(N
),
30134 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
30137 -- Nothing else to do at the current time
30139 end Process_Compilation_Unit_Pragmas
;
30141 -------------------------------------------
30142 -- Process_Compile_Time_Warning_Or_Error --
30143 -------------------------------------------
30145 procedure Process_Compile_Time_Warning_Or_Error
30149 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
30150 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
30151 Arg2
: constant Node_Id
:= Next
(Arg1
);
30154 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
30156 if Compile_Time_Known_Value
(Arg1x
) then
30157 if Is_True
(Expr_Value
(Arg1x
)) then
30159 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
30160 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
30161 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
30162 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
30163 Str_Len
: constant Nat
:= String_Length
(Str
);
30165 Force
: constant Boolean :=
30166 Prag_Id
= Pragma_Compile_Time_Warning
30167 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
30168 and then (Ekind
(Cent
) /= E_Package
30169 or else not In_Private_Part
(Cent
));
30170 -- Set True if this is the warning case, and we are in the
30171 -- visible part of a package spec, or in a subprogram spec,
30172 -- in which case we want to force the client to see the
30173 -- warning, even though it is not in the main unit.
30181 -- Loop through segments of message separated by line feeds.
30182 -- We output these segments as separate messages with
30183 -- continuation marks for all but the first.
30188 Error_Msg_Strlen
:= 0;
30190 -- Loop to copy characters from argument to error message
30194 exit when Ptr
> Str_Len
;
30195 CC
:= Get_String_Char
(Str
, Ptr
);
30198 -- Ignore wide chars ??? else store character
30200 if In_Character_Range
(CC
) then
30201 C
:= Get_Character
(CC
);
30202 exit when C
= ASCII
.LF
;
30203 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
30204 Error_Msg_String
(Error_Msg_Strlen
) := C
;
30208 -- Here with one line ready to go
30210 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
30212 -- If this is a warning in a spec, then we want clients
30213 -- to see the warning, so mark the message with the
30214 -- special sequence !! to force the warning. In the case
30215 -- of a package spec, we do not force this if we are in
30216 -- the private part of the spec.
30219 if Cont
= False then
30220 Error_Msg
("<<~!!", Eloc
);
30223 Error_Msg
("\<<~!!", Eloc
);
30226 -- Error, rather than warning, or in a body, so we do not
30227 -- need to force visibility for client (error will be
30228 -- output in any case, and this is the situation in which
30229 -- we do not want a client to get a warning, since the
30230 -- warning is in the body or the spec private part).
30233 if Cont
= False then
30234 Error_Msg
("<<~", Eloc
);
30237 Error_Msg
("\<<~", Eloc
);
30241 exit when Ptr
> Str_Len
;
30246 end Process_Compile_Time_Warning_Or_Error
;
30248 ------------------------------------
30249 -- Record_Possible_Body_Reference --
30250 ------------------------------------
30252 procedure Record_Possible_Body_Reference
30253 (State_Id
: Entity_Id
;
30257 Spec_Id
: Entity_Id
;
30260 -- Ensure that we are dealing with a reference to a state
30262 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
30264 -- Climb the tree starting from the reference looking for a package body
30265 -- whose spec declares the referenced state. This criteria automatically
30266 -- excludes references in package specs which are legal. Note that it is
30267 -- not wise to emit an error now as the package body may lack pragma
30268 -- Refined_State or the referenced state may not be mentioned in the
30269 -- refinement. This approach avoids the generation of misleading errors.
30272 while Present
(Context
) loop
30273 if Nkind
(Context
) = N_Package_Body
then
30274 Spec_Id
:= Corresponding_Spec
(Context
);
30276 if Present
(Abstract_States
(Spec_Id
))
30277 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
30279 if No
(Body_References
(State_Id
)) then
30280 Set_Body_References
(State_Id
, New_Elmt_List
);
30283 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
30288 Context
:= Parent
(Context
);
30290 end Record_Possible_Body_Reference
;
30292 ------------------------------------------
30293 -- Relocate_Pragmas_To_Anonymous_Object --
30294 ------------------------------------------
30296 procedure Relocate_Pragmas_To_Anonymous_Object
30297 (Typ_Decl
: Node_Id
;
30298 Obj_Decl
: Node_Id
)
30302 Next_Decl
: Node_Id
;
30305 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
30306 Def
:= Protected_Definition
(Typ_Decl
);
30308 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
30309 Def
:= Task_Definition
(Typ_Decl
);
30312 -- The concurrent definition has a visible declaration list. Inspect it
30313 -- and relocate all canidate pragmas.
30315 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
30316 Decl
:= First
(Visible_Declarations
(Def
));
30317 while Present
(Decl
) loop
30319 -- Preserve the following declaration for iteration purposes due
30320 -- to possible relocation of a pragma.
30322 Next_Decl
:= Next
(Decl
);
30324 if Nkind
(Decl
) = N_Pragma
30325 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
30328 Insert_After
(Obj_Decl
, Decl
);
30330 -- Skip internally generated code
30332 elsif not Comes_From_Source
(Decl
) then
30335 -- No candidate pragmas are available for relocation
30344 end Relocate_Pragmas_To_Anonymous_Object
;
30346 ------------------------------
30347 -- Relocate_Pragmas_To_Body --
30348 ------------------------------
30350 procedure Relocate_Pragmas_To_Body
30351 (Subp_Body
: Node_Id
;
30352 Target_Body
: Node_Id
:= Empty
)
30354 procedure Relocate_Pragma
(Prag
: Node_Id
);
30355 -- Remove a single pragma from its current list and add it to the
30356 -- declarations of the proper body (either Subp_Body or Target_Body).
30358 ---------------------
30359 -- Relocate_Pragma --
30360 ---------------------
30362 procedure Relocate_Pragma
(Prag
: Node_Id
) is
30367 -- When subprogram stubs or expression functions are involves, the
30368 -- destination declaration list belongs to the proper body.
30370 if Present
(Target_Body
) then
30371 Target
:= Target_Body
;
30373 Target
:= Subp_Body
;
30376 Decls
:= Declarations
(Target
);
30380 Set_Declarations
(Target
, Decls
);
30383 -- Unhook the pragma from its current list
30386 Prepend
(Prag
, Decls
);
30387 end Relocate_Pragma
;
30391 Body_Id
: constant Entity_Id
:=
30392 Defining_Unit_Name
(Specification
(Subp_Body
));
30393 Next_Stmt
: Node_Id
;
30396 -- Start of processing for Relocate_Pragmas_To_Body
30399 -- Do not process a body that comes from a separate unit as no construct
30400 -- can possibly follow it.
30402 if not Is_List_Member
(Subp_Body
) then
30405 -- Do not relocate pragmas that follow a stub if the stub does not have
30408 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
30409 and then No
(Target_Body
)
30413 -- Do not process internally generated routine _Postconditions
30415 elsif Ekind
(Body_Id
) = E_Procedure
30416 and then Chars
(Body_Id
) = Name_uPostconditions
30421 -- Look at what is following the body. We are interested in certain kind
30422 -- of pragmas (either from source or byproducts of expansion) that can
30423 -- apply to a body [stub].
30425 Stmt
:= Next
(Subp_Body
);
30426 while Present
(Stmt
) loop
30428 -- Preserve the following statement for iteration purposes due to a
30429 -- possible relocation of a pragma.
30431 Next_Stmt
:= Next
(Stmt
);
30433 -- Move a candidate pragma following the body to the declarations of
30436 if Nkind
(Stmt
) = N_Pragma
30437 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
30440 -- If a source pragma Warnings follows the body, it applies to
30441 -- following statements and does not belong in the body.
30443 if Get_Pragma_Id
(Stmt
) = Pragma_Warnings
30444 and then Comes_From_Source
(Stmt
)
30448 Relocate_Pragma
(Stmt
);
30451 -- Skip internally generated code
30453 elsif not Comes_From_Source
(Stmt
) then
30456 -- No candidate pragmas are available for relocation
30464 end Relocate_Pragmas_To_Body
;
30466 -------------------
30467 -- Resolve_State --
30468 -------------------
30470 procedure Resolve_State
(N
: Node_Id
) is
30475 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30476 Func
:= Entity
(N
);
30478 -- Handle overloading of state names by functions. Traverse the
30479 -- homonym chain looking for an abstract state.
30481 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
30482 pragma Assert
(Is_Overloaded
(N
));
30484 State
:= Homonym
(Func
);
30485 while Present
(State
) loop
30486 if Ekind
(State
) = E_Abstract_State
then
30488 -- Resolve the overloading by setting the proper entity of
30489 -- the reference to that of the state.
30491 Set_Etype
(N
, Standard_Void_Type
);
30492 Set_Entity
(N
, State
);
30493 Set_Is_Overloaded
(N
, False);
30495 Generate_Reference
(State
, N
);
30499 State
:= Homonym
(State
);
30502 -- A function can never act as a state. If the homonym chain does
30503 -- not contain a corresponding state, then something went wrong in
30504 -- the overloading mechanism.
30506 raise Program_Error
;
30511 ----------------------------
30512 -- Rewrite_Assertion_Kind --
30513 ----------------------------
30515 procedure Rewrite_Assertion_Kind
30517 From_Policy
: Boolean := False)
30523 if Nkind
(N
) = N_Attribute_Reference
30524 and then Attribute_Name
(N
) = Name_Class
30525 and then Nkind
(Prefix
(N
)) = N_Identifier
30527 case Chars
(Prefix
(N
)) is
30534 when Name_Type_Invariant
=>
30535 Nam
:= Name_uType_Invariant
;
30537 when Name_Invariant
=>
30538 Nam
:= Name_uInvariant
;
30544 -- Recommend standard use of aspect names Pre/Post
30546 elsif Nkind
(N
) = N_Identifier
30547 and then From_Policy
30548 and then Serious_Errors_Detected
= 0
30549 and then not ASIS_Mode
30551 if Chars
(N
) = Name_Precondition
30552 or else Chars
(N
) = Name_Postcondition
30554 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
30556 ("\use Assertion_Policy and aspect names Pre/Post for "
30557 & "Ada2012 conformance?", N
);
30563 if Nam
/= No_Name
then
30564 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
30566 end Rewrite_Assertion_Kind
;
30574 Dummy
:= Dummy
+ 1;
30577 --------------------------------
30578 -- Set_Encoded_Interface_Name --
30579 --------------------------------
30581 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
30582 Str
: constant String_Id
:= Strval
(S
);
30583 Len
: constant Nat
:= String_Length
(Str
);
30588 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
30591 -- Stores encoded value of character code CC. The encoding we use an
30592 -- underscore followed by four lower case hex digits.
30598 procedure Encode
is
30600 Store_String_Char
(Get_Char_Code
('_'));
30602 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
30604 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
30606 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
30608 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
30611 -- Start of processing for Set_Encoded_Interface_Name
30614 -- If first character is asterisk, this is a link name, and we leave it
30615 -- completely unmodified. We also ignore null strings (the latter case
30616 -- happens only in error cases).
30619 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
30621 Set_Interface_Name
(E
, S
);
30626 CC
:= Get_String_Char
(Str
, J
);
30628 exit when not In_Character_Range
(CC
);
30630 C
:= Get_Character
(CC
);
30632 exit when C
/= '_' and then C
/= '$'
30633 and then C
not in '0' .. '9'
30634 and then C
not in 'a' .. 'z'
30635 and then C
not in 'A' .. 'Z';
30638 Set_Interface_Name
(E
, S
);
30646 -- Here we need to encode. The encoding we use as follows:
30647 -- three underscores + four hex digits (lower case)
30651 for J
in 1 .. String_Length
(Str
) loop
30652 CC
:= Get_String_Char
(Str
, J
);
30654 if not In_Character_Range
(CC
) then
30657 C
:= Get_Character
(CC
);
30659 if C
= '_' or else C
= '$'
30660 or else C
in '0' .. '9'
30661 or else C
in 'a' .. 'z'
30662 or else C
in 'A' .. 'Z'
30664 Store_String_Char
(CC
);
30671 Set_Interface_Name
(E
,
30672 Make_String_Literal
(Sloc
(S
),
30673 Strval
=> End_String
));
30675 end Set_Encoded_Interface_Name
;
30677 ------------------------
30678 -- Set_Elab_Unit_Name --
30679 ------------------------
30681 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
30686 if Nkind
(N
) = N_Identifier
30687 and then Nkind
(With_Item
) = N_Identifier
30689 Set_Entity
(N
, Entity
(With_Item
));
30691 elsif Nkind
(N
) = N_Selected_Component
then
30692 Change_Selected_Component_To_Expanded_Name
(N
);
30693 Set_Entity
(N
, Entity
(With_Item
));
30694 Set_Entity
(Selector_Name
(N
), Entity
(N
));
30696 Pref
:= Prefix
(N
);
30697 Scop
:= Scope
(Entity
(N
));
30698 while Nkind
(Pref
) = N_Selected_Component
loop
30699 Change_Selected_Component_To_Expanded_Name
(Pref
);
30700 Set_Entity
(Selector_Name
(Pref
), Scop
);
30701 Set_Entity
(Pref
, Scop
);
30702 Pref
:= Prefix
(Pref
);
30703 Scop
:= Scope
(Scop
);
30706 Set_Entity
(Pref
, Scop
);
30709 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
30710 end Set_Elab_Unit_Name
;
30712 -------------------
30713 -- Test_Case_Arg --
30714 -------------------
30716 function Test_Case_Arg
30719 From_Aspect
: Boolean := False) return Node_Id
30721 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
30726 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
30731 -- The caller requests the aspect argument
30733 if From_Aspect
then
30734 if Present
(Aspect
)
30735 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
30737 Args
:= Expression
(Aspect
);
30739 -- "Name" and "Mode" may appear without an identifier as a
30740 -- positional association.
30742 if Present
(Expressions
(Args
)) then
30743 Arg
:= First
(Expressions
(Args
));
30745 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30753 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30758 -- Some or all arguments may appear as component associatons
30760 if Present
(Component_Associations
(Args
)) then
30761 Arg
:= First
(Component_Associations
(Args
));
30762 while Present
(Arg
) loop
30763 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
30772 -- Otherwise retrieve the argument directly from the pragma
30775 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30777 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30781 -- Skip argument "Name"
30785 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30789 -- Skip argument "Mode"
30793 -- Arguments "Requires" and "Ensures" are optional and may not be
30796 while Present
(Arg
) loop
30797 if Chars
(Arg
) = Arg_Nam
then