1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2016, 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
;
47 with Lib
.Writ
; use Lib
.Writ
;
48 with Lib
.Xref
; use Lib
.Xref
;
49 with Namet
.Sp
; use Namet
.Sp
;
50 with Nlists
; use Nlists
;
51 with Nmake
; use Nmake
;
52 with Output
; use Output
;
53 with Par_SCO
; use Par_SCO
;
54 with Restrict
; use Restrict
;
55 with Rident
; use Rident
;
56 with Rtsfind
; use Rtsfind
;
58 with Sem_Aux
; use Sem_Aux
;
59 with Sem_Ch3
; use Sem_Ch3
;
60 with Sem_Ch6
; use Sem_Ch6
;
61 with Sem_Ch8
; use Sem_Ch8
;
62 with Sem_Ch12
; use Sem_Ch12
;
63 with Sem_Ch13
; use Sem_Ch13
;
64 with Sem_Disp
; use Sem_Disp
;
65 with Sem_Dist
; use Sem_Dist
;
66 with Sem_Elim
; use Sem_Elim
;
67 with Sem_Eval
; use Sem_Eval
;
68 with Sem_Intr
; use Sem_Intr
;
69 with Sem_Mech
; use Sem_Mech
;
70 with Sem_Res
; use Sem_Res
;
71 with Sem_Type
; use Sem_Type
;
72 with Sem_Util
; use Sem_Util
;
73 with Sem_Warn
; use Sem_Warn
;
74 with Stand
; use Stand
;
75 with Sinfo
; use Sinfo
;
76 with Sinfo
.CN
; use Sinfo
.CN
;
77 with Sinput
; use Sinput
;
78 with Stringt
; use Stringt
;
79 with Stylesw
; use Stylesw
;
81 with Targparm
; use Targparm
;
82 with Tbuild
; use Tbuild
;
84 with Uintp
; use Uintp
;
85 with Uname
; use Uname
;
86 with Urealp
; use Urealp
;
87 with Validsw
; use Validsw
;
88 with Warnsw
; use Warnsw
;
90 package body Sem_Prag
is
92 ----------------------------------------------
93 -- Common Handling of Import-Export Pragmas --
94 ----------------------------------------------
96 -- In the following section, a number of Import_xxx and Export_xxx pragmas
97 -- are defined by GNAT. These are compatible with the DEC pragmas of the
98 -- same name, and all have the following common form and processing:
101 -- [Internal =>] LOCAL_NAME
102 -- [, [External =>] EXTERNAL_SYMBOL]
103 -- [, other optional parameters ]);
106 -- [Internal =>] LOCAL_NAME
107 -- [, [External =>] EXTERNAL_SYMBOL]
108 -- [, other optional parameters ]);
110 -- EXTERNAL_SYMBOL ::=
112 -- | static_string_EXPRESSION
114 -- The internal LOCAL_NAME designates the entity that is imported or
115 -- exported, and must refer to an entity in the current declarative
116 -- part (as required by the rules for LOCAL_NAME).
118 -- The external linker name is designated by the External parameter if
119 -- given, or the Internal parameter if not (if there is no External
120 -- parameter, the External parameter is a copy of the Internal name).
122 -- If the External parameter is given as a string, then this string is
123 -- treated as an external name (exactly as though it had been given as an
124 -- External_Name parameter for a normal Import pragma).
126 -- If the External parameter is given as an identifier (or there is no
127 -- External parameter, so that the Internal identifier is used), then
128 -- the external name is the characters of the identifier, translated
129 -- to all lower case letters.
131 -- Note: the external name specified or implied by any of these special
132 -- Import_xxx or Export_xxx pragmas override an external or link name
133 -- specified in a previous Import or Export pragma.
135 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
136 -- named notation, following the standard rules for subprogram calls, i.e.
137 -- parameters can be given in any order if named notation is used, and
138 -- positional and named notation can be mixed, subject to the rule that all
139 -- positional parameters must appear first.
141 -- Note: All these pragmas are implemented exactly following the DEC design
142 -- and implementation and are intended to be fully compatible with the use
143 -- of these pragmas in the DEC Ada compiler.
145 --------------------------------------------
146 -- Checking for Duplicated External Names --
147 --------------------------------------------
149 -- It is suspicious if two separate Export pragmas use the same external
150 -- name. The following table is used to diagnose this situation so that
151 -- an appropriate warning can be issued.
153 -- The Node_Id stored is for the N_String_Literal node created to hold
154 -- the value of the external name. The Sloc of this node is used to
155 -- cross-reference the location of the duplication.
157 package Externals
is new Table
.Table
(
158 Table_Component_Type
=> Node_Id
,
159 Table_Index_Type
=> Int
,
160 Table_Low_Bound
=> 0,
161 Table_Initial
=> 100,
162 Table_Increment
=> 100,
163 Table_Name
=> "Name_Externals");
165 -------------------------------------
166 -- Local Subprograms and Variables --
167 -------------------------------------
169 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
170 -- This routine is used for possible casing adjustment of an explicit
171 -- external name supplied as a string literal (the node N), according to
172 -- the casing requirement of Opt.External_Name_Casing. If this is set to
173 -- As_Is, then the string literal is returned unchanged, but if it is set
174 -- to Uppercase or Lowercase, then a new string literal with appropriate
175 -- casing is constructed.
177 procedure Analyze_Part_Of
181 Encap_Id
: out Entity_Id
;
182 Legal
: out Boolean);
183 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
184 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
185 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
186 -- package instantiation. Encap denotes the encapsulating state or single
187 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
188 -- the indicator is legal.
190 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
191 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
192 -- Query whether a particular item appears in a mixed list of nodes and
193 -- entities. It is assumed that all nodes in the list have entities.
195 procedure Check_Postcondition_Use_In_Inlined_Subprogram
197 Spec_Id
: Entity_Id
);
198 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
199 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
200 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
202 procedure Check_State_And_Constituent_Use
206 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
207 -- Global and Initializes. Determine whether a state from list States and a
208 -- corresponding constituent from list Constits (if any) appear in the same
209 -- context denoted by Context. If this is the case, emit an error.
211 procedure Contract_Freeze_Error
212 (Contract_Id
: Entity_Id
;
213 Freeze_Id
: Entity_Id
);
214 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
215 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
216 -- of a body which caused contract "freezing" and Contract_Id denotes the
217 -- entity of the affected contstruct.
219 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
220 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
221 -- Prag that duplicates previous pragma Prev.
223 function Find_Related_Context
225 Do_Checks
: Boolean := False) return Node_Id
;
226 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
227 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
228 -- Part_Of. Find the first source declaration or statement found while
229 -- traversing the previous node chain starting from pragma Prag. If flag
230 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
231 -- returns Empty when reaching the start of the node chain.
233 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
234 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
235 -- original one, following the renaming chain) is returned. Otherwise the
236 -- entity is returned unchanged. Should be in Einfo???
238 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
239 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
240 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
241 -- value of type SPARK_Mode_Type.
243 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
244 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
245 -- Determine whether dependency clause Clause is surrounded by extra
246 -- parentheses. If this is the case, issue an error message.
248 function Is_CCT_Instance
250 Context_Id
: Entity_Id
) return Boolean;
251 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
252 -- Global. Determine whether entity Ref_Id denotes the current instance of
253 -- a concurrent type. Context_Id denotes the associated context where the
256 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
257 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
258 -- pragma Depends. Determine whether the type of dependency item Item is
259 -- tagged, unconstrained array, unconstrained record or a record with at
260 -- least one unconstrained component.
262 procedure Record_Possible_Body_Reference
263 (State_Id
: Entity_Id
;
265 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
266 -- Global. Given an abstract state denoted by State_Id and a reference Ref
267 -- to it, determine whether the reference appears in a package body that
268 -- will eventually refine the state. If this is the case, record the
269 -- reference for future checks (see Analyze_Refined_State_In_Decls).
271 procedure Resolve_State
(N
: Node_Id
);
272 -- Handle the overloading of state names by functions. When N denotes a
273 -- function, this routine finds the corresponding state and sets the entity
274 -- of N to that of the state.
276 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
277 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
278 -- then it is rewritten as an identifier with the corresponding special
279 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
282 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
283 -- Place semantic information on the argument of an Elaborate/Elaborate_All
284 -- pragma. Entity name for unit and its parents is taken from item in
285 -- previous with_clause that mentions the unit.
287 Dummy
: Integer := 0;
288 pragma Volatile
(Dummy
);
289 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
292 pragma No_Inline
(ip
);
293 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
294 -- is just to help debugging the front end. If a pragma Inspection_Point
295 -- is added to a source program, then breaking on ip will get you to that
296 -- point in the program.
299 pragma No_Inline
(rv
);
300 -- This is a dummy function called by the processing for pragma Reviewable.
301 -- It is there for assisting front end debugging. By placing a Reviewable
302 -- pragma in the source program, a breakpoint on rv catches this place in
303 -- the source, allowing convenient stepping to the point of interest.
305 -------------------------------
306 -- Adjust_External_Name_Case --
307 -------------------------------
309 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
313 -- Adjust case of literal if required
315 if Opt
.External_Name_Exp_Casing
= As_Is
then
319 -- Copy existing string
325 for J
in 1 .. String_Length
(Strval
(N
)) loop
326 CC
:= Get_String_Char
(Strval
(N
), J
);
328 if Opt
.External_Name_Exp_Casing
= Uppercase
329 and then CC
>= Get_Char_Code
('a')
330 and then CC
<= Get_Char_Code
('z')
332 Store_String_Char
(CC
- 32);
334 elsif Opt
.External_Name_Exp_Casing
= Lowercase
335 and then CC
>= Get_Char_Code
('A')
336 and then CC
<= Get_Char_Code
('Z')
338 Store_String_Char
(CC
+ 32);
341 Store_String_Char
(CC
);
346 Make_String_Literal
(Sloc
(N
),
347 Strval
=> End_String
);
349 end Adjust_External_Name_Case
;
351 -----------------------------------------
352 -- Analyze_Contract_Cases_In_Decl_Part --
353 -----------------------------------------
355 procedure Analyze_Contract_Cases_In_Decl_Part
357 Freeze_Id
: Entity_Id
:= Empty
)
359 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
360 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
362 Others_Seen
: Boolean := False;
363 -- This flag is set when an "others" choice is encountered. It is used
364 -- to detect multiple illegal occurrences of "others".
366 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
367 -- Verify the legality of a single contract case
369 ---------------------------
370 -- Analyze_Contract_Case --
371 ---------------------------
373 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
374 Case_Guard
: Node_Id
;
377 Extra_Guard
: Node_Id
;
380 if Nkind
(CCase
) = N_Component_Association
then
381 Case_Guard
:= First
(Choices
(CCase
));
382 Conseq
:= Expression
(CCase
);
384 -- Each contract case must have exactly one case guard
386 Extra_Guard
:= Next
(Case_Guard
);
388 if Present
(Extra_Guard
) then
390 ("contract case must have exactly one case guard",
394 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
396 if Nkind
(Case_Guard
) = N_Others_Choice
then
399 ("only one others choice allowed in contract cases",
405 elsif Others_Seen
then
407 ("others must be the last choice in contract cases", N
);
410 -- Preanalyze the case guard and consequence
412 if Nkind
(Case_Guard
) /= N_Others_Choice
then
413 Errors
:= Serious_Errors_Detected
;
414 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
416 -- Emit a clarification message when the case guard contains
417 -- at least one undefined reference, possibly due to contract
420 if Errors
/= Serious_Errors_Detected
421 and then Present
(Freeze_Id
)
422 and then Has_Undefined_Reference
(Case_Guard
)
424 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
428 Errors
:= Serious_Errors_Detected
;
429 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
431 -- Emit a clarification message when the consequence contains
432 -- at least one undefined reference, possibly due to contract
435 if Errors
/= Serious_Errors_Detected
436 and then Present
(Freeze_Id
)
437 and then Has_Undefined_Reference
(Conseq
)
439 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
442 -- The contract case is malformed
445 Error_Msg_N
("wrong syntax in contract case", CCase
);
447 end Analyze_Contract_Case
;
451 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
453 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
456 Restore_Scope
: Boolean := False;
458 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
461 -- Do not analyze the pragma multiple times
463 if Is_Analyzed_Pragma
(N
) then
467 -- Set the Ghost mode in effect from the pragma. Due to the delayed
468 -- analysis of the pragma, the Ghost mode at point of declaration and
469 -- point of analysis may not necessarely be the same. Use the mode in
470 -- effect at the point of declaration.
474 -- Single and multiple contract cases must appear in aggregate form. If
475 -- this is not the case, then either the parser of the analysis of the
476 -- pragma failed to produce an aggregate.
478 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
480 if Present
(Component_Associations
(CCases
)) then
482 -- Ensure that the formal parameters are visible when analyzing all
483 -- clauses. This falls out of the general rule of aspects pertaining
484 -- to subprogram declarations.
486 if not In_Open_Scopes
(Spec_Id
) then
487 Restore_Scope
:= True;
488 Push_Scope
(Spec_Id
);
490 if Is_Generic_Subprogram
(Spec_Id
) then
491 Install_Generic_Formals
(Spec_Id
);
493 Install_Formals
(Spec_Id
);
497 CCase
:= First
(Component_Associations
(CCases
));
498 while Present
(CCase
) loop
499 Analyze_Contract_Case
(CCase
);
503 if Restore_Scope
then
507 -- Currently it is not possible to inline pre/postconditions on a
508 -- subprogram subject to pragma Inline_Always.
510 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
512 -- Otherwise the pragma is illegal
515 Error_Msg_N
("wrong syntax for constract cases", N
);
518 Ghost_Mode
:= Save_Ghost_Mode
;
519 Set_Is_Analyzed_Pragma
(N
);
520 end Analyze_Contract_Cases_In_Decl_Part
;
522 ----------------------------------
523 -- Analyze_Depends_In_Decl_Part --
524 ----------------------------------
526 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
527 Loc
: constant Source_Ptr
:= Sloc
(N
);
528 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
529 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
531 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
532 -- A list containing the entities of all the inputs processed so far.
533 -- The list is populated with unique entities because the same input
534 -- may appear in multiple input lists.
536 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
537 -- A list containing the entities of all the outputs processed so far.
538 -- The list is populated with unique entities because output items are
539 -- unique in a dependence relation.
541 Constits_Seen
: Elist_Id
:= No_Elist
;
542 -- A list containing the entities of all constituents processed so far.
543 -- It aids in detecting illegal usage of a state and a corresponding
544 -- constituent in pragma [Refinde_]Depends.
546 Global_Seen
: Boolean := False;
547 -- A flag set when pragma Global has been processed
549 Null_Output_Seen
: Boolean := False;
550 -- A flag used to track the legality of a null output
552 Result_Seen
: Boolean := False;
553 -- A flag set when Spec_Id'Result is processed
555 States_Seen
: Elist_Id
:= No_Elist
;
556 -- A list containing the entities of all states processed so far. It
557 -- helps in detecting illegal usage of a state and a corresponding
558 -- constituent in pragma [Refined_]Depends.
560 Subp_Inputs
: Elist_Id
:= No_Elist
;
561 Subp_Outputs
: Elist_Id
:= No_Elist
;
562 -- Two lists containing the full set of inputs and output of the related
563 -- subprograms. Note that these lists contain both nodes and entities.
565 Task_Input_Seen
: Boolean := False;
566 Task_Output_Seen
: Boolean := False;
567 -- Flags used to track the implicit dependence of a task unit on itself
569 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
570 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
571 -- to the name buffer. The individual kinds are as follows:
572 -- E_Abstract_State - "state"
573 -- E_Constant - "constant"
574 -- E_Discriminant - "discriminant"
575 -- E_Generic_In_Out_Parameter - "generic parameter"
576 -- E_Generic_In_Parameter - "generic parameter"
577 -- E_In_Parameter - "parameter"
578 -- E_In_Out_Parameter - "parameter"
579 -- E_Loop_Parameter - "loop parameter"
580 -- E_Out_Parameter - "parameter"
581 -- E_Protected_Type - "current instance of protected type"
582 -- E_Task_Type - "current instance of task type"
583 -- E_Variable - "global"
585 procedure Analyze_Dependency_Clause
588 -- Verify the legality of a single dependency clause. Flag Is_Last
589 -- denotes whether Clause is the last clause in the relation.
591 procedure Check_Function_Return
;
592 -- Verify that Funtion'Result appears as one of the outputs
593 -- (SPARK RM 6.1.5(10)).
600 -- Ensure that an item fulfills its designated input and/or output role
601 -- as specified by pragma Global (if any) or the enclosing context. If
602 -- this is not the case, emit an error. Item and Item_Id denote the
603 -- attributes of an item. Flag Is_Input should be set when item comes
604 -- from an input list. Flag Self_Ref should be set when the item is an
605 -- output and the dependency clause has operator "+".
607 procedure Check_Usage
608 (Subp_Items
: Elist_Id
;
609 Used_Items
: Elist_Id
;
611 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
612 -- error if this is not the case.
614 procedure Normalize_Clause
(Clause
: Node_Id
);
615 -- Remove a self-dependency "+" from the input list of a clause
617 -----------------------------
618 -- Add_Item_To_Name_Buffer --
619 -----------------------------
621 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
623 if Ekind
(Item_Id
) = E_Abstract_State
then
624 Add_Str_To_Name_Buffer
("state");
626 elsif Ekind
(Item_Id
) = E_Constant
then
627 Add_Str_To_Name_Buffer
("constant");
629 elsif Ekind
(Item_Id
) = E_Discriminant
then
630 Add_Str_To_Name_Buffer
("discriminant");
632 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
633 E_Generic_In_Parameter
)
635 Add_Str_To_Name_Buffer
("generic parameter");
637 elsif Is_Formal
(Item_Id
) then
638 Add_Str_To_Name_Buffer
("parameter");
640 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
641 Add_Str_To_Name_Buffer
("loop parameter");
643 elsif Ekind
(Item_Id
) = E_Protected_Type
644 or else Is_Single_Protected_Object
(Item_Id
)
646 Add_Str_To_Name_Buffer
("current instance of protected type");
648 elsif Ekind
(Item_Id
) = E_Task_Type
649 or else Is_Single_Task_Object
(Item_Id
)
651 Add_Str_To_Name_Buffer
("current instance of task type");
653 elsif Ekind
(Item_Id
) = E_Variable
then
654 Add_Str_To_Name_Buffer
("global");
656 -- The routine should not be called with non-SPARK items
661 end Add_Item_To_Name_Buffer
;
663 -------------------------------
664 -- Analyze_Dependency_Clause --
665 -------------------------------
667 procedure Analyze_Dependency_Clause
671 procedure Analyze_Input_List
(Inputs
: Node_Id
);
672 -- Verify the legality of a single input list
674 procedure Analyze_Input_Output
679 Seen
: in out Elist_Id
;
680 Null_Seen
: in out Boolean;
681 Non_Null_Seen
: in out Boolean);
682 -- Verify the legality of a single input or output item. Flag
683 -- Is_Input should be set whenever Item is an input, False when it
684 -- denotes an output. Flag Self_Ref should be set when the item is an
685 -- output and the dependency clause has a "+". Flag Top_Level should
686 -- be set whenever Item appears immediately within an input or output
687 -- list. Seen is a collection of all abstract states, objects and
688 -- formals processed so far. Flag Null_Seen denotes whether a null
689 -- input or output has been encountered. Flag Non_Null_Seen denotes
690 -- whether a non-null input or output has been encountered.
692 ------------------------
693 -- Analyze_Input_List --
694 ------------------------
696 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
697 Inputs_Seen
: Elist_Id
:= No_Elist
;
698 -- A list containing the entities of all inputs that appear in the
699 -- current input list.
701 Non_Null_Input_Seen
: Boolean := False;
702 Null_Input_Seen
: Boolean := False;
703 -- Flags used to check the legality of an input list
708 -- Multiple inputs appear as an aggregate
710 if Nkind
(Inputs
) = N_Aggregate
then
711 if Present
(Component_Associations
(Inputs
)) then
713 ("nested dependency relations not allowed", Inputs
);
715 elsif Present
(Expressions
(Inputs
)) then
716 Input
:= First
(Expressions
(Inputs
));
717 while Present
(Input
) loop
724 Null_Seen
=> Null_Input_Seen
,
725 Non_Null_Seen
=> Non_Null_Input_Seen
);
730 -- Syntax error, always report
733 Error_Msg_N
("malformed input dependency list", Inputs
);
736 -- Process a solitary input
745 Null_Seen
=> Null_Input_Seen
,
746 Non_Null_Seen
=> Non_Null_Input_Seen
);
749 -- Detect an illegal dependency clause of the form
753 if Null_Output_Seen
and then Null_Input_Seen
then
755 ("null dependency clause cannot have a null input list",
758 end Analyze_Input_List
;
760 --------------------------
761 -- Analyze_Input_Output --
762 --------------------------
764 procedure Analyze_Input_Output
769 Seen
: in out Elist_Id
;
770 Null_Seen
: in out Boolean;
771 Non_Null_Seen
: in out Boolean)
773 procedure Current_Task_Instance_Seen
;
774 -- Set the appropriate global flag when the current instance of a
775 -- task unit is encountered.
777 --------------------------------
778 -- Current_Task_Instance_Seen --
779 --------------------------------
781 procedure Current_Task_Instance_Seen
is
784 Task_Input_Seen
:= True;
786 Task_Output_Seen
:= True;
788 end Current_Task_Instance_Seen
;
792 Is_Output
: constant Boolean := not Is_Input
;
796 -- Start of processing for Analyze_Input_Output
799 -- Multiple input or output items appear as an aggregate
801 if Nkind
(Item
) = N_Aggregate
then
802 if not Top_Level
then
803 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
805 elsif Present
(Component_Associations
(Item
)) then
807 ("nested dependency relations not allowed", Item
);
809 -- Recursively analyze the grouped items
811 elsif Present
(Expressions
(Item
)) then
812 Grouped
:= First
(Expressions
(Item
));
813 while Present
(Grouped
) loop
816 Is_Input
=> Is_Input
,
817 Self_Ref
=> Self_Ref
,
820 Null_Seen
=> Null_Seen
,
821 Non_Null_Seen
=> Non_Null_Seen
);
826 -- Syntax error, always report
829 Error_Msg_N
("malformed dependency list", Item
);
832 -- Process attribute 'Result in the context of a dependency clause
834 elsif Is_Attribute_Result
(Item
) then
835 Non_Null_Seen
:= True;
839 -- Attribute 'Result is allowed to appear on the output side of
840 -- a dependency clause (SPARK RM 6.1.5(6)).
843 SPARK_Msg_N
("function result cannot act as input", Item
);
847 ("cannot mix null and non-null dependency items", Item
);
853 -- Detect multiple uses of null in a single dependency list or
854 -- throughout the whole relation. Verify the placement of a null
855 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
857 elsif Nkind
(Item
) = N_Null
then
860 ("multiple null dependency relations not allowed", Item
);
862 elsif Non_Null_Seen
then
864 ("cannot mix null and non-null dependency items", Item
);
872 ("null output list must be the last clause in a "
873 & "dependency relation", Item
);
875 -- Catch a useless dependence of the form:
880 ("useless dependence, null depends on itself", Item
);
888 Non_Null_Seen
:= True;
891 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
895 Resolve_State
(Item
);
897 -- Find the entity of the item. If this is a renaming, climb
898 -- the renaming chain to reach the root object. Renamings of
899 -- non-entire objects do not yield an entity (Empty).
901 Item_Id
:= Entity_Of
(Item
);
903 if Present
(Item_Id
) then
907 if Ekind_In
(Item_Id
, E_Constant
,
912 -- Current instances of concurrent types
914 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
919 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
920 E_Generic_In_Parameter
,
928 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
930 -- The item denotes a concurrent type. Note that single
931 -- protected/task types are not considered here because
932 -- they behave as objects in the context of pragma
933 -- [Refined_]Depends.
935 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
937 -- This use is legal as long as the concurrent type is
938 -- the current instance of an enclosing type.
940 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
942 -- The dependence of a task unit on itself is
943 -- implicit and may or may not be explicitly
944 -- specified (SPARK RM 6.1.4).
946 if Ekind
(Item_Id
) = E_Task_Type
then
947 Current_Task_Instance_Seen
;
950 -- Otherwise this is not the current instance
954 ("invalid use of subtype mark in dependency "
958 -- The dependency of a task unit on itself is implicit
959 -- and may or may not be explicitly specified
962 elsif Is_Single_Task_Object
(Item_Id
)
963 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
965 Current_Task_Instance_Seen
;
968 -- Ensure that the item fulfills its role as input and/or
969 -- output as specified by pragma Global or the enclosing
972 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
974 -- Detect multiple uses of the same state, variable or
975 -- formal parameter. If this is not the case, add the
976 -- item to the list of processed relations.
978 if Contains
(Seen
, Item_Id
) then
980 ("duplicate use of item &", Item
, Item_Id
);
982 Append_New_Elmt
(Item_Id
, Seen
);
985 -- Detect illegal use of an input related to a null
986 -- output. Such input items cannot appear in other
987 -- input lists (SPARK RM 6.1.5(13)).
990 and then Null_Output_Seen
991 and then Contains
(All_Inputs_Seen
, Item_Id
)
994 ("input of a null output list cannot appear in "
995 & "multiple input lists", Item
);
998 -- Add an input or a self-referential output to the list
999 -- of all processed inputs.
1001 if Is_Input
or else Self_Ref
then
1002 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1005 -- State related checks (SPARK RM 6.1.5(3))
1007 if Ekind
(Item_Id
) = E_Abstract_State
then
1009 -- Package and subprogram bodies are instantiated
1010 -- individually in a separate compiler pass. Due to
1011 -- this mode of instantiation, the refinement of a
1012 -- state may no longer be visible when a subprogram
1013 -- body contract is instantiated. Since the generic
1014 -- template is legal, do not perform this check in
1015 -- the instance to circumvent this oddity.
1017 if Is_Generic_Instance
(Spec_Id
) then
1020 -- An abstract state with visible refinement cannot
1021 -- appear in pragma [Refined_]Depends as its place
1022 -- must be taken by some of its constituents
1023 -- (SPARK RM 6.1.4(7)).
1025 elsif Has_Visible_Refinement
(Item_Id
) then
1027 ("cannot mention state & in dependence relation",
1029 SPARK_Msg_N
("\use its constituents instead", Item
);
1032 -- If the reference to the abstract state appears in
1033 -- an enclosing package body that will eventually
1034 -- refine the state, record the reference for future
1038 Record_Possible_Body_Reference
1039 (State_Id
=> Item_Id
,
1044 -- When the item renames an entire object, replace the
1045 -- item with a reference to the object.
1047 if Entity
(Item
) /= Item_Id
then
1049 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1053 -- Add the entity of the current item to the list of
1056 if Ekind
(Item_Id
) = E_Abstract_State
then
1057 Append_New_Elmt
(Item_Id
, States_Seen
);
1059 -- The variable may eventually become a constituent of a
1060 -- single protected/task type. Record the reference now
1061 -- and verify its legality when analyzing the contract of
1062 -- the variable (SPARK RM 9.3).
1064 elsif Ekind
(Item_Id
) = E_Variable
then
1065 Record_Possible_Part_Of_Reference
1070 if Ekind_In
(Item_Id
, E_Abstract_State
,
1073 and then Present
(Encapsulating_State
(Item_Id
))
1075 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1078 -- All other input/output items are illegal
1079 -- (SPARK RM 6.1.5(1)).
1083 ("item must denote parameter, variable, state or "
1084 & "current instance of concurren type", Item
);
1087 -- All other input/output items are illegal
1088 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1092 ("item must denote parameter, variable, state or current "
1093 & "instance of concurrent type", Item
);
1096 end Analyze_Input_Output
;
1104 Non_Null_Output_Seen
: Boolean := False;
1105 -- Flag used to check the legality of an output list
1107 -- Start of processing for Analyze_Dependency_Clause
1110 Inputs
:= Expression
(Clause
);
1113 -- An input list with a self-dependency appears as operator "+" where
1114 -- the actuals inputs are the right operand.
1116 if Nkind
(Inputs
) = N_Op_Plus
then
1117 Inputs
:= Right_Opnd
(Inputs
);
1121 -- Process the output_list of a dependency_clause
1123 Output
:= First
(Choices
(Clause
));
1124 while Present
(Output
) loop
1125 Analyze_Input_Output
1128 Self_Ref
=> Self_Ref
,
1130 Seen
=> All_Outputs_Seen
,
1131 Null_Seen
=> Null_Output_Seen
,
1132 Non_Null_Seen
=> Non_Null_Output_Seen
);
1137 -- Process the input_list of a dependency_clause
1139 Analyze_Input_List
(Inputs
);
1140 end Analyze_Dependency_Clause
;
1142 ---------------------------
1143 -- Check_Function_Return --
1144 ---------------------------
1146 procedure Check_Function_Return
is
1148 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1149 and then not Result_Seen
1152 ("result of & must appear in exactly one output list",
1155 end Check_Function_Return
;
1161 procedure Check_Role
1163 Item_Id
: Entity_Id
;
1168 (Item_Is_Input
: out Boolean;
1169 Item_Is_Output
: out Boolean);
1170 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1171 -- Item_Is_Output are set depending on the role.
1173 procedure Role_Error
1174 (Item_Is_Input
: Boolean;
1175 Item_Is_Output
: Boolean);
1176 -- Emit an error message concerning the incorrect use of Item in
1177 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1178 -- denote whether the item is an input and/or an output.
1185 (Item_Is_Input
: out Boolean;
1186 Item_Is_Output
: out Boolean)
1189 Item_Is_Input
:= False;
1190 Item_Is_Output
:= False;
1194 if Ekind
(Item_Id
) = E_Abstract_State
then
1196 -- When pragma Global is present, the mode of the state may be
1197 -- further constrained by setting a more restrictive mode.
1200 if Appears_In
(Subp_Inputs
, Item_Id
) then
1201 Item_Is_Input
:= True;
1204 if Appears_In
(Subp_Outputs
, Item_Id
) then
1205 Item_Is_Output
:= True;
1208 -- Otherwise the state has a default IN OUT mode
1211 Item_Is_Input
:= True;
1212 Item_Is_Output
:= True;
1217 elsif Ekind_In
(Item_Id
, E_Constant
,
1221 Item_Is_Input
:= True;
1225 elsif Ekind_In
(Item_Id
, E_Generic_In_Parameter
,
1228 Item_Is_Input
:= True;
1230 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
1233 Item_Is_Input
:= True;
1234 Item_Is_Output
:= True;
1236 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1237 if Scope
(Item_Id
) = Spec_Id
then
1239 -- An OUT parameter of the related subprogram has mode IN
1240 -- if its type is unconstrained or tagged because array
1241 -- bounds, discriminants or tags can be read.
1243 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1244 Item_Is_Input
:= True;
1247 Item_Is_Output
:= True;
1249 -- An OUT parameter of an enclosing subprogram behaves as a
1250 -- read-write variable in which case the mode is IN OUT.
1253 Item_Is_Input
:= True;
1254 Item_Is_Output
:= True;
1259 elsif Ekind
(Item_Id
) = E_Protected_Type
then
1261 -- A protected type acts as a formal parameter of mode IN when
1262 -- it applies to a protected function.
1264 if Ekind
(Spec_Id
) = E_Function
then
1265 Item_Is_Input
:= True;
1267 -- Otherwise the protected type acts as a formal of mode IN OUT
1270 Item_Is_Input
:= True;
1271 Item_Is_Output
:= True;
1276 elsif Ekind
(Item_Id
) = E_Task_Type
then
1277 Item_Is_Input
:= True;
1278 Item_Is_Output
:= True;
1282 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1284 -- When pragma Global is present, the mode of the variable may
1285 -- be further constrained by setting a more restrictive mode.
1289 -- A variable has mode IN when its type is unconstrained or
1290 -- tagged because array bounds, discriminants or tags can be
1293 if Appears_In
(Subp_Inputs
, Item_Id
)
1294 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1296 Item_Is_Input
:= True;
1299 if Appears_In
(Subp_Outputs
, Item_Id
) then
1300 Item_Is_Output
:= True;
1303 -- Otherwise the variable has a default IN OUT mode
1306 Item_Is_Input
:= True;
1307 Item_Is_Output
:= True;
1316 procedure Role_Error
1317 (Item_Is_Input
: Boolean;
1318 Item_Is_Output
: Boolean)
1320 Error_Msg
: Name_Id
;
1325 -- When the item is not part of the input and the output set of
1326 -- the related subprogram, then it appears as extra in pragma
1327 -- [Refined_]Depends.
1329 if not Item_Is_Input
and then not Item_Is_Output
then
1330 Add_Item_To_Name_Buffer
(Item_Id
);
1331 Add_Str_To_Name_Buffer
1332 (" & cannot appear in dependence relation");
1334 Error_Msg
:= Name_Find
;
1335 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1337 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1339 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1340 & "set of subprogram %"), Item
, Item_Id
);
1342 -- The mode of the item and its role in pragma [Refined_]Depends
1343 -- are in conflict. Construct a detailed message explaining the
1344 -- illegality (SPARK RM 6.1.5(5-6)).
1347 if Item_Is_Input
then
1348 Add_Str_To_Name_Buffer
("read-only");
1350 Add_Str_To_Name_Buffer
("write-only");
1353 Add_Char_To_Name_Buffer
(' ');
1354 Add_Item_To_Name_Buffer
(Item_Id
);
1355 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1357 if Item_Is_Input
then
1358 Add_Str_To_Name_Buffer
("output");
1360 Add_Str_To_Name_Buffer
("input");
1363 Add_Str_To_Name_Buffer
(" in dependence relation");
1364 Error_Msg
:= Name_Find
;
1365 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1371 Item_Is_Input
: Boolean;
1372 Item_Is_Output
: Boolean;
1374 -- Start of processing for Check_Role
1377 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1382 if not Item_Is_Input
then
1383 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1386 -- Self-referential item
1389 if not Item_Is_Input
or else not Item_Is_Output
then
1390 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1395 elsif not Item_Is_Output
then
1396 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1404 procedure Check_Usage
1405 (Subp_Items
: Elist_Id
;
1406 Used_Items
: Elist_Id
;
1409 procedure Usage_Error
(Item_Id
: Entity_Id
);
1410 -- Emit an error concerning the illegal usage of an item
1416 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1417 Error_Msg
: Name_Id
;
1424 -- Unconstrained and tagged items are not part of the explicit
1425 -- input set of the related subprogram, they do not have to be
1426 -- present in a dependence relation and should not be flagged
1427 -- (SPARK RM 6.1.5(8)).
1429 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1432 Add_Item_To_Name_Buffer
(Item_Id
);
1433 Add_Str_To_Name_Buffer
1434 (" & is missing from input dependence list");
1436 Error_Msg
:= Name_Find
;
1437 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1440 -- Output case (SPARK RM 6.1.5(10))
1445 Add_Item_To_Name_Buffer
(Item_Id
);
1446 Add_Str_To_Name_Buffer
1447 (" & is missing from output dependence list");
1449 Error_Msg
:= Name_Find
;
1450 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1458 Item_Id
: Entity_Id
;
1460 -- Start of processing for Check_Usage
1463 if No
(Subp_Items
) then
1467 -- Each input or output of the subprogram must appear in a dependency
1470 Elmt
:= First_Elmt
(Subp_Items
);
1471 while Present
(Elmt
) loop
1472 Item
:= Node
(Elmt
);
1474 if Nkind
(Item
) = N_Defining_Identifier
then
1477 Item_Id
:= Entity_Of
(Item
);
1480 -- The item does not appear in a dependency
1482 if Present
(Item_Id
)
1483 and then not Contains
(Used_Items
, Item_Id
)
1485 if Is_Formal
(Item_Id
) then
1486 Usage_Error
(Item_Id
);
1488 -- The current instance of a protected type behaves as a formal
1489 -- parameter (SPARK RM 6.1.4).
1491 elsif Ekind
(Item_Id
) = E_Protected_Type
1492 or else Is_Single_Protected_Object
(Item_Id
)
1494 Usage_Error
(Item_Id
);
1496 -- The current instance of a task type behaves as a formal
1497 -- parameter (SPARK RM 6.1.4).
1499 elsif Ekind
(Item_Id
) = E_Task_Type
1500 or else Is_Single_Task_Object
(Item_Id
)
1502 -- The dependence of a task unit on itself is implicit and
1503 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1504 -- Emit an error if only one input/output is present.
1506 if Task_Input_Seen
/= Task_Output_Seen
then
1507 Usage_Error
(Item_Id
);
1510 -- States and global objects are not used properly only when
1511 -- the subprogram is subject to pragma Global.
1513 elsif Global_Seen
then
1514 Usage_Error
(Item_Id
);
1522 ----------------------
1523 -- Normalize_Clause --
1524 ----------------------
1526 procedure Normalize_Clause
(Clause
: Node_Id
) is
1527 procedure Create_Or_Modify_Clause
1533 Multiple
: Boolean);
1534 -- Create a brand new clause to represent the self-reference or
1535 -- modify the input and/or output lists of an existing clause. Output
1536 -- denotes a self-referencial output. Outputs is the output list of a
1537 -- clause. Inputs is the input list of a clause. After denotes the
1538 -- clause after which the new clause is to be inserted. Flag In_Place
1539 -- should be set when normalizing the last output of an output list.
1540 -- Flag Multiple should be set when Output comes from a list with
1543 -----------------------------
1544 -- Create_Or_Modify_Clause --
1545 -----------------------------
1547 procedure Create_Or_Modify_Clause
1555 procedure Propagate_Output
1558 -- Handle the various cases of output propagation to the input
1559 -- list. Output denotes a self-referencial output item. Inputs
1560 -- is the input list of a clause.
1562 ----------------------
1563 -- Propagate_Output --
1564 ----------------------
1566 procedure Propagate_Output
1570 function In_Input_List
1572 Inputs
: List_Id
) return Boolean;
1573 -- Determine whether a particulat item appears in the input
1574 -- list of a clause.
1580 function In_Input_List
1582 Inputs
: List_Id
) return Boolean
1587 Elmt
:= First
(Inputs
);
1588 while Present
(Elmt
) loop
1589 if Entity_Of
(Elmt
) = Item
then
1601 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1604 -- Start of processing for Propagate_Output
1607 -- The clause is of the form:
1609 -- (Output =>+ null)
1611 -- Remove null input and replace it with a copy of the output:
1613 -- (Output => Output)
1615 if Nkind
(Inputs
) = N_Null
then
1616 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1618 -- The clause is of the form:
1620 -- (Output =>+ (Input1, ..., InputN))
1622 -- Determine whether the output is not already mentioned in the
1623 -- input list and if not, add it to the list of inputs:
1625 -- (Output => (Output, Input1, ..., InputN))
1627 elsif Nkind
(Inputs
) = N_Aggregate
then
1628 Grouped
:= Expressions
(Inputs
);
1630 if not In_Input_List
1634 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1637 -- The clause is of the form:
1639 -- (Output =>+ Input)
1641 -- If the input does not mention the output, group the two
1644 -- (Output => (Output, Input))
1646 elsif Entity_Of
(Inputs
) /= Output_Id
then
1648 Make_Aggregate
(Loc
,
1649 Expressions
=> New_List
(
1650 New_Copy_Tree
(Output
),
1651 New_Copy_Tree
(Inputs
))));
1653 end Propagate_Output
;
1657 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1658 New_Clause
: Node_Id
;
1660 -- Start of processing for Create_Or_Modify_Clause
1663 -- A null output depending on itself does not require any
1666 if Nkind
(Output
) = N_Null
then
1669 -- A function result cannot depend on itself because it cannot
1670 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1672 elsif Is_Attribute_Result
(Output
) then
1673 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1677 -- When performing the transformation in place, simply add the
1678 -- output to the list of inputs (if not already there). This
1679 -- case arises when dealing with the last output of an output
1680 -- list. Perform the normalization in place to avoid generating
1681 -- a malformed tree.
1684 Propagate_Output
(Output
, Inputs
);
1686 -- A list with multiple outputs is slowly trimmed until only
1687 -- one element remains. When this happens, replace aggregate
1688 -- with the element itself.
1692 Rewrite
(Outputs
, Output
);
1698 -- Unchain the output from its output list as it will appear in
1699 -- a new clause. Note that we cannot simply rewrite the output
1700 -- as null because this will violate the semantics of pragma
1705 -- Generate a new clause of the form:
1706 -- (Output => Inputs)
1709 Make_Component_Association
(Loc
,
1710 Choices
=> New_List
(Output
),
1711 Expression
=> New_Copy_Tree
(Inputs
));
1713 -- The new clause contains replicated content that has already
1714 -- been analyzed. There is not need to reanalyze or renormalize
1717 Set_Analyzed
(New_Clause
);
1720 (Output
=> First
(Choices
(New_Clause
)),
1721 Inputs
=> Expression
(New_Clause
));
1723 Insert_After
(After
, New_Clause
);
1725 end Create_Or_Modify_Clause
;
1729 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1731 Last_Output
: Node_Id
;
1732 Next_Output
: Node_Id
;
1735 -- Start of processing for Normalize_Clause
1738 -- A self-dependency appears as operator "+". Remove the "+" from the
1739 -- tree by moving the real inputs to their proper place.
1741 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1742 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1743 Inputs
:= Expression
(Clause
);
1745 -- Multiple outputs appear as an aggregate
1747 if Nkind
(Outputs
) = N_Aggregate
then
1748 Last_Output
:= Last
(Expressions
(Outputs
));
1750 Output
:= First
(Expressions
(Outputs
));
1751 while Present
(Output
) loop
1753 -- Normalization may remove an output from its list,
1754 -- preserve the subsequent output now.
1756 Next_Output
:= Next
(Output
);
1758 Create_Or_Modify_Clause
1763 In_Place
=> Output
= Last_Output
,
1766 Output
:= Next_Output
;
1772 Create_Or_Modify_Clause
1781 end Normalize_Clause
;
1785 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1786 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1790 Last_Clause
: Node_Id
;
1791 Restore_Scope
: Boolean := False;
1793 -- Start of processing for Analyze_Depends_In_Decl_Part
1796 -- Do not analyze the pragma multiple times
1798 if Is_Analyzed_Pragma
(N
) then
1802 -- Empty dependency list
1804 if Nkind
(Deps
) = N_Null
then
1806 -- Gather all states, objects and formal parameters that the
1807 -- subprogram may depend on. These items are obtained from the
1808 -- parameter profile or pragma [Refined_]Global (if available).
1810 Collect_Subprogram_Inputs_Outputs
1811 (Subp_Id
=> Subp_Id
,
1812 Subp_Inputs
=> Subp_Inputs
,
1813 Subp_Outputs
=> Subp_Outputs
,
1814 Global_Seen
=> Global_Seen
);
1816 -- Verify that every input or output of the subprogram appear in a
1819 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1820 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1821 Check_Function_Return
;
1823 -- Dependency clauses appear as component associations of an aggregate
1825 elsif Nkind
(Deps
) = N_Aggregate
then
1827 -- Do not attempt to perform analysis of a syntactically illegal
1828 -- clause as this will lead to misleading errors.
1830 if Has_Extra_Parentheses
(Deps
) then
1834 if Present
(Component_Associations
(Deps
)) then
1835 Last_Clause
:= Last
(Component_Associations
(Deps
));
1837 -- Gather all states, objects and formal parameters that the
1838 -- subprogram may depend on. These items are obtained from the
1839 -- parameter profile or pragma [Refined_]Global (if available).
1841 Collect_Subprogram_Inputs_Outputs
1842 (Subp_Id
=> Subp_Id
,
1843 Subp_Inputs
=> Subp_Inputs
,
1844 Subp_Outputs
=> Subp_Outputs
,
1845 Global_Seen
=> Global_Seen
);
1847 -- When pragma [Refined_]Depends appears on a single concurrent
1848 -- type, it is relocated to the anonymous object.
1850 if Is_Single_Concurrent_Object
(Spec_Id
) then
1853 -- Ensure that the formal parameters are visible when analyzing
1854 -- all clauses. This falls out of the general rule of aspects
1855 -- pertaining to subprogram declarations.
1857 elsif not In_Open_Scopes
(Spec_Id
) then
1858 Restore_Scope
:= True;
1859 Push_Scope
(Spec_Id
);
1861 if Ekind
(Spec_Id
) = E_Task_Type
then
1862 if Has_Discriminants
(Spec_Id
) then
1863 Install_Discriminants
(Spec_Id
);
1866 elsif Is_Generic_Subprogram
(Spec_Id
) then
1867 Install_Generic_Formals
(Spec_Id
);
1870 Install_Formals
(Spec_Id
);
1874 Clause
:= First
(Component_Associations
(Deps
));
1875 while Present
(Clause
) loop
1876 Errors
:= Serious_Errors_Detected
;
1878 -- The normalization mechanism may create extra clauses that
1879 -- contain replicated input and output names. There is no need
1880 -- to reanalyze them.
1882 if not Analyzed
(Clause
) then
1883 Set_Analyzed
(Clause
);
1885 Analyze_Dependency_Clause
1887 Is_Last
=> Clause
= Last_Clause
);
1890 -- Do not normalize a clause if errors were detected (count
1891 -- of Serious_Errors has increased) because the inputs and/or
1892 -- outputs may denote illegal items. Normalization is disabled
1893 -- in ASIS mode as it alters the tree by introducing new nodes
1894 -- similar to expansion.
1896 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1897 Normalize_Clause
(Clause
);
1903 if Restore_Scope
then
1907 -- Verify that every input or output of the subprogram appear in a
1910 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1911 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1912 Check_Function_Return
;
1914 -- The dependency list is malformed. This is a syntax error, always
1918 Error_Msg_N
("malformed dependency relation", Deps
);
1922 -- The top level dependency relation is malformed. This is a syntax
1923 -- error, always report.
1926 Error_Msg_N
("malformed dependency relation", Deps
);
1930 -- Ensure that a state and a corresponding constituent do not appear
1931 -- together in pragma [Refined_]Depends.
1933 Check_State_And_Constituent_Use
1934 (States
=> States_Seen
,
1935 Constits
=> Constits_Seen
,
1939 Set_Is_Analyzed_Pragma
(N
);
1940 end Analyze_Depends_In_Decl_Part
;
1942 --------------------------------------------
1943 -- Analyze_External_Property_In_Decl_Part --
1944 --------------------------------------------
1946 procedure Analyze_External_Property_In_Decl_Part
1948 Expr_Val
: out Boolean)
1950 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1951 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
1952 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
1958 -- Do not analyze the pragma multiple times
1960 if Is_Analyzed_Pragma
(N
) then
1964 Error_Msg_Name_1
:= Pragma_Name
(N
);
1966 -- An external property pragma must apply to an effectively volatile
1967 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1968 -- The check is performed at the end of the declarative region due to a
1969 -- possible out-of-order arrangement of pragmas:
1972 -- pragma Async_Readers (Obj);
1973 -- pragma Volatile (Obj);
1975 if not Is_Effectively_Volatile
(Obj_Id
) then
1977 ("external property % must apply to a volatile object", N
);
1980 -- Ensure that the Boolean expression (if present) is static. A missing
1981 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
1985 if Present
(Arg1
) then
1986 Expr
:= Get_Pragma_Arg
(Arg1
);
1988 if Is_OK_Static_Expression
(Expr
) then
1989 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
1993 Set_Is_Analyzed_Pragma
(N
);
1994 end Analyze_External_Property_In_Decl_Part
;
1996 ---------------------------------
1997 -- Analyze_Global_In_Decl_Part --
1998 ---------------------------------
2000 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2001 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2002 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2003 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2005 Constits_Seen
: Elist_Id
:= No_Elist
;
2006 -- A list containing the entities of all constituents processed so far.
2007 -- It aids in detecting illegal usage of a state and a corresponding
2008 -- constituent in pragma [Refinde_]Global.
2010 Seen
: Elist_Id
:= No_Elist
;
2011 -- A list containing the entities of all the items processed so far. It
2012 -- plays a role in detecting distinct entities.
2014 States_Seen
: Elist_Id
:= No_Elist
;
2015 -- A list containing the entities of all states processed so far. It
2016 -- helps in detecting illegal usage of a state and a corresponding
2017 -- constituent in pragma [Refined_]Global.
2019 In_Out_Seen
: Boolean := False;
2020 Input_Seen
: Boolean := False;
2021 Output_Seen
: Boolean := False;
2022 Proof_Seen
: Boolean := False;
2023 -- Flags used to verify the consistency of modes
2025 procedure Analyze_Global_List
2027 Global_Mode
: Name_Id
:= Name_Input
);
2028 -- Verify the legality of a single global list declaration. Global_Mode
2029 -- denotes the current mode in effect.
2031 -------------------------
2032 -- Analyze_Global_List --
2033 -------------------------
2035 procedure Analyze_Global_List
2037 Global_Mode
: Name_Id
:= Name_Input
)
2039 procedure Analyze_Global_Item
2041 Global_Mode
: Name_Id
);
2042 -- Verify the legality of a single global item declaration denoted by
2043 -- Item. Global_Mode denotes the current mode in effect.
2045 procedure Check_Duplicate_Mode
2047 Status
: in out Boolean);
2048 -- Flag Status denotes whether a particular mode has been seen while
2049 -- processing a global list. This routine verifies that Mode is not a
2050 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2052 procedure Check_Mode_Restriction_In_Enclosing_Context
2054 Item_Id
: Entity_Id
);
2055 -- Verify that an item of mode In_Out or Output does not appear as an
2056 -- input in the Global aspect of an enclosing subprogram. If this is
2057 -- the case, emit an error. Item and Item_Id are respectively the
2058 -- item and its entity.
2060 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2061 -- Mode denotes either In_Out or Output. Depending on the kind of the
2062 -- related subprogram, emit an error if those two modes apply to a
2063 -- function (SPARK RM 6.1.4(10)).
2065 -------------------------
2066 -- Analyze_Global_Item --
2067 -------------------------
2069 procedure Analyze_Global_Item
2071 Global_Mode
: Name_Id
)
2073 Item_Id
: Entity_Id
;
2076 -- Detect one of the following cases
2078 -- with Global => (null, Name)
2079 -- with Global => (Name_1, null, Name_2)
2080 -- with Global => (Name, null)
2082 if Nkind
(Item
) = N_Null
then
2083 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2088 Resolve_State
(Item
);
2090 -- Find the entity of the item. If this is a renaming, climb the
2091 -- renaming chain to reach the root object. Renamings of non-
2092 -- entire objects do not yield an entity (Empty).
2094 Item_Id
:= Entity_Of
(Item
);
2096 if Present
(Item_Id
) then
2098 -- A global item may denote a formal parameter of an enclosing
2099 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2100 -- provide a better error diagnostic.
2102 if Is_Formal
(Item_Id
) then
2103 if Scope
(Item_Id
) = Spec_Id
then
2105 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2106 & "parameter of subprogram &"), Item
, Spec_Id
);
2110 -- A global item may denote a concurrent type as long as it is
2111 -- the current instance of an enclosing protected or task type
2112 -- (SPARK RM 6.1.4).
2114 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2115 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2117 -- Pragma [Refined_]Global associated with a protected
2118 -- subprogram cannot mention the current instance of a
2119 -- protected type because the instance behaves as a
2120 -- formal parameter.
2122 if Ekind
(Item_Id
) = E_Protected_Type
then
2123 Error_Msg_Name_1
:= Chars
(Item_Id
);
2125 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2126 & "cannot reference current instance of protected "
2127 & "type %"), Item
, Spec_Id
);
2130 -- Pragma [Refined_]Global associated with a task type
2131 -- cannot mention the current instance of a task type
2132 -- because the instance behaves as a formal parameter.
2134 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2135 Error_Msg_Name_1
:= Chars
(Item_Id
);
2137 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2138 & "cannot reference current instance of task type "
2139 & "%"), Item
, Spec_Id
);
2143 -- Otherwise the global item denotes a subtype mark that is
2144 -- not a current instance.
2148 ("invalid use of subtype mark in global list", Item
);
2152 -- A global item may denote the anonymous object created for a
2153 -- single protected/task type as long as the current instance
2154 -- is the same single type (SPARK RM 6.1.4).
2156 elsif Is_Single_Concurrent_Object
(Item_Id
)
2157 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
2159 -- Pragma [Refined_]Global associated with a protected
2160 -- subprogram cannot mention the current instance of a
2161 -- protected type because the instance behaves as a formal
2164 if Is_Single_Protected_Object
(Item_Id
) then
2165 Error_Msg_Name_1
:= Chars
(Item_Id
);
2167 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2168 & "reference current instance of protected type %"),
2172 -- Pragma [Refined_]Global associated with a task type
2173 -- cannot mention the current instance of a task type
2174 -- because the instance behaves as a formal parameter.
2176 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2177 Error_Msg_Name_1
:= Chars
(Item_Id
);
2179 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2180 & "reference current instance of task type %"),
2185 -- A formal object may act as a global item inside a generic
2187 elsif Is_Formal_Object
(Item_Id
) then
2190 -- The only legal references are those to abstract states,
2191 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2193 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2200 ("global item must denote object, state or current "
2201 & "instance of concurrent type", Item
);
2205 -- State related checks
2207 if Ekind
(Item_Id
) = E_Abstract_State
then
2209 -- Package and subprogram bodies are instantiated
2210 -- individually in a separate compiler pass. Due to this
2211 -- mode of instantiation, the refinement of a state may
2212 -- no longer be visible when a subprogram body contract
2213 -- is instantiated. Since the generic template is legal,
2214 -- do not perform this check in the instance to circumvent
2217 if Is_Generic_Instance
(Spec_Id
) then
2220 -- An abstract state with visible refinement cannot appear
2221 -- in pragma [Refined_]Global as its place must be taken by
2222 -- some of its constituents (SPARK RM 6.1.4(7)).
2224 elsif Has_Visible_Refinement
(Item_Id
) then
2226 ("cannot mention state & in global refinement",
2228 SPARK_Msg_N
("\use its constituents instead", Item
);
2231 -- An external state cannot appear as a global item of a
2232 -- nonvolatile function (SPARK RM 7.1.3(8)).
2234 elsif Is_External_State
(Item_Id
)
2235 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2236 and then not Is_Volatile_Function
(Spec_Id
)
2239 ("external state & cannot act as global item of "
2240 & "nonvolatile function", Item
, Item_Id
);
2243 -- If the reference to the abstract state appears in an
2244 -- enclosing package body that will eventually refine the
2245 -- state, record the reference for future checks.
2248 Record_Possible_Body_Reference
2249 (State_Id
=> Item_Id
,
2253 -- Constant related checks
2255 elsif Ekind
(Item_Id
) = E_Constant
then
2257 -- A constant is a read-only item, therefore it cannot act
2260 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2262 ("constant & cannot act as output", Item
, Item_Id
);
2266 -- Discriminant related checks
2268 elsif Ekind
(Item_Id
) = E_Discriminant
then
2270 -- A discriminant is a read-only item, therefore it cannot
2271 -- act as an output.
2273 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2275 ("discriminant & cannot act as output", Item
, Item_Id
);
2279 -- Loop parameter related checks
2281 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2283 -- A loop parameter is a read-only item, therefore it cannot
2284 -- act as an output.
2286 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2288 ("loop parameter & cannot act as output",
2293 -- Variable related checks. These are only relevant when
2294 -- SPARK_Mode is on as they are not standard Ada legality
2297 elsif SPARK_Mode
= On
2298 and then Ekind
(Item_Id
) = E_Variable
2299 and then Is_Effectively_Volatile
(Item_Id
)
2301 -- An effectively volatile object cannot appear as a global
2302 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2304 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2305 and then not Is_Volatile_Function
(Spec_Id
)
2308 ("volatile object & cannot act as global item of a "
2309 & "function", Item
, Item_Id
);
2312 -- An effectively volatile object with external property
2313 -- Effective_Reads set to True must have mode Output or
2314 -- In_Out (SPARK RM 7.1.3(10)).
2316 elsif Effective_Reads_Enabled
(Item_Id
)
2317 and then Global_Mode
= Name_Input
2320 ("volatile object & with property Effective_Reads must "
2321 & "have mode In_Out or Output", Item
, Item_Id
);
2326 -- When the item renames an entire object, replace the item
2327 -- with a reference to the object.
2329 if Entity
(Item
) /= Item_Id
then
2330 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2334 -- Some form of illegal construct masquerading as a name
2335 -- (SPARK RM 6.1.4(4)).
2339 ("global item must denote object, state or current instance "
2340 & "of concurrent type", Item
);
2344 -- Verify that an output does not appear as an input in an
2345 -- enclosing subprogram.
2347 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2348 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2351 -- The same entity might be referenced through various way.
2352 -- Check the entity of the item rather than the item itself
2353 -- (SPARK RM 6.1.4(10)).
2355 if Contains
(Seen
, Item_Id
) then
2356 SPARK_Msg_N
("duplicate global item", Item
);
2358 -- Add the entity of the current item to the list of processed
2362 Append_New_Elmt
(Item_Id
, Seen
);
2364 if Ekind
(Item_Id
) = E_Abstract_State
then
2365 Append_New_Elmt
(Item_Id
, States_Seen
);
2367 -- The variable may eventually become a constituent of a single
2368 -- protected/task type. Record the reference now and verify its
2369 -- legality when analyzing the contract of the variable
2372 elsif Ekind
(Item_Id
) = E_Variable
then
2373 Record_Possible_Part_Of_Reference
2378 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2379 and then Present
(Encapsulating_State
(Item_Id
))
2381 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2384 end Analyze_Global_Item
;
2386 --------------------------
2387 -- Check_Duplicate_Mode --
2388 --------------------------
2390 procedure Check_Duplicate_Mode
2392 Status
: in out Boolean)
2396 SPARK_Msg_N
("duplicate global mode", Mode
);
2400 end Check_Duplicate_Mode
;
2402 -------------------------------------------------
2403 -- Check_Mode_Restriction_In_Enclosing_Context --
2404 -------------------------------------------------
2406 procedure Check_Mode_Restriction_In_Enclosing_Context
2408 Item_Id
: Entity_Id
)
2410 Context
: Entity_Id
;
2412 Inputs
: Elist_Id
:= No_Elist
;
2413 Outputs
: Elist_Id
:= No_Elist
;
2416 -- Traverse the scope stack looking for enclosing subprograms
2417 -- subject to pragma [Refined_]Global.
2419 Context
:= Scope
(Subp_Id
);
2420 while Present
(Context
) and then Context
/= Standard_Standard
loop
2421 if Is_Subprogram
(Context
)
2423 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2425 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2427 Collect_Subprogram_Inputs_Outputs
2428 (Subp_Id
=> Context
,
2429 Subp_Inputs
=> Inputs
,
2430 Subp_Outputs
=> Outputs
,
2431 Global_Seen
=> Dummy
);
2433 -- The item is classified as In_Out or Output but appears as
2434 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2436 if Appears_In
(Inputs
, Item_Id
)
2437 and then not Appears_In
(Outputs
, Item_Id
)
2440 ("global item & cannot have mode In_Out or Output",
2444 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2445 & "subprogram &"), Item
, Context
);
2447 -- Stop the traversal once an error has been detected
2453 Context
:= Scope
(Context
);
2455 end Check_Mode_Restriction_In_Enclosing_Context
;
2457 ----------------------------------------
2458 -- Check_Mode_Restriction_In_Function --
2459 ----------------------------------------
2461 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2463 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2465 ("global mode & is not applicable to functions", Mode
);
2467 end Check_Mode_Restriction_In_Function
;
2475 -- Start of processing for Analyze_Global_List
2478 if Nkind
(List
) = N_Null
then
2479 Set_Analyzed
(List
);
2481 -- Single global item declaration
2483 elsif Nkind_In
(List
, N_Expanded_Name
,
2485 N_Selected_Component
)
2487 Analyze_Global_Item
(List
, Global_Mode
);
2489 -- Simple global list or moded global list declaration
2491 elsif Nkind
(List
) = N_Aggregate
then
2492 Set_Analyzed
(List
);
2494 -- The declaration of a simple global list appear as a collection
2497 if Present
(Expressions
(List
)) then
2498 if Present
(Component_Associations
(List
)) then
2500 ("cannot mix moded and non-moded global lists", List
);
2503 Item
:= First
(Expressions
(List
));
2504 while Present
(Item
) loop
2505 Analyze_Global_Item
(Item
, Global_Mode
);
2509 -- The declaration of a moded global list appears as a collection
2510 -- of component associations where individual choices denote
2513 elsif Present
(Component_Associations
(List
)) then
2514 if Present
(Expressions
(List
)) then
2516 ("cannot mix moded and non-moded global lists", List
);
2519 Assoc
:= First
(Component_Associations
(List
));
2520 while Present
(Assoc
) loop
2521 Mode
:= First
(Choices
(Assoc
));
2523 if Nkind
(Mode
) = N_Identifier
then
2524 if Chars
(Mode
) = Name_In_Out
then
2525 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2526 Check_Mode_Restriction_In_Function
(Mode
);
2528 elsif Chars
(Mode
) = Name_Input
then
2529 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2531 elsif Chars
(Mode
) = Name_Output
then
2532 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2533 Check_Mode_Restriction_In_Function
(Mode
);
2535 elsif Chars
(Mode
) = Name_Proof_In
then
2536 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2539 SPARK_Msg_N
("invalid mode selector", Mode
);
2543 SPARK_Msg_N
("invalid mode selector", Mode
);
2546 -- Items in a moded list appear as a collection of
2547 -- expressions. Reuse the existing machinery to analyze
2551 (List
=> Expression
(Assoc
),
2552 Global_Mode
=> Chars
(Mode
));
2560 raise Program_Error
;
2563 -- Any other attempt to declare a global item is illegal. This is a
2564 -- syntax error, always report.
2567 Error_Msg_N
("malformed global list", List
);
2569 end Analyze_Global_List
;
2573 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2575 Restore_Scope
: Boolean := False;
2577 -- Start of processing for Analyze_Global_In_Decl_Part
2580 -- Do not analyze the pragma multiple times
2582 if Is_Analyzed_Pragma
(N
) then
2586 -- There is nothing to be done for a null global list
2588 if Nkind
(Items
) = N_Null
then
2589 Set_Analyzed
(Items
);
2591 -- Analyze the various forms of global lists and items. Note that some
2592 -- of these may be malformed in which case the analysis emits error
2596 -- When pragma [Refined_]Global appears on a single concurrent type,
2597 -- it is relocated to the anonymous object.
2599 if Is_Single_Concurrent_Object
(Spec_Id
) then
2602 -- Ensure that the formal parameters are visible when processing an
2603 -- item. This falls out of the general rule of aspects pertaining to
2604 -- subprogram declarations.
2606 elsif not In_Open_Scopes
(Spec_Id
) then
2607 Restore_Scope
:= True;
2608 Push_Scope
(Spec_Id
);
2610 if Ekind
(Spec_Id
) = E_Task_Type
then
2611 if Has_Discriminants
(Spec_Id
) then
2612 Install_Discriminants
(Spec_Id
);
2615 elsif Is_Generic_Subprogram
(Spec_Id
) then
2616 Install_Generic_Formals
(Spec_Id
);
2619 Install_Formals
(Spec_Id
);
2623 Analyze_Global_List
(Items
);
2625 if Restore_Scope
then
2630 -- Ensure that a state and a corresponding constituent do not appear
2631 -- together in pragma [Refined_]Global.
2633 Check_State_And_Constituent_Use
2634 (States
=> States_Seen
,
2635 Constits
=> Constits_Seen
,
2638 Set_Is_Analyzed_Pragma
(N
);
2639 end Analyze_Global_In_Decl_Part
;
2641 --------------------------------------------
2642 -- Analyze_Initial_Condition_In_Decl_Part --
2643 --------------------------------------------
2645 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2646 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2647 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2648 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2650 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2653 -- Do not analyze the pragma multiple times
2655 if Is_Analyzed_Pragma
(N
) then
2659 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2660 -- analysis of the pragma, the Ghost mode at point of declaration and
2661 -- point of analysis may not necessarely be the same. Use the mode in
2662 -- effect at the point of declaration.
2666 -- The expression is preanalyzed because it has not been moved to its
2667 -- final place yet. A direct analysis may generate side effects and this
2668 -- is not desired at this point.
2670 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2671 Ghost_Mode
:= Save_Ghost_Mode
;
2673 Set_Is_Analyzed_Pragma
(N
);
2674 end Analyze_Initial_Condition_In_Decl_Part
;
2676 --------------------------------------
2677 -- Analyze_Initializes_In_Decl_Part --
2678 --------------------------------------
2680 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2681 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2682 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2684 Constits_Seen
: Elist_Id
:= No_Elist
;
2685 -- A list containing the entities of all constituents processed so far.
2686 -- It aids in detecting illegal usage of a state and a corresponding
2687 -- constituent in pragma Initializes.
2689 Items_Seen
: Elist_Id
:= No_Elist
;
2690 -- A list of all initialization items processed so far. This list is
2691 -- used to detect duplicate items.
2693 Non_Null_Seen
: Boolean := False;
2694 Null_Seen
: Boolean := False;
2695 -- Flags used to check the legality of a null initialization list
2697 States_And_Objs
: Elist_Id
:= No_Elist
;
2698 -- A list of all abstract states and objects declared in the visible
2699 -- declarations of the related package. This list is used to detect the
2700 -- legality of initialization items.
2702 States_Seen
: Elist_Id
:= No_Elist
;
2703 -- A list containing the entities of all states processed so far. It
2704 -- helps in detecting illegal usage of a state and a corresponding
2705 -- constituent in pragma Initializes.
2707 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2708 -- Verify the legality of a single initialization item
2710 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2711 -- Verify the legality of a single initialization item followed by a
2712 -- list of input items.
2714 procedure Collect_States_And_Objects
;
2715 -- Inspect the visible declarations of the related package and gather
2716 -- the entities of all abstract states and objects in States_And_Objs.
2718 ---------------------------------
2719 -- Analyze_Initialization_Item --
2720 ---------------------------------
2722 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2723 Item_Id
: Entity_Id
;
2726 -- Null initialization list
2728 if Nkind
(Item
) = N_Null
then
2730 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2732 elsif Non_Null_Seen
then
2734 ("cannot mix null and non-null initialization items", Item
);
2739 -- Initialization item
2742 Non_Null_Seen
:= True;
2746 ("cannot mix null and non-null initialization items", Item
);
2750 Resolve_State
(Item
);
2752 if Is_Entity_Name
(Item
) then
2753 Item_Id
:= Entity_Of
(Item
);
2755 if Ekind_In
(Item_Id
, E_Abstract_State
,
2759 -- The state or variable must be declared in the visible
2760 -- declarations of the package (SPARK RM 7.1.5(7)).
2762 if not Contains
(States_And_Objs
, Item_Id
) then
2763 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2765 ("initialization item & must appear in the visible "
2766 & "declarations of package %", Item
, Item_Id
);
2768 -- Detect a duplicate use of the same initialization item
2769 -- (SPARK RM 7.1.5(5)).
2771 elsif Contains
(Items_Seen
, Item_Id
) then
2772 SPARK_Msg_N
("duplicate initialization item", Item
);
2774 -- The item is legal, add it to the list of processed states
2778 Append_New_Elmt
(Item_Id
, Items_Seen
);
2780 if Ekind
(Item_Id
) = E_Abstract_State
then
2781 Append_New_Elmt
(Item_Id
, States_Seen
);
2784 if Present
(Encapsulating_State
(Item_Id
)) then
2785 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2789 -- The item references something that is not a state or object
2790 -- (SPARK RM 7.1.5(3)).
2794 ("initialization item must denote object or state", Item
);
2797 -- Some form of illegal construct masquerading as a name
2798 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2802 ("initialization item must denote object or state", Item
);
2805 end Analyze_Initialization_Item
;
2807 ---------------------------------------------
2808 -- Analyze_Initialization_Item_With_Inputs --
2809 ---------------------------------------------
2811 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2812 Inputs_Seen
: Elist_Id
:= No_Elist
;
2813 -- A list of all inputs processed so far. This list is used to detect
2814 -- duplicate uses of an input.
2816 Non_Null_Seen
: Boolean := False;
2817 Null_Seen
: Boolean := False;
2818 -- Flags used to check the legality of an input list
2820 procedure Analyze_Input_Item
(Input
: Node_Id
);
2821 -- Verify the legality of a single input item
2823 ------------------------
2824 -- Analyze_Input_Item --
2825 ------------------------
2827 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2828 Input_Id
: Entity_Id
;
2829 Input_OK
: Boolean := True;
2834 if Nkind
(Input
) = N_Null
then
2837 ("multiple null initializations not allowed", Item
);
2839 elsif Non_Null_Seen
then
2841 ("cannot mix null and non-null initialization item", Item
);
2849 Non_Null_Seen
:= True;
2853 ("cannot mix null and non-null initialization item", Item
);
2857 Resolve_State
(Input
);
2859 if Is_Entity_Name
(Input
) then
2860 Input_Id
:= Entity_Of
(Input
);
2862 if Ekind_In
(Input_Id
, E_Abstract_State
,
2864 E_Generic_In_Out_Parameter
,
2865 E_Generic_In_Parameter
,
2871 -- The input cannot denote states or objects declared
2872 -- within the related package (SPARK RM 7.1.5(4)).
2874 if Within_Scope
(Input_Id
, Current_Scope
) then
2876 -- Do not consider generic formal parameters or their
2877 -- respective mappings to generic formals. Even though
2878 -- the formals appear within the scope of the package,
2879 -- it is allowed for an initialization item to depend
2880 -- on an input item.
2882 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2883 E_Generic_In_Parameter
)
2887 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2888 and then Present
(Corresponding_Generic_Association
2889 (Declaration_Node
(Input_Id
)))
2895 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2897 ("input item & cannot denote a visible object or "
2898 & "state of package %", Input
, Input_Id
);
2902 -- Detect a duplicate use of the same input item
2903 -- (SPARK RM 7.1.5(5)).
2905 if Contains
(Inputs_Seen
, Input_Id
) then
2907 SPARK_Msg_N
("duplicate input item", Input
);
2910 -- Input is legal, add it to the list of processed inputs
2913 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2915 if Ekind
(Input_Id
) = E_Abstract_State
then
2916 Append_New_Elmt
(Input_Id
, States_Seen
);
2919 if Ekind_In
(Input_Id
, E_Abstract_State
,
2922 and then Present
(Encapsulating_State
(Input_Id
))
2924 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2928 -- The input references something that is not a state or an
2929 -- object (SPARK RM 7.1.5(3)).
2933 ("input item must denote object or state", Input
);
2936 -- Some form of illegal construct masquerading as a name
2937 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2941 ("input item must denote object or state", Input
);
2944 end Analyze_Input_Item
;
2948 Inputs
: constant Node_Id
:= Expression
(Item
);
2952 Name_Seen
: Boolean := False;
2953 -- A flag used to detect multiple item names
2955 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2958 -- Inspect the name of an item with inputs
2960 Elmt
:= First
(Choices
(Item
));
2961 while Present
(Elmt
) loop
2963 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2966 Analyze_Initialization_Item
(Elmt
);
2972 -- Multiple input items appear as an aggregate
2974 if Nkind
(Inputs
) = N_Aggregate
then
2975 if Present
(Expressions
(Inputs
)) then
2976 Input
:= First
(Expressions
(Inputs
));
2977 while Present
(Input
) loop
2978 Analyze_Input_Item
(Input
);
2983 if Present
(Component_Associations
(Inputs
)) then
2985 ("inputs must appear in named association form", Inputs
);
2988 -- Single input item
2991 Analyze_Input_Item
(Inputs
);
2993 end Analyze_Initialization_Item_With_Inputs
;
2995 --------------------------------
2996 -- Collect_States_And_Objects --
2997 --------------------------------
2999 procedure Collect_States_And_Objects
is
3000 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3004 -- Collect the abstract states defined in the package (if any)
3006 if Present
(Abstract_States
(Pack_Id
)) then
3007 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3010 -- Collect all objects the appear in the visible declarations of the
3013 if Present
(Visible_Declarations
(Pack_Spec
)) then
3014 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3015 while Present
(Decl
) loop
3016 if Comes_From_Source
(Decl
)
3017 and then Nkind
(Decl
) = N_Object_Declaration
3019 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3025 end Collect_States_And_Objects
;
3029 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3032 -- Start of processing for Analyze_Initializes_In_Decl_Part
3035 -- Do not analyze the pragma multiple times
3037 if Is_Analyzed_Pragma
(N
) then
3041 -- Nothing to do when the initialization list is empty
3043 if Nkind
(Inits
) = N_Null
then
3047 -- Single and multiple initialization clauses appear as an aggregate. If
3048 -- this is not the case, then either the parser or the analysis of the
3049 -- pragma failed to produce an aggregate.
3051 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3053 -- Initialize the various lists used during analysis
3055 Collect_States_And_Objects
;
3057 if Present
(Expressions
(Inits
)) then
3058 Init
:= First
(Expressions
(Inits
));
3059 while Present
(Init
) loop
3060 Analyze_Initialization_Item
(Init
);
3065 if Present
(Component_Associations
(Inits
)) then
3066 Init
:= First
(Component_Associations
(Inits
));
3067 while Present
(Init
) loop
3068 Analyze_Initialization_Item_With_Inputs
(Init
);
3073 -- Ensure that a state and a corresponding constituent do not appear
3074 -- together in pragma Initializes.
3076 Check_State_And_Constituent_Use
3077 (States
=> States_Seen
,
3078 Constits
=> Constits_Seen
,
3081 Set_Is_Analyzed_Pragma
(N
);
3082 end Analyze_Initializes_In_Decl_Part
;
3084 ---------------------
3085 -- Analyze_Part_Of --
3086 ---------------------
3088 procedure Analyze_Part_Of
3090 Item_Id
: Entity_Id
;
3092 Encap_Id
: out Entity_Id
;
3093 Legal
: out Boolean)
3095 Encap_Typ
: Entity_Id
;
3096 Item_Decl
: Node_Id
;
3097 Pack_Id
: Entity_Id
;
3098 Placement
: State_Space_Kind
;
3099 Parent_Unit
: Entity_Id
;
3102 -- Assume that the indicator is illegal
3107 if Nkind_In
(Encap
, N_Expanded_Name
,
3109 N_Selected_Component
)
3112 Resolve_State
(Encap
);
3114 Encap_Id
:= Entity
(Encap
);
3116 -- The encapsulator is an abstract state
3118 if Ekind
(Encap_Id
) = E_Abstract_State
then
3121 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3123 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3126 -- Otherwise the encapsulator is not a legal choice
3130 ("indicator Part_Of must denote abstract state, single "
3131 & "protected type or single task type", Encap
);
3135 -- This is a syntax error, always report
3139 ("indicator Part_Of must denote abstract state, single protected "
3140 & "type or single task type", Encap
);
3144 -- Catch a case where indicator Part_Of denotes the abstract view of a
3145 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3147 if From_Limited_With
(Encap_Id
)
3148 and then Present
(Non_Limited_View
(Encap_Id
))
3149 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3151 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3152 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3156 -- The encapsulator is an abstract state
3158 if Ekind
(Encap_Id
) = E_Abstract_State
then
3160 -- Determine where the object, package instantiation or state lives
3161 -- with respect to the enclosing packages or package bodies.
3163 Find_Placement_In_State_Space
3164 (Item_Id
=> Item_Id
,
3165 Placement
=> Placement
,
3166 Pack_Id
=> Pack_Id
);
3168 -- The item appears in a non-package construct with a declarative
3169 -- part (subprogram, block, etc). As such, the item is not allowed
3170 -- to be a part of an encapsulating state because the item is not
3173 if Placement
= Not_In_Package
then
3175 ("indicator Part_Of cannot appear in this context "
3176 & "(SPARK RM 7.2.6(5))", Indic
);
3177 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3179 ("\& is not part of the hidden state of package %",
3182 -- The item appears in the visible state space of some package. In
3183 -- general this scenario does not warrant Part_Of except when the
3184 -- package is a private child unit and the encapsulating state is
3185 -- declared in a parent unit or a public descendant of that parent
3188 elsif Placement
= Visible_State_Space
then
3189 if Is_Child_Unit
(Pack_Id
)
3190 and then Is_Private_Descendant
(Pack_Id
)
3192 -- A variable or state abstraction which is part of the visible
3193 -- state of a private child unit (or one of its public
3194 -- descendants) must have its Part_Of indicator specified. The
3195 -- Part_Of indicator must denote a state abstraction declared
3196 -- by either the parent unit of the private unit or by a public
3197 -- descendant of that parent unit.
3199 -- Find nearest private ancestor (which can be the current unit
3202 Parent_Unit
:= Pack_Id
;
3203 while Present
(Parent_Unit
) loop
3206 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3207 Parent_Unit
:= Scope
(Parent_Unit
);
3210 Parent_Unit
:= Scope
(Parent_Unit
);
3212 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3214 ("indicator Part_Of must denote abstract state or public "
3215 & "descendant of & (SPARK RM 7.2.6(3))",
3216 Indic
, Parent_Unit
);
3218 elsif Scope
(Encap_Id
) = Parent_Unit
3220 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3221 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3227 ("indicator Part_Of must denote abstract state or public "
3228 & "descendant of & (SPARK RM 7.2.6(3))",
3229 Indic
, Parent_Unit
);
3232 -- Indicator Part_Of is not needed when the related package is not
3233 -- a private child unit or a public descendant thereof.
3237 ("indicator Part_Of cannot appear in this context "
3238 & "(SPARK RM 7.2.6(5))", Indic
);
3239 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3241 ("\& is declared in the visible part of package %",
3245 -- When the item appears in the private state space of a package, the
3246 -- encapsulating state must be declared in the same package.
3248 elsif Placement
= Private_State_Space
then
3249 if Scope
(Encap_Id
) /= Pack_Id
then
3251 ("indicator Part_Of must designate an abstract state of "
3252 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3253 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3255 ("\& is declared in the private part of package %",
3259 -- Items declared in the body state space of a package do not need
3260 -- Part_Of indicators as the refinement has already been seen.
3264 ("indicator Part_Of cannot appear in this context "
3265 & "(SPARK RM 7.2.6(5))", Indic
);
3267 if Scope
(Encap_Id
) = Pack_Id
then
3268 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3270 ("\& is declared in the body of package %", Indic
, Item_Id
);
3274 -- The encapsulator is a single concurrent type
3277 Encap_Typ
:= Etype
(Encap_Id
);
3279 -- Only abstract states and variables can act as constituents of an
3280 -- encapsulating single concurrent type.
3282 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3285 -- The constituent is a constant
3287 elsif Ekind
(Item_Id
) = E_Constant
then
3288 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3290 (Fix_Msg
(Encap_Typ
, "consant & cannot act as constituent of "
3291 & "single protected type %"), Indic
, Item_Id
);
3293 -- The constituent is a package instantiation
3296 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3298 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3299 & "constituent of single protected type %"), Indic
, Item_Id
);
3302 -- When the item denotes an abstract state of a nested package, use
3303 -- the declaration of the package to detect proper placement.
3308 -- with Abstract_State => (State with Part_Of => T)
3310 if Ekind
(Item_Id
) = E_Abstract_State
then
3311 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3313 Item_Decl
:= Declaration_Node
(Item_Id
);
3316 -- Both the item and its encapsulating single concurrent type must
3317 -- appear in the same declarative region (SPARK RM 9.3). Note that
3318 -- privacy is ignored.
3320 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3321 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3323 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3324 & "immediately within the same region as single protected "
3325 & "type %"), Indic
, Item_Id
);
3330 end Analyze_Part_Of
;
3332 ----------------------------------
3333 -- Analyze_Part_Of_In_Decl_Part --
3334 ----------------------------------
3336 procedure Analyze_Part_Of_In_Decl_Part
3338 Freeze_Id
: Entity_Id
:= Empty
)
3340 Encap
: constant Node_Id
:=
3341 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3342 Errors
: constant Nat
:= Serious_Errors_Detected
;
3343 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3344 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3345 Constits
: Elist_Id
;
3346 Encap_Id
: Entity_Id
;
3350 -- Detect any discrepancies between the placement of the variable with
3351 -- respect to general state space and the encapsulating state or single
3358 Encap_Id
=> Encap_Id
,
3361 -- The Part_Of indicator turns the variable into a constituent of the
3362 -- encapsulating state or single concurrent type.
3365 pragma Assert
(Present
(Encap_Id
));
3366 Constits
:= Part_Of_Constituents
(Encap_Id
);
3368 if No
(Constits
) then
3369 Constits
:= New_Elmt_List
;
3370 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3373 Append_Elmt
(Var_Id
, Constits
);
3374 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3377 -- Emit a clarification message when the encapsulator is undefined,
3378 -- possibly due to contract "freezing".
3380 if Errors
/= Serious_Errors_Detected
3381 and then Present
(Freeze_Id
)
3382 and then Has_Undefined_Reference
(Encap
)
3384 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3386 end Analyze_Part_Of_In_Decl_Part
;
3388 --------------------
3389 -- Analyze_Pragma --
3390 --------------------
3392 procedure Analyze_Pragma
(N
: Node_Id
) is
3393 Loc
: constant Source_Ptr
:= Sloc
(N
);
3394 Prag_Id
: Pragma_Id
;
3397 -- Name of the source pragma, or name of the corresponding aspect for
3398 -- pragmas which originate in a source aspect. In the latter case, the
3399 -- name may be different from the pragma name.
3401 Pragma_Exit
: exception;
3402 -- This exception is used to exit pragma processing completely. It
3403 -- is used when an error is detected, and no further processing is
3404 -- required. It is also used if an earlier error has left the tree in
3405 -- a state where the pragma should not be processed.
3408 -- Number of pragma argument associations
3414 -- First four pragma arguments (pragma argument association nodes, or
3415 -- Empty if the corresponding argument does not exist).
3417 type Name_List
is array (Natural range <>) of Name_Id
;
3418 type Args_List
is array (Natural range <>) of Node_Id
;
3419 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3421 -----------------------
3422 -- Local Subprograms --
3423 -----------------------
3425 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3426 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3427 -- get the given string argument, and place it in Name_Buffer, adding
3428 -- leading and trailing asterisks if they are not already present. The
3429 -- caller has already checked that Arg is a static string expression.
3431 procedure Ada_2005_Pragma
;
3432 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3433 -- Ada 95 mode, these are implementation defined pragmas, so should be
3434 -- caught by the No_Implementation_Pragmas restriction.
3436 procedure Ada_2012_Pragma
;
3437 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3438 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3439 -- should be caught by the No_Implementation_Pragmas restriction.
3441 procedure Analyze_Depends_Global
3442 (Spec_Id
: out Entity_Id
;
3443 Subp_Decl
: out Node_Id
;
3444 Legal
: out Boolean);
3445 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3446 -- legality of the placement and related context of the pragma. Spec_Id
3447 -- is the entity of the related subprogram. Subp_Decl is the declaration
3448 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3450 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3451 -- Inspect the remainder of the list containing pragma N and look for
3452 -- a pragma that matches Id. If found, analyze the pragma.
3454 procedure Analyze_Pre_Post_Condition
;
3455 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3457 procedure Analyze_Refined_Depends_Global_Post
3458 (Spec_Id
: out Entity_Id
;
3459 Body_Id
: out Entity_Id
;
3460 Legal
: out Boolean);
3461 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3462 -- Refined_Global and Refined_Post. Verify the legality of the placement
3463 -- and related context of the pragma. Spec_Id is the entity of the
3464 -- related subprogram. Body_Id is the entity of the subprogram body.
3465 -- Flag Legal is set when the pragma is legal.
3467 procedure Check_Ada_83_Warning
;
3468 -- Issues a warning message for the current pragma if operating in Ada
3469 -- 83 mode (used for language pragmas that are not a standard part of
3470 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3473 procedure Check_Arg_Count
(Required
: Nat
);
3474 -- Check argument count for pragma is equal to given parameter. If not,
3475 -- then issue an error message and raise Pragma_Exit.
3477 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3478 -- Arg which can either be a pragma argument association, in which case
3479 -- the check is applied to the expression of the association or an
3480 -- expression directly.
3482 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3483 -- Check that an argument has the right form for an EXTERNAL_NAME
3484 -- parameter of an extended import/export pragma. The rule is that the
3485 -- name must be an identifier or string literal (in Ada 83 mode) or a
3486 -- static string expression (in Ada 95 mode).
3488 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3489 -- Check the specified argument Arg to make sure that it is an
3490 -- identifier. If not give error and raise Pragma_Exit.
3492 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3493 -- Check the specified argument Arg to make sure that it is an integer
3494 -- literal. If not give error and raise Pragma_Exit.
3496 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3497 -- Check the specified argument Arg to make sure that it has the proper
3498 -- syntactic form for a local name and meets the semantic requirements
3499 -- for a local name. The local name is analyzed as part of the
3500 -- processing for this call. In addition, the local name is required
3501 -- to represent an entity at the library level.
3503 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3504 -- Check the specified argument Arg to make sure that it has the proper
3505 -- syntactic form for a local name and meets the semantic requirements
3506 -- for a local name. The local name is analyzed as part of the
3507 -- processing for this call.
3509 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3510 -- Check the specified argument Arg to make sure that it is a valid
3511 -- locking policy name. If not give error and raise Pragma_Exit.
3513 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3514 -- Check the specified argument Arg to make sure that it is a valid
3515 -- elaboration policy name. If not give error and raise Pragma_Exit.
3517 procedure Check_Arg_Is_One_Of
3520 procedure Check_Arg_Is_One_Of
3522 N1
, N2
, N3
: Name_Id
);
3523 procedure Check_Arg_Is_One_Of
3525 N1
, N2
, N3
, N4
: Name_Id
);
3526 procedure Check_Arg_Is_One_Of
3528 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3529 -- Check the specified argument Arg to make sure that it is an
3530 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3531 -- present). If not then give error and raise Pragma_Exit.
3533 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3534 -- Check the specified argument Arg to make sure that it is a valid
3535 -- queuing policy name. If not give error and raise Pragma_Exit.
3537 procedure Check_Arg_Is_OK_Static_Expression
3539 Typ
: Entity_Id
:= Empty
);
3540 -- Check the specified argument Arg to make sure that it is a static
3541 -- expression of the given type (i.e. it will be analyzed and resolved
3542 -- using this type, which can be any valid argument to Resolve, e.g.
3543 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3544 -- Typ is left Empty, then any static expression is allowed. Includes
3545 -- checking that the argument does not raise Constraint_Error.
3547 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3548 -- Check the specified argument Arg to make sure that it is a valid task
3549 -- dispatching policy name. If not give error and raise Pragma_Exit.
3551 procedure Check_Arg_Order
(Names
: Name_List
);
3552 -- Checks for an instance of two arguments with identifiers for the
3553 -- current pragma which are not in the sequence indicated by Names,
3554 -- and if so, generates a fatal message about bad order of arguments.
3556 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3557 -- Check there are at least N arguments present
3559 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3560 -- Check there are no more than N arguments present
3562 procedure Check_Component
3565 In_Variant_Part
: Boolean := False);
3566 -- Examine an Unchecked_Union component for correct use of per-object
3567 -- constrained subtypes, and for restrictions on finalizable components.
3568 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3569 -- should be set when Comp comes from a record variant.
3571 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3572 -- Check if a rep item of the same name as the current pragma is already
3573 -- chained as a rep pragma to the given entity. If so give a message
3574 -- about the duplicate, and then raise Pragma_Exit so does not return.
3575 -- Note that if E is a type, then this routine avoids flagging a pragma
3576 -- which applies to a parent type from which E is derived.
3578 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3579 -- Nam is an N_String_Literal node containing the external name set by
3580 -- an Import or Export pragma (or extended Import or Export pragma).
3581 -- This procedure checks for possible duplications if this is the export
3582 -- case, and if found, issues an appropriate error message.
3584 procedure Check_Expr_Is_OK_Static_Expression
3586 Typ
: Entity_Id
:= Empty
);
3587 -- Check the specified expression Expr to make sure that it is a static
3588 -- expression of the given type (i.e. it will be analyzed and resolved
3589 -- using this type, which can be any valid argument to Resolve, e.g.
3590 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3591 -- Typ is left Empty, then any static expression is allowed. Includes
3592 -- checking that the expression does not raise Constraint_Error.
3594 procedure Check_First_Subtype
(Arg
: Node_Id
);
3595 -- Checks that Arg, whose expression is an entity name, references a
3598 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3599 -- Checks that the given argument has an identifier, and if so, requires
3600 -- it to match the given identifier name. If there is no identifier, or
3601 -- a non-matching identifier, then an error message is given and
3602 -- Pragma_Exit is raised.
3604 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3605 -- Checks that the given argument has an identifier, and if so, requires
3606 -- it to match one of the given identifier names. If there is no
3607 -- identifier, or a non-matching identifier, then an error message is
3608 -- given and Pragma_Exit is raised.
3610 procedure Check_In_Main_Program
;
3611 -- Common checks for pragmas that appear within a main program
3612 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3614 procedure Check_Interrupt_Or_Attach_Handler
;
3615 -- Common processing for first argument of pragma Interrupt_Handler or
3616 -- pragma Attach_Handler.
3618 procedure Check_Loop_Pragma_Placement
;
3619 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3620 -- appear immediately within a construct restricted to loops, and that
3621 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3623 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3624 -- Check that pragma appears in a declarative part, or in a package
3625 -- specification, i.e. that it does not occur in a statement sequence
3628 procedure Check_No_Identifier
(Arg
: Node_Id
);
3629 -- Checks that the given argument does not have an identifier. If
3630 -- an identifier is present, then an error message is issued, and
3631 -- Pragma_Exit is raised.
3633 procedure Check_No_Identifiers
;
3634 -- Checks that none of the arguments to the pragma has an identifier.
3635 -- If any argument has an identifier, then an error message is issued,
3636 -- and Pragma_Exit is raised.
3638 procedure Check_No_Link_Name
;
3639 -- Checks that no link name is specified
3641 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3642 -- Checks if the given argument has an identifier, and if so, requires
3643 -- it to match the given identifier name. If there is a non-matching
3644 -- identifier, then an error message is given and Pragma_Exit is raised.
3646 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3647 -- Checks if the given argument has an identifier, and if so, requires
3648 -- it to match the given identifier name. If there is a non-matching
3649 -- identifier, then an error message is given and Pragma_Exit is raised.
3650 -- In this version of the procedure, the identifier name is given as
3651 -- a string with lower case letters.
3653 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3654 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3655 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3656 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3657 -- is an OK static boolean expression. Emit an error if this is not the
3660 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3661 -- Constr is a constraint from an N_Subtype_Indication node from a
3662 -- component constraint in an Unchecked_Union type. This routine checks
3663 -- that the constraint is static as required by the restrictions for
3666 procedure Check_Valid_Configuration_Pragma
;
3667 -- Legality checks for placement of a configuration pragma
3669 procedure Check_Valid_Library_Unit_Pragma
;
3670 -- Legality checks for library unit pragmas. A special case arises for
3671 -- pragmas in generic instances that come from copies of the original
3672 -- library unit pragmas in the generic templates. In the case of other
3673 -- than library level instantiations these can appear in contexts which
3674 -- would normally be invalid (they only apply to the original template
3675 -- and to library level instantiations), and they are simply ignored,
3676 -- which is implemented by rewriting them as null statements.
3678 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3679 -- Check an Unchecked_Union variant for lack of nested variants and
3680 -- presence of at least one component. UU_Typ is the related Unchecked_
3683 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3684 -- Subsidiary routine to the processing of pragmas Abstract_State,
3685 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3686 -- Refined_Global and Refined_State. Transform argument Arg into
3687 -- an aggregate if not one already. N_Null is never transformed.
3688 -- Arg may denote an aspect specification or a pragma argument
3691 procedure Error_Pragma
(Msg
: String);
3692 pragma No_Return
(Error_Pragma
);
3693 -- Outputs error message for current pragma. The message contains a %
3694 -- that will be replaced with the pragma name, and the flag is placed
3695 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3696 -- calls Fix_Error (see spec of that procedure for details).
3698 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3699 pragma No_Return
(Error_Pragma_Arg
);
3700 -- Outputs error message for current pragma. The message may contain
3701 -- a % that will be replaced with the pragma name. The parameter Arg
3702 -- may either be a pragma argument association, in which case the flag
3703 -- is placed on the expression of this association, or an expression,
3704 -- in which case the flag is placed directly on the expression. The
3705 -- message is placed using Error_Msg_N, so the message may also contain
3706 -- an & insertion character which will reference the given Arg value.
3707 -- After placing the message, Pragma_Exit is raised. Note: this routine
3708 -- calls Fix_Error (see spec of that procedure for details).
3710 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3711 pragma No_Return
(Error_Pragma_Arg
);
3712 -- Similar to above form of Error_Pragma_Arg except that two messages
3713 -- are provided, the second is a continuation comment starting with \.
3715 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3716 pragma No_Return
(Error_Pragma_Arg_Ident
);
3717 -- Outputs error message for current pragma. The message may contain a %
3718 -- that will be replaced with the pragma name. The parameter Arg must be
3719 -- a pragma argument association with a non-empty identifier (i.e. its
3720 -- Chars field must be set), and the error message is placed on the
3721 -- identifier. The message is placed using Error_Msg_N so the message
3722 -- may also contain an & insertion character which will reference
3723 -- the identifier. After placing the message, Pragma_Exit is raised.
3724 -- Note: this routine calls Fix_Error (see spec of that procedure for
3727 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3728 pragma No_Return
(Error_Pragma_Ref
);
3729 -- Outputs error message for current pragma. The message may contain
3730 -- a % that will be replaced with the pragma name. The parameter Ref
3731 -- must be an entity whose name can be referenced by & and sloc by #.
3732 -- After placing the message, Pragma_Exit is raised. Note: this routine
3733 -- calls Fix_Error (see spec of that procedure for details).
3735 function Find_Lib_Unit_Name
return Entity_Id
;
3736 -- Used for a library unit pragma to find the entity to which the
3737 -- library unit pragma applies, returns the entity found.
3739 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3740 -- If the pragma is a compilation unit pragma, the id must denote the
3741 -- compilation unit in the same compilation, and the pragma must appear
3742 -- in the list of preceding or trailing pragmas. If it is a program
3743 -- unit pragma that is not a compilation unit pragma, then the
3744 -- identifier must be visible.
3746 function Find_Unique_Parameterless_Procedure
3748 Arg
: Node_Id
) return Entity_Id
;
3749 -- Used for a procedure pragma to find the unique parameterless
3750 -- procedure identified by Name, returns it if it exists, otherwise
3751 -- errors out and uses Arg as the pragma argument for the message.
3753 function Fix_Error
(Msg
: String) return String;
3754 -- This is called prior to issuing an error message. Msg is the normal
3755 -- error message issued in the pragma case. This routine checks for the
3756 -- case of a pragma coming from an aspect in the source, and returns a
3757 -- message suitable for the aspect case as follows:
3759 -- Each substring "pragma" is replaced by "aspect"
3761 -- If "argument of" is at the start of the error message text, it is
3762 -- replaced by "entity for".
3764 -- If "argument" is at the start of the error message text, it is
3765 -- replaced by "entity".
3767 -- So for example, "argument of pragma X must be discrete type"
3768 -- returns "entity for aspect X must be a discrete type".
3770 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3771 -- be different from the pragma name). If the current pragma results
3772 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3773 -- original pragma name.
3775 procedure Gather_Associations
3777 Args
: out Args_List
);
3778 -- This procedure is used to gather the arguments for a pragma that
3779 -- permits arbitrary ordering of parameters using the normal rules
3780 -- for named and positional parameters. The Names argument is a list
3781 -- of Name_Id values that corresponds to the allowed pragma argument
3782 -- association identifiers in order. The result returned in Args is
3783 -- a list of corresponding expressions that are the pragma arguments.
3784 -- Note that this is a list of expressions, not of pragma argument
3785 -- associations (Gather_Associations has completely checked all the
3786 -- optional identifiers when it returns). An entry in Args is Empty
3787 -- on return if the corresponding argument is not present.
3789 procedure GNAT_Pragma
;
3790 -- Called for all GNAT defined pragmas to check the relevant restriction
3791 -- (No_Implementation_Pragmas).
3793 function Is_Before_First_Decl
3794 (Pragma_Node
: Node_Id
;
3795 Decls
: List_Id
) return Boolean;
3796 -- Return True if Pragma_Node is before the first declarative item in
3797 -- Decls where Decls is the list of declarative items.
3799 function Is_Configuration_Pragma
return Boolean;
3800 -- Determines if the placement of the current pragma is appropriate
3801 -- for a configuration pragma.
3803 function Is_In_Context_Clause
return Boolean;
3804 -- Returns True if pragma appears within the context clause of a unit,
3805 -- and False for any other placement (does not generate any messages).
3807 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3808 -- Analyzes the argument, and determines if it is a static string
3809 -- expression, returns True if so, False if non-static or not String.
3810 -- A special case is that a string literal returns True in Ada 83 mode
3811 -- (which has no such thing as static string expressions). Note that
3812 -- the call analyzes its argument, so this cannot be used for the case
3813 -- where an identifier might not be declared.
3815 procedure Pragma_Misplaced
;
3816 pragma No_Return
(Pragma_Misplaced
);
3817 -- Issue fatal error message for misplaced pragma
3819 procedure Process_Atomic_Independent_Shared_Volatile
;
3820 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3821 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3822 -- and treated as being identical in effect to pragma Atomic.
3824 procedure Process_Compile_Time_Warning_Or_Error
;
3825 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3827 procedure Process_Convention
3828 (C
: out Convention_Id
;
3829 Ent
: out Entity_Id
);
3830 -- Common processing for Convention, Interface, Import and Export.
3831 -- Checks first two arguments of pragma, and sets the appropriate
3832 -- convention value in the specified entity or entities. On return
3833 -- C is the convention, Ent is the referenced entity.
3835 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3836 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3837 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3839 procedure Process_Extended_Import_Export_Object_Pragma
3840 (Arg_Internal
: Node_Id
;
3841 Arg_External
: Node_Id
;
3842 Arg_Size
: Node_Id
);
3843 -- Common processing for the pragmas Import/Export_Object. The three
3844 -- arguments correspond to the three named parameters of the pragmas. An
3845 -- argument is empty if the corresponding parameter is not present in
3848 procedure Process_Extended_Import_Export_Internal_Arg
3849 (Arg_Internal
: Node_Id
:= Empty
);
3850 -- Common processing for all extended Import and Export pragmas. The
3851 -- argument is the pragma parameter for the Internal argument. If
3852 -- Arg_Internal is empty or inappropriate, an error message is posted.
3853 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3854 -- set to identify the referenced entity.
3856 procedure Process_Extended_Import_Export_Subprogram_Pragma
3857 (Arg_Internal
: Node_Id
;
3858 Arg_External
: Node_Id
;
3859 Arg_Parameter_Types
: Node_Id
;
3860 Arg_Result_Type
: Node_Id
:= Empty
;
3861 Arg_Mechanism
: Node_Id
;
3862 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3863 -- Common processing for all extended Import and Export pragmas applying
3864 -- to subprograms. The caller omits any arguments that do not apply to
3865 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3866 -- only in the Import_Function and Export_Function cases). The argument
3867 -- names correspond to the allowed pragma association identifiers.
3869 procedure Process_Generic_List
;
3870 -- Common processing for Share_Generic and Inline_Generic
3872 procedure Process_Import_Or_Interface
;
3873 -- Common processing for Import or Interface
3875 procedure Process_Import_Predefined_Type
;
3876 -- Processing for completing a type with pragma Import. This is used
3877 -- to declare types that match predefined C types, especially for cases
3878 -- without corresponding Ada predefined type.
3880 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3881 -- Inline status of a subprogram, indicated as follows:
3882 -- Suppressed: inlining is suppressed for the subprogram
3883 -- Disabled: no inlining is requested for the subprogram
3884 -- Enabled: inlining is requested/required for the subprogram
3886 procedure Process_Inline
(Status
: Inline_Status
);
3887 -- Common processing for Inline, Inline_Always and No_Inline. Parameter
3888 -- indicates the inline status specified by the pragma.
3890 procedure Process_Interface_Name
3891 (Subprogram_Def
: Entity_Id
;
3893 Link_Arg
: Node_Id
);
3894 -- Given the last two arguments of pragma Import, pragma Export, or
3895 -- pragma Interface_Name, performs validity checks and sets the
3896 -- Interface_Name field of the given subprogram entity to the
3897 -- appropriate external or link name, depending on the arguments given.
3898 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3899 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3900 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3901 -- nor Link_Arg is present, the interface name is set to the default
3902 -- from the subprogram name.
3904 procedure Process_Interrupt_Or_Attach_Handler
;
3905 -- Common processing for Interrupt and Attach_Handler pragmas
3907 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3908 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3909 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3910 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3911 -- is not set in the Restrictions case.
3913 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3914 -- Common processing for Suppress and Unsuppress. The boolean parameter
3915 -- Suppress_Case is True for the Suppress case, and False for the
3918 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3919 -- Subsidiary to the analysis of pragmas Independent[_Components].
3920 -- Record such a pragma N applied to entity E for future checks.
3922 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3923 -- This procedure sets the Is_Exported flag for the given entity,
3924 -- checking that the entity was not previously imported. Arg is
3925 -- the argument that specified the entity. A check is also made
3926 -- for exporting inappropriate entities.
3928 procedure Set_Extended_Import_Export_External_Name
3929 (Internal_Ent
: Entity_Id
;
3930 Arg_External
: Node_Id
);
3931 -- Common processing for all extended import export pragmas. The first
3932 -- argument, Internal_Ent, is the internal entity, which has already
3933 -- been checked for validity by the caller. Arg_External is from the
3934 -- Import or Export pragma, and may be null if no External parameter
3935 -- was present. If Arg_External is present and is a non-null string
3936 -- (a null string is treated as the default), then the Interface_Name
3937 -- field of Internal_Ent is set appropriately.
3939 procedure Set_Imported
(E
: Entity_Id
);
3940 -- This procedure sets the Is_Imported flag for the given entity,
3941 -- checking that it is not previously exported or imported.
3943 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3944 -- Mech is a parameter passing mechanism (see Import_Function syntax
3945 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3946 -- has the right form, and if not issues an error message. If the
3947 -- argument has the right form then the Mechanism field of Ent is
3948 -- set appropriately.
3950 procedure Set_Rational_Profile
;
3951 -- Activate the set of configuration pragmas and permissions that make
3952 -- up the Rational profile.
3954 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
3955 -- Activate the set of configuration pragmas and restrictions that make
3956 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
3957 -- Ravenscar. N is the corresponding pragma node, which is used for
3958 -- error messages on any constructs violating the profile.
3960 ----------------------------------
3961 -- Acquire_Warning_Match_String --
3962 ----------------------------------
3964 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
3966 String_To_Name_Buffer
3967 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
3969 -- Add asterisk at start if not already there
3971 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
3972 Name_Buffer
(2 .. Name_Len
+ 1) :=
3973 Name_Buffer
(1 .. Name_Len
);
3974 Name_Buffer
(1) := '*';
3975 Name_Len
:= Name_Len
+ 1;
3978 -- Add asterisk at end if not already there
3980 if Name_Buffer
(Name_Len
) /= '*' then
3981 Name_Len
:= Name_Len
+ 1;
3982 Name_Buffer
(Name_Len
) := '*';
3984 end Acquire_Warning_Match_String
;
3986 ---------------------
3987 -- Ada_2005_Pragma --
3988 ---------------------
3990 procedure Ada_2005_Pragma
is
3992 if Ada_Version
<= Ada_95
then
3993 Check_Restriction
(No_Implementation_Pragmas
, N
);
3995 end Ada_2005_Pragma
;
3997 ---------------------
3998 -- Ada_2012_Pragma --
3999 ---------------------
4001 procedure Ada_2012_Pragma
is
4003 if Ada_Version
<= Ada_2005
then
4004 Check_Restriction
(No_Implementation_Pragmas
, N
);
4006 end Ada_2012_Pragma
;
4008 ----------------------------
4009 -- Analyze_Depends_Global --
4010 ----------------------------
4012 procedure Analyze_Depends_Global
4013 (Spec_Id
: out Entity_Id
;
4014 Subp_Decl
: out Node_Id
;
4015 Legal
: out Boolean)
4018 -- Assume that the pragma is illegal
4025 Check_Arg_Count
(1);
4027 -- Ensure the proper placement of the pragma. Depends/Global must be
4028 -- associated with a subprogram declaration or a body that acts as a
4031 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4035 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4038 -- Generic subprogram
4040 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4043 -- Object declaration of a single concurrent type
4045 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
then
4050 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4053 -- Subprogram body acts as spec
4055 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4056 and then No
(Corresponding_Spec
(Subp_Decl
))
4060 -- Subprogram body stub acts as spec
4062 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4063 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4067 -- Subprogram declaration
4069 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4074 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4082 -- If we get here, then the pragma is legal
4085 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4087 -- When the related context is an entry, the entry must belong to a
4088 -- protected unit (SPARK RM 6.1.4(6)).
4090 if Is_Entry_Declaration
(Spec_Id
)
4091 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4096 -- When the related context is an anonymous object created for a
4097 -- simple concurrent type, the type must be a task
4098 -- (SPARK RM 6.1.4(6)).
4100 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4101 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4107 -- A pragma that applies to a Ghost entity becomes Ghost for the
4108 -- purposes of legality checks and removal of ignored Ghost code.
4110 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
4111 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4112 end Analyze_Depends_Global
;
4114 ------------------------
4115 -- Analyze_If_Present --
4116 ------------------------
4118 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4122 pragma Assert
(Is_List_Member
(N
));
4124 -- Inspect the declarations or statements following pragma N looking
4125 -- for another pragma whose Id matches the caller's request. If it is
4126 -- available, analyze it.
4129 while Present
(Stmt
) loop
4130 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4131 Analyze_Pragma
(Stmt
);
4134 -- The first source declaration or statement immediately following
4135 -- N ends the region where a pragma may appear.
4137 elsif Comes_From_Source
(Stmt
) then
4143 end Analyze_If_Present
;
4145 --------------------------------
4146 -- Analyze_Pre_Post_Condition --
4147 --------------------------------
4149 procedure Analyze_Pre_Post_Condition
is
4150 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4151 Subp_Decl
: Node_Id
;
4152 Subp_Id
: Entity_Id
;
4154 Duplicates_OK
: Boolean := False;
4155 -- Flag set when a pre/postcondition allows multiple pragmas of the
4158 In_Body_OK
: Boolean := False;
4159 -- Flag set when a pre/postcondition is allowed to appear on a body
4160 -- even though the subprogram may have a spec.
4162 Is_Pre_Post
: Boolean := False;
4163 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4167 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4168 -- offer uniformity among the various kinds of pre/postconditions by
4169 -- rewriting the pragma identifier. This allows the retrieval of the
4170 -- original pragma name by routine Original_Aspect_Pragma_Name.
4172 if Comes_From_Source
(N
) then
4173 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4174 Is_Pre_Post
:= True;
4175 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4176 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4178 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4179 Is_Pre_Post
:= True;
4180 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4181 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4185 -- Determine the semantics with respect to duplicates and placement
4186 -- in a body. Pragmas Precondition and Postcondition were introduced
4187 -- before aspects and are not subject to the same aspect-like rules.
4189 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4190 Duplicates_OK
:= True;
4196 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4197 -- argument without an identifier.
4200 Check_Arg_Count
(1);
4201 Check_No_Identifiers
;
4203 -- Pragmas Precondition and Postcondition have complex argument
4207 Check_At_Least_N_Arguments
(1);
4208 Check_At_Most_N_Arguments
(2);
4209 Check_Optional_Identifier
(Arg1
, Name_Check
);
4211 if Present
(Arg2
) then
4212 Check_Optional_Identifier
(Arg2
, Name_Message
);
4213 Preanalyze_Spec_Expression
4214 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4218 -- For a pragma PPC in the extended main source unit, record enabled
4220 -- ??? nothing checks that the pragma is in the main source unit
4222 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4223 Set_SCO_Pragma_Enabled
(Loc
);
4226 -- Ensure the proper placement of the pragma
4229 Find_Related_Declaration_Or_Body
4230 (N
, Do_Checks
=> not Duplicates_OK
);
4232 -- When a pre/postcondition pragma applies to an abstract subprogram,
4233 -- its original form must be an aspect with 'Class.
4235 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4236 if not From_Aspect_Specification
(N
) then
4238 ("pragma % cannot be applied to abstract subprogram");
4240 elsif not Class_Present
(N
) then
4242 ("aspect % requires ''Class for abstract subprogram");
4245 -- Entry declaration
4247 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4250 -- Generic subprogram declaration
4252 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4257 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4258 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4262 -- Subprogram body stub
4264 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4265 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4269 -- Subprogram declaration
4271 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4273 -- AI05-0230: When a pre/postcondition pragma applies to a null
4274 -- procedure, its original form must be an aspect with 'Class.
4276 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4277 and then Null_Present
(Specification
(Subp_Decl
))
4278 and then From_Aspect_Specification
(N
)
4279 and then not Class_Present
(N
)
4281 Error_Pragma
("aspect % requires ''Class for null procedure");
4284 -- Otherwise the placement is illegal
4291 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4293 -- Chain the pragma on the contract for further processing by
4294 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4296 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4298 -- A pragma that applies to a Ghost entity becomes Ghost for the
4299 -- purposes of legality checks and removal of ignored Ghost code.
4301 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
4303 -- Fully analyze the pragma when it appears inside an entry or
4304 -- subprogram body because it cannot benefit from forward references.
4306 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4308 N_Subprogram_Body_Stub
)
4310 -- The legality checks of pragmas Precondition and Postcondition
4311 -- are affected by the SPARK mode in effect and the volatility of
4312 -- the context. Analyze all pragmas in a specific order.
4314 Analyze_If_Present
(Pragma_SPARK_Mode
);
4315 Analyze_If_Present
(Pragma_Volatile_Function
);
4316 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4318 end Analyze_Pre_Post_Condition
;
4320 -----------------------------------------
4321 -- Analyze_Refined_Depends_Global_Post --
4322 -----------------------------------------
4324 procedure Analyze_Refined_Depends_Global_Post
4325 (Spec_Id
: out Entity_Id
;
4326 Body_Id
: out Entity_Id
;
4327 Legal
: out Boolean)
4329 Body_Decl
: Node_Id
;
4330 Spec_Decl
: Node_Id
;
4333 -- Assume that the pragma is illegal
4340 Check_Arg_Count
(1);
4341 Check_No_Identifiers
;
4343 -- Verify the placement of the pragma and check for duplicates. The
4344 -- pragma must apply to a subprogram body [stub].
4346 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4350 if Nkind
(Body_Decl
) = N_Entry_Body
then
4355 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4358 -- Subprogram body stub
4360 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4365 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4373 Body_Id
:= Defining_Entity
(Body_Decl
);
4374 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4376 -- The pragma must apply to the second declaration of a subprogram.
4377 -- In other words, the body [stub] cannot acts as a spec.
4379 if No
(Spec_Id
) then
4380 Error_Pragma
("pragma % cannot apply to a stand alone body");
4383 -- Catch the case where the subprogram body is a subunit and acts as
4384 -- the third declaration of the subprogram.
4386 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4387 Error_Pragma
("pragma % cannot apply to a subunit");
4391 -- A refined pragma can only apply to the body [stub] of a subprogram
4392 -- declared in the visible part of a package. Retrieve the context of
4393 -- the subprogram declaration.
4395 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4397 -- When dealing with protected entries or protected subprograms, use
4398 -- the enclosing protected type as the proper context.
4400 if Ekind_In
(Spec_Id
, E_Entry
,
4404 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4406 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4409 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4411 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4412 & "subprogram declared in a package specification"));
4416 -- If we get here, then the pragma is legal
4420 -- A pragma that applies to a Ghost entity becomes Ghost for the
4421 -- purposes of legality checks and removal of ignored Ghost code.
4423 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
4425 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4426 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4428 end Analyze_Refined_Depends_Global_Post
;
4430 --------------------------
4431 -- Check_Ada_83_Warning --
4432 --------------------------
4434 procedure Check_Ada_83_Warning
is
4436 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4437 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4439 end Check_Ada_83_Warning
;
4441 ---------------------
4442 -- Check_Arg_Count --
4443 ---------------------
4445 procedure Check_Arg_Count
(Required
: Nat
) is
4447 if Arg_Count
/= Required
then
4448 Error_Pragma
("wrong number of arguments for pragma%");
4450 end Check_Arg_Count
;
4452 --------------------------------
4453 -- Check_Arg_Is_External_Name --
4454 --------------------------------
4456 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4457 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4460 if Nkind
(Argx
) = N_Identifier
then
4464 Analyze_And_Resolve
(Argx
, Standard_String
);
4466 if Is_OK_Static_Expression
(Argx
) then
4469 elsif Etype
(Argx
) = Any_Type
then
4472 -- An interesting special case, if we have a string literal and
4473 -- we are in Ada 83 mode, then we allow it even though it will
4474 -- not be flagged as static. This allows expected Ada 83 mode
4475 -- use of external names which are string literals, even though
4476 -- technically these are not static in Ada 83.
4478 elsif Ada_Version
= Ada_83
4479 and then Nkind
(Argx
) = N_String_Literal
4483 -- Static expression that raises Constraint_Error. This has
4484 -- already been flagged, so just exit from pragma processing.
4486 elsif Is_OK_Static_Expression
(Argx
) then
4489 -- Here we have a real error (non-static expression)
4492 Error_Msg_Name_1
:= Pname
;
4495 Msg
: constant String :=
4496 "argument for pragma% must be a identifier or "
4497 & "static string expression!";
4499 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
4504 end Check_Arg_Is_External_Name
;
4506 -----------------------------
4507 -- Check_Arg_Is_Identifier --
4508 -----------------------------
4510 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
4511 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4513 if Nkind
(Argx
) /= N_Identifier
then
4515 ("argument for pragma% must be identifier", Argx
);
4517 end Check_Arg_Is_Identifier
;
4519 ----------------------------------
4520 -- Check_Arg_Is_Integer_Literal --
4521 ----------------------------------
4523 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
4524 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4526 if Nkind
(Argx
) /= N_Integer_Literal
then
4528 ("argument for pragma% must be integer literal", Argx
);
4530 end Check_Arg_Is_Integer_Literal
;
4532 -------------------------------------------
4533 -- Check_Arg_Is_Library_Level_Local_Name --
4534 -------------------------------------------
4538 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4539 -- | library_unit_NAME
4541 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
4543 Check_Arg_Is_Local_Name
(Arg
);
4545 -- If it came from an aspect, we want to give the error just as if it
4546 -- came from source.
4548 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
4549 and then (Comes_From_Source
(N
)
4550 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
4553 ("argument for pragma% must be library level entity", Arg
);
4555 end Check_Arg_Is_Library_Level_Local_Name
;
4557 -----------------------------
4558 -- Check_Arg_Is_Local_Name --
4559 -----------------------------
4563 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4564 -- | library_unit_NAME
4566 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
4567 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4570 -- If this pragma came from an aspect specification, we don't want to
4571 -- check for this error, because that would cause spurious errors, in
4572 -- case a type is frozen in a scope more nested than the type. The
4573 -- aspect itself of course can't be anywhere but on the declaration
4576 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
4577 if From_Aspect_Specification
(Parent
(Arg
)) then
4581 -- Arg is the Expression of an N_Pragma_Argument_Association
4584 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
4591 if Nkind
(Argx
) not in N_Direct_Name
4592 and then (Nkind
(Argx
) /= N_Attribute_Reference
4593 or else Present
(Expressions
(Argx
))
4594 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
4595 and then (not Is_Entity_Name
(Argx
)
4596 or else not Is_Compilation_Unit
(Entity
(Argx
)))
4598 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
4601 -- No further check required if not an entity name
4603 if not Is_Entity_Name
(Argx
) then
4609 Ent
: constant Entity_Id
:= Entity
(Argx
);
4610 Scop
: constant Entity_Id
:= Scope
(Ent
);
4613 -- Case of a pragma applied to a compilation unit: pragma must
4614 -- occur immediately after the program unit in the compilation.
4616 if Is_Compilation_Unit
(Ent
) then
4618 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
4621 -- Case of pragma placed immediately after spec
4623 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
4626 -- Case of pragma placed immediately after body
4628 elsif Nkind
(Decl
) = N_Subprogram_Declaration
4629 and then Present
(Corresponding_Body
(Decl
))
4633 (Parent
(Unit_Declaration_Node
4634 (Corresponding_Body
(Decl
))));
4636 -- All other cases are illegal
4643 -- Special restricted placement rule from 10.2.1(11.8/2)
4645 elsif Is_Generic_Formal
(Ent
)
4646 and then Prag_Id
= Pragma_Preelaborable_Initialization
4648 OK
:= List_Containing
(N
) =
4649 Generic_Formal_Declarations
4650 (Unit_Declaration_Node
(Scop
));
4652 -- If this is an aspect applied to a subprogram body, the
4653 -- pragma is inserted in its declarative part.
4655 elsif From_Aspect_Specification
(N
)
4656 and then Ent
= Current_Scope
4658 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
4662 -- If the aspect is a predicate (possibly others ???) and the
4663 -- context is a record type, this is a discriminant expression
4664 -- within a type declaration, that freezes the predicated
4667 elsif From_Aspect_Specification
(N
)
4668 and then Prag_Id
= Pragma_Predicate
4669 and then Ekind
(Current_Scope
) = E_Record_Type
4670 and then Scop
= Scope
(Current_Scope
)
4674 -- Default case, just check that the pragma occurs in the scope
4675 -- of the entity denoted by the name.
4678 OK
:= Current_Scope
= Scop
;
4683 ("pragma% argument must be in same declarative part", Arg
);
4687 end Check_Arg_Is_Local_Name
;
4689 ---------------------------------
4690 -- Check_Arg_Is_Locking_Policy --
4691 ---------------------------------
4693 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
4694 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4697 Check_Arg_Is_Identifier
(Argx
);
4699 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
4700 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
4702 end Check_Arg_Is_Locking_Policy
;
4704 -----------------------------------------------
4705 -- Check_Arg_Is_Partition_Elaboration_Policy --
4706 -----------------------------------------------
4708 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
4709 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4712 Check_Arg_Is_Identifier
(Argx
);
4714 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
4716 ("& is not a valid partition elaboration policy name", Argx
);
4718 end Check_Arg_Is_Partition_Elaboration_Policy
;
4720 -------------------------
4721 -- Check_Arg_Is_One_Of --
4722 -------------------------
4724 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
4725 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4728 Check_Arg_Is_Identifier
(Argx
);
4730 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
4731 Error_Msg_Name_2
:= N1
;
4732 Error_Msg_Name_3
:= N2
;
4733 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
4735 end Check_Arg_Is_One_Of
;
4737 procedure Check_Arg_Is_One_Of
4739 N1
, N2
, N3
: Name_Id
)
4741 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4744 Check_Arg_Is_Identifier
(Argx
);
4746 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
4747 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4749 end Check_Arg_Is_One_Of
;
4751 procedure Check_Arg_Is_One_Of
4753 N1
, N2
, N3
, N4
: Name_Id
)
4755 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4758 Check_Arg_Is_Identifier
(Argx
);
4760 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
4761 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4763 end Check_Arg_Is_One_Of
;
4765 procedure Check_Arg_Is_One_Of
4767 N1
, N2
, N3
, N4
, N5
: Name_Id
)
4769 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4772 Check_Arg_Is_Identifier
(Argx
);
4774 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
4775 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
4777 end Check_Arg_Is_One_Of
;
4779 ---------------------------------
4780 -- Check_Arg_Is_Queuing_Policy --
4781 ---------------------------------
4783 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
4784 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4787 Check_Arg_Is_Identifier
(Argx
);
4789 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
4790 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
4792 end Check_Arg_Is_Queuing_Policy
;
4794 ---------------------------------------
4795 -- Check_Arg_Is_OK_Static_Expression --
4796 ---------------------------------------
4798 procedure Check_Arg_Is_OK_Static_Expression
4800 Typ
: Entity_Id
:= Empty
)
4803 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
4804 end Check_Arg_Is_OK_Static_Expression
;
4806 ------------------------------------------
4807 -- Check_Arg_Is_Task_Dispatching_Policy --
4808 ------------------------------------------
4810 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
4811 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4814 Check_Arg_Is_Identifier
(Argx
);
4816 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
4818 ("& is not an allowed task dispatching policy name", Argx
);
4820 end Check_Arg_Is_Task_Dispatching_Policy
;
4822 ---------------------
4823 -- Check_Arg_Order --
4824 ---------------------
4826 procedure Check_Arg_Order
(Names
: Name_List
) is
4829 Highest_So_Far
: Natural := 0;
4830 -- Highest index in Names seen do far
4834 for J
in 1 .. Arg_Count
loop
4835 if Chars
(Arg
) /= No_Name
then
4836 for K
in Names
'Range loop
4837 if Chars
(Arg
) = Names
(K
) then
4838 if K
< Highest_So_Far
then
4839 Error_Msg_Name_1
:= Pname
;
4841 ("parameters out of order for pragma%", Arg
);
4842 Error_Msg_Name_1
:= Names
(K
);
4843 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
4844 Error_Msg_N
("\% must appear before %", Arg
);
4848 Highest_So_Far
:= K
;
4856 end Check_Arg_Order
;
4858 --------------------------------
4859 -- Check_At_Least_N_Arguments --
4860 --------------------------------
4862 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
4864 if Arg_Count
< N
then
4865 Error_Pragma
("too few arguments for pragma%");
4867 end Check_At_Least_N_Arguments
;
4869 -------------------------------
4870 -- Check_At_Most_N_Arguments --
4871 -------------------------------
4873 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
4876 if Arg_Count
> N
then
4878 for J
in 1 .. N
loop
4880 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
4883 end Check_At_Most_N_Arguments
;
4885 ---------------------
4886 -- Check_Component --
4887 ---------------------
4889 procedure Check_Component
4892 In_Variant_Part
: Boolean := False)
4894 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
4895 Sindic
: constant Node_Id
:=
4896 Subtype_Indication
(Component_Definition
(Comp
));
4897 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
4900 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
4901 -- object constraint, then the component type shall be an Unchecked_
4904 if Nkind
(Sindic
) = N_Subtype_Indication
4905 and then Has_Per_Object_Constraint
(Comp_Id
)
4906 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
4909 ("component subtype subject to per-object constraint "
4910 & "must be an Unchecked_Union", Comp
);
4912 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
4913 -- the body of a generic unit, or within the body of any of its
4914 -- descendant library units, no part of the type of a component
4915 -- declared in a variant_part of the unchecked union type shall be of
4916 -- a formal private type or formal private extension declared within
4917 -- the formal part of the generic unit.
4919 elsif Ada_Version
>= Ada_2012
4920 and then In_Generic_Body
(UU_Typ
)
4921 and then In_Variant_Part
4922 and then Is_Private_Type
(Typ
)
4923 and then Is_Generic_Type
(Typ
)
4926 ("component of unchecked union cannot be of generic type", Comp
);
4928 elsif Needs_Finalization
(Typ
) then
4930 ("component of unchecked union cannot be controlled", Comp
);
4932 elsif Has_Task
(Typ
) then
4934 ("component of unchecked union cannot have tasks", Comp
);
4936 end Check_Component
;
4938 ----------------------------
4939 -- Check_Duplicate_Pragma --
4940 ----------------------------
4942 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
4943 Id
: Entity_Id
:= E
;
4947 -- Nothing to do if this pragma comes from an aspect specification,
4948 -- since we could not be duplicating a pragma, and we dealt with the
4949 -- case of duplicated aspects in Analyze_Aspect_Specifications.
4951 if From_Aspect_Specification
(N
) then
4955 -- Otherwise current pragma may duplicate previous pragma or a
4956 -- previously given aspect specification or attribute definition
4957 -- clause for the same pragma.
4959 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
4963 -- If the entity is a type, then we have to make sure that the
4964 -- ostensible duplicate is not for a parent type from which this
4968 if Nkind
(P
) = N_Pragma
then
4970 Args
: constant List_Id
:=
4971 Pragma_Argument_Associations
(P
);
4974 and then Is_Entity_Name
(Expression
(First
(Args
)))
4975 and then Is_Type
(Entity
(Expression
(First
(Args
))))
4976 and then Entity
(Expression
(First
(Args
))) /= E
4982 elsif Nkind
(P
) = N_Aspect_Specification
4983 and then Is_Type
(Entity
(P
))
4984 and then Entity
(P
) /= E
4990 -- Here we have a definite duplicate
4992 Error_Msg_Name_1
:= Pragma_Name
(N
);
4993 Error_Msg_Sloc
:= Sloc
(P
);
4995 -- For a single protected or a single task object, the error is
4996 -- issued on the original entity.
4998 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
4999 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5002 if Nkind
(P
) = N_Aspect_Specification
5003 or else From_Aspect_Specification
(P
)
5005 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5007 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5012 end Check_Duplicate_Pragma
;
5014 ----------------------------------
5015 -- Check_Duplicated_Export_Name --
5016 ----------------------------------
5018 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5019 String_Val
: constant String_Id
:= Strval
(Nam
);
5022 -- We are only interested in the export case, and in the case of
5023 -- generics, it is the instance, not the template, that is the
5024 -- problem (the template will generate a warning in any case).
5026 if not Inside_A_Generic
5027 and then (Prag_Id
= Pragma_Export
5029 Prag_Id
= Pragma_Export_Procedure
5031 Prag_Id
= Pragma_Export_Valued_Procedure
5033 Prag_Id
= Pragma_Export_Function
)
5035 for J
in Externals
.First
.. Externals
.Last
loop
5036 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5037 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5038 Error_Msg_N
("external name duplicates name given#", Nam
);
5043 Externals
.Append
(Nam
);
5045 end Check_Duplicated_Export_Name
;
5047 ----------------------------------------
5048 -- Check_Expr_Is_OK_Static_Expression --
5049 ----------------------------------------
5051 procedure Check_Expr_Is_OK_Static_Expression
5053 Typ
: Entity_Id
:= Empty
)
5056 if Present
(Typ
) then
5057 Analyze_And_Resolve
(Expr
, Typ
);
5059 Analyze_And_Resolve
(Expr
);
5062 if Is_OK_Static_Expression
(Expr
) then
5065 elsif Etype
(Expr
) = Any_Type
then
5068 -- An interesting special case, if we have a string literal and we
5069 -- are in Ada 83 mode, then we allow it even though it will not be
5070 -- flagged as static. This allows the use of Ada 95 pragmas like
5071 -- Import in Ada 83 mode. They will of course be flagged with
5072 -- warnings as usual, but will not cause errors.
5074 elsif Ada_Version
= Ada_83
5075 and then Nkind
(Expr
) = N_String_Literal
5079 -- Static expression that raises Constraint_Error. This has already
5080 -- been flagged, so just exit from pragma processing.
5082 elsif Is_OK_Static_Expression
(Expr
) then
5085 -- Finally, we have a real error
5088 Error_Msg_Name_1
:= Pname
;
5089 Flag_Non_Static_Expr
5090 (Fix_Error
("argument for pragma% must be a static expression!"),
5094 end Check_Expr_Is_OK_Static_Expression
;
5096 -------------------------
5097 -- Check_First_Subtype --
5098 -------------------------
5100 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5101 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5102 Ent
: constant Entity_Id
:= Entity
(Argx
);
5105 if Is_First_Subtype
(Ent
) then
5108 elsif Is_Type
(Ent
) then
5110 ("pragma% cannot apply to subtype", Argx
);
5112 elsif Is_Object
(Ent
) then
5114 ("pragma% cannot apply to object, requires a type", Argx
);
5118 ("pragma% cannot apply to&, requires a type", Argx
);
5120 end Check_First_Subtype
;
5122 ----------------------
5123 -- Check_Identifier --
5124 ----------------------
5126 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5129 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5131 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5132 Error_Msg_Name_1
:= Pname
;
5133 Error_Msg_Name_2
:= Id
;
5134 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5138 end Check_Identifier
;
5140 --------------------------------
5141 -- Check_Identifier_Is_One_Of --
5142 --------------------------------
5144 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5147 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5149 if Chars
(Arg
) = No_Name
then
5150 Error_Msg_Name_1
:= Pname
;
5151 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5154 elsif Chars
(Arg
) /= N1
5155 and then Chars
(Arg
) /= N2
5157 Error_Msg_Name_1
:= Pname
;
5158 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5162 end Check_Identifier_Is_One_Of
;
5164 ---------------------------
5165 -- Check_In_Main_Program --
5166 ---------------------------
5168 procedure Check_In_Main_Program
is
5169 P
: constant Node_Id
:= Parent
(N
);
5172 -- Must be in subprogram body
5174 if Nkind
(P
) /= N_Subprogram_Body
then
5175 Error_Pragma
("% pragma allowed only in subprogram");
5177 -- Otherwise warn if obviously not main program
5179 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5180 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5182 Error_Msg_Name_1
:= Pname
;
5184 ("??pragma% is only effective in main program", N
);
5186 end Check_In_Main_Program
;
5188 ---------------------------------------
5189 -- Check_Interrupt_Or_Attach_Handler --
5190 ---------------------------------------
5192 procedure Check_Interrupt_Or_Attach_Handler
is
5193 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5194 Handler_Proc
, Proc_Scope
: Entity_Id
;
5199 if Prag_Id
= Pragma_Interrupt_Handler
then
5200 Check_Restriction
(No_Dynamic_Attachment
, N
);
5203 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5204 Proc_Scope
:= Scope
(Handler_Proc
);
5206 -- On AAMP only, a pragma Interrupt_Handler is supported for
5207 -- nonprotected parameterless procedures.
5209 if not AAMP_On_Target
5210 or else Prag_Id
= Pragma_Attach_Handler
5212 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5214 ("argument of pragma% must be protected procedure", Arg1
);
5217 -- For pragma case (as opposed to access case), check placement.
5218 -- We don't need to do that for aspects, because we have the
5219 -- check that they aspect applies an appropriate procedure.
5221 if not From_Aspect_Specification
(N
)
5222 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5224 Error_Pragma
("pragma% must be in protected definition");
5228 if not Is_Library_Level_Entity
(Proc_Scope
)
5229 or else (AAMP_On_Target
5230 and then not Is_Library_Level_Entity
(Handler_Proc
))
5233 ("argument for pragma% must be library level entity", Arg1
);
5236 -- AI05-0033: A pragma cannot appear within a generic body, because
5237 -- instance can be in a nested scope. The check that protected type
5238 -- is itself a library-level declaration is done elsewhere.
5240 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5241 -- handle code prior to AI-0033. Analysis tools typically are not
5242 -- interested in this pragma in any case, so no need to worry too
5243 -- much about its placement.
5245 if Inside_A_Generic
then
5246 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5247 and then In_Package_Body
(Scope
(Current_Scope
))
5248 and then not Relaxed_RM_Semantics
5250 Error_Pragma
("pragma% cannot be used inside a generic");
5253 end Check_Interrupt_Or_Attach_Handler
;
5255 ---------------------------------
5256 -- Check_Loop_Pragma_Placement --
5257 ---------------------------------
5259 procedure Check_Loop_Pragma_Placement
is
5260 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5261 -- Verify whether the current pragma is properly grouped with other
5262 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5263 -- related loop where the pragma appears.
5265 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5266 -- Determine whether an arbitrary statement Stmt denotes pragma
5267 -- Loop_Invariant or Loop_Variant.
5269 procedure Placement_Error
(Constr
: Node_Id
);
5270 pragma No_Return
(Placement_Error
);
5271 -- Node Constr denotes the last loop restricted construct before we
5272 -- encountered an illegal relation between enclosing constructs. Emit
5273 -- an error depending on what Constr was.
5275 --------------------------------
5276 -- Check_Loop_Pragma_Grouping --
5277 --------------------------------
5279 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5280 Stop_Search
: exception;
5281 -- This exception is used to terminate the recursive descent of
5282 -- routine Check_Grouping.
5284 procedure Check_Grouping
(L
: List_Id
);
5285 -- Find the first group of pragmas in list L and if successful,
5286 -- ensure that the current pragma is part of that group. The
5287 -- routine raises Stop_Search once such a check is performed to
5288 -- halt the recursive descent.
5290 procedure Grouping_Error
(Prag
: Node_Id
);
5291 pragma No_Return
(Grouping_Error
);
5292 -- Emit an error concerning the current pragma indicating that it
5293 -- should be placed after pragma Prag.
5295 --------------------
5296 -- Check_Grouping --
5297 --------------------
5299 procedure Check_Grouping
(L
: List_Id
) is
5305 -- Inspect the list of declarations or statements looking for
5306 -- the first grouping of pragmas:
5309 -- pragma Loop_Invariant ...;
5310 -- pragma Loop_Variant ...;
5312 -- pragma Loop_Variant ...; -- current pragma
5314 -- If the current pragma is not in the grouping, then it must
5315 -- either appear in a different declarative or statement list
5316 -- or the construct at (1) is separating the pragma from the
5320 while Present
(Stmt
) loop
5322 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5323 -- inside a loop or a block housed inside a loop. Inspect
5324 -- the declarations and statements of the block as they may
5325 -- contain the first grouping.
5327 if Nkind
(Stmt
) = N_Block_Statement
then
5328 HSS
:= Handled_Statement_Sequence
(Stmt
);
5330 Check_Grouping
(Declarations
(Stmt
));
5332 if Present
(HSS
) then
5333 Check_Grouping
(Statements
(HSS
));
5336 -- First pragma of the first topmost grouping has been found
5338 elsif Is_Loop_Pragma
(Stmt
) then
5340 -- The group and the current pragma are not in the same
5341 -- declarative or statement list.
5343 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5344 Grouping_Error
(Stmt
);
5346 -- Try to reach the current pragma from the first pragma
5347 -- of the grouping while skipping other members:
5349 -- pragma Loop_Invariant ...; -- first pragma
5350 -- pragma Loop_Variant ...; -- member
5352 -- pragma Loop_Variant ...; -- current pragma
5355 while Present
(Stmt
) loop
5357 -- The current pragma is either the first pragma
5358 -- of the group or is a member of the group. Stop
5359 -- the search as the placement is legal.
5364 -- Skip group members, but keep track of the last
5365 -- pragma in the group.
5367 elsif Is_Loop_Pragma
(Stmt
) then
5370 -- Skip declarations and statements generated by
5371 -- the compiler during expansion.
5373 elsif not Comes_From_Source
(Stmt
) then
5376 -- A non-pragma is separating the group from the
5377 -- current pragma, the placement is illegal.
5380 Grouping_Error
(Prag
);
5386 -- If the traversal did not reach the current pragma,
5387 -- then the list must be malformed.
5389 raise Program_Error
;
5397 --------------------
5398 -- Grouping_Error --
5399 --------------------
5401 procedure Grouping_Error
(Prag
: Node_Id
) is
5403 Error_Msg_Sloc
:= Sloc
(Prag
);
5404 Error_Pragma
("pragma% must appear next to pragma#");
5407 -- Start of processing for Check_Loop_Pragma_Grouping
5410 -- Inspect the statements of the loop or nested blocks housed
5411 -- within to determine whether the current pragma is part of the
5412 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5414 Check_Grouping
(Statements
(Loop_Stmt
));
5417 when Stop_Search
=> null;
5418 end Check_Loop_Pragma_Grouping
;
5420 --------------------
5421 -- Is_Loop_Pragma --
5422 --------------------
5424 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5426 -- Inspect the original node as Loop_Invariant and Loop_Variant
5427 -- pragmas are rewritten to null when assertions are disabled.
5429 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5431 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
5432 Name_Loop_Invariant
,
5439 ---------------------
5440 -- Placement_Error --
5441 ---------------------
5443 procedure Placement_Error
(Constr
: Node_Id
) is
5444 LA
: constant String := " with Loop_Entry";
5447 if Prag_Id
= Pragma_Assert
then
5448 Error_Msg_String
(1 .. LA
'Length) := LA
;
5449 Error_Msg_Strlen
:= LA
'Length;
5451 Error_Msg_Strlen
:= 0;
5454 if Nkind
(Constr
) = N_Pragma
then
5456 ("pragma %~ must appear immediately within the statements "
5460 ("block containing pragma %~ must appear immediately within "
5461 & "the statements of a loop", Constr
);
5463 end Placement_Error
;
5465 -- Local declarations
5470 -- Start of processing for Check_Loop_Pragma_Placement
5473 -- Check that pragma appears immediately within a loop statement,
5474 -- ignoring intervening block statements.
5478 while Present
(Stmt
) loop
5480 -- The pragma or previous block must appear immediately within the
5481 -- current block's declarative or statement part.
5483 if Nkind
(Stmt
) = N_Block_Statement
then
5484 if (No
(Declarations
(Stmt
))
5485 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
5487 List_Containing
(Prev
) /=
5488 Statements
(Handled_Statement_Sequence
(Stmt
))
5490 Placement_Error
(Prev
);
5493 -- Keep inspecting the parents because we are now within a
5494 -- chain of nested blocks.
5498 Stmt
:= Parent
(Stmt
);
5501 -- The pragma or previous block must appear immediately within the
5502 -- statements of the loop.
5504 elsif Nkind
(Stmt
) = N_Loop_Statement
then
5505 if List_Containing
(Prev
) /= Statements
(Stmt
) then
5506 Placement_Error
(Prev
);
5509 -- Stop the traversal because we reached the innermost loop
5510 -- regardless of whether we encountered an error or not.
5514 -- Ignore a handled statement sequence. Note that this node may
5515 -- be related to a subprogram body in which case we will emit an
5516 -- error on the next iteration of the search.
5518 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
5519 Stmt
:= Parent
(Stmt
);
5521 -- Any other statement breaks the chain from the pragma to the
5525 Placement_Error
(Prev
);
5530 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5531 -- grouped together with other such pragmas.
5533 if Is_Loop_Pragma
(N
) then
5535 -- The previous check should have located the related loop
5537 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
5538 Check_Loop_Pragma_Grouping
(Stmt
);
5540 end Check_Loop_Pragma_Placement
;
5542 -------------------------------------------
5543 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5544 -------------------------------------------
5546 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
5555 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
5558 elsif Nkind_In
(P
, N_Package_Specification
,
5563 -- Note: the following tests seem a little peculiar, because
5564 -- they test for bodies, but if we were in the statement part
5565 -- of the body, we would already have hit the handled statement
5566 -- sequence, so the only way we get here is by being in the
5567 -- declarative part of the body.
5569 elsif Nkind_In
(P
, N_Subprogram_Body
,
5580 Error_Pragma
("pragma% is not in declarative part or package spec");
5581 end Check_Is_In_Decl_Part_Or_Package_Spec
;
5583 -------------------------
5584 -- Check_No_Identifier --
5585 -------------------------
5587 procedure Check_No_Identifier
(Arg
: Node_Id
) is
5589 if Nkind
(Arg
) = N_Pragma_Argument_Association
5590 and then Chars
(Arg
) /= No_Name
5592 Error_Pragma_Arg_Ident
5593 ("pragma% does not permit identifier& here", Arg
);
5595 end Check_No_Identifier
;
5597 --------------------------
5598 -- Check_No_Identifiers --
5599 --------------------------
5601 procedure Check_No_Identifiers
is
5605 for J
in 1 .. Arg_Count
loop
5606 Check_No_Identifier
(Arg_Node
);
5609 end Check_No_Identifiers
;
5611 ------------------------
5612 -- Check_No_Link_Name --
5613 ------------------------
5615 procedure Check_No_Link_Name
is
5617 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
5621 if Present
(Arg4
) then
5623 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
5625 end Check_No_Link_Name
;
5627 -------------------------------
5628 -- Check_Optional_Identifier --
5629 -------------------------------
5631 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5634 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5635 and then Chars
(Arg
) /= No_Name
5637 if Chars
(Arg
) /= Id
then
5638 Error_Msg_Name_1
:= Pname
;
5639 Error_Msg_Name_2
:= Id
;
5640 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5644 end Check_Optional_Identifier
;
5646 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
5648 Name_Buffer
(1 .. Id
'Length) := Id
;
5649 Name_Len
:= Id
'Length;
5650 Check_Optional_Identifier
(Arg
, Name_Find
);
5651 end Check_Optional_Identifier
;
5653 -------------------------------------
5654 -- Check_Static_Boolean_Expression --
5655 -------------------------------------
5657 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
5659 if Present
(Expr
) then
5660 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
5662 if not Is_OK_Static_Expression
(Expr
) then
5664 ("expression of pragma % must be static", Expr
);
5667 end Check_Static_Boolean_Expression
;
5669 -----------------------------
5670 -- Check_Static_Constraint --
5671 -----------------------------
5673 -- Note: for convenience in writing this procedure, in addition to
5674 -- the officially (i.e. by spec) allowed argument which is always a
5675 -- constraint, it also allows ranges and discriminant associations.
5676 -- Above is not clear ???
5678 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5680 procedure Require_Static
(E
: Node_Id
);
5681 -- Require given expression to be static expression
5683 --------------------
5684 -- Require_Static --
5685 --------------------
5687 procedure Require_Static
(E
: Node_Id
) is
5689 if not Is_OK_Static_Expression
(E
) then
5690 Flag_Non_Static_Expr
5691 ("non-static constraint not allowed in Unchecked_Union!", E
);
5696 -- Start of processing for Check_Static_Constraint
5699 case Nkind
(Constr
) is
5700 when N_Discriminant_Association
=>
5701 Require_Static
(Expression
(Constr
));
5704 Require_Static
(Low_Bound
(Constr
));
5705 Require_Static
(High_Bound
(Constr
));
5707 when N_Attribute_Reference
=>
5708 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
5709 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
5711 when N_Range_Constraint
=>
5712 Check_Static_Constraint
(Range_Expression
(Constr
));
5714 when N_Index_Or_Discriminant_Constraint
=>
5718 IDC
:= First
(Constraints
(Constr
));
5719 while Present
(IDC
) loop
5720 Check_Static_Constraint
(IDC
);
5728 end Check_Static_Constraint
;
5730 --------------------------------------
5731 -- Check_Valid_Configuration_Pragma --
5732 --------------------------------------
5734 -- A configuration pragma must appear in the context clause of a
5735 -- compilation unit, and only other pragmas may precede it. Note that
5736 -- the test also allows use in a configuration pragma file.
5738 procedure Check_Valid_Configuration_Pragma
is
5740 if not Is_Configuration_Pragma
then
5741 Error_Pragma
("incorrect placement for configuration pragma%");
5743 end Check_Valid_Configuration_Pragma
;
5745 -------------------------------------
5746 -- Check_Valid_Library_Unit_Pragma --
5747 -------------------------------------
5749 procedure Check_Valid_Library_Unit_Pragma
is
5751 Parent_Node
: Node_Id
;
5752 Unit_Name
: Entity_Id
;
5753 Unit_Kind
: Node_Kind
;
5754 Unit_Node
: Node_Id
;
5755 Sindex
: Source_File_Index
;
5758 if not Is_List_Member
(N
) then
5762 Plist
:= List_Containing
(N
);
5763 Parent_Node
:= Parent
(Plist
);
5765 if Parent_Node
= Empty
then
5768 -- Case of pragma appearing after a compilation unit. In this case
5769 -- it must have an argument with the corresponding name and must
5770 -- be part of the following pragmas of its parent.
5772 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
5773 if Plist
/= Pragmas_After
(Parent_Node
) then
5776 elsif Arg_Count
= 0 then
5778 ("argument required if outside compilation unit");
5781 Check_No_Identifiers
;
5782 Check_Arg_Count
(1);
5783 Unit_Node
:= Unit
(Parent
(Parent_Node
));
5784 Unit_Kind
:= Nkind
(Unit_Node
);
5786 Analyze
(Get_Pragma_Arg
(Arg1
));
5788 if Unit_Kind
= N_Generic_Subprogram_Declaration
5789 or else Unit_Kind
= N_Subprogram_Declaration
5791 Unit_Name
:= Defining_Entity
(Unit_Node
);
5793 elsif Unit_Kind
in N_Generic_Instantiation
then
5794 Unit_Name
:= Defining_Entity
(Unit_Node
);
5797 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
5800 if Chars
(Unit_Name
) /=
5801 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
5804 ("pragma% argument is not current unit name", Arg1
);
5807 if Ekind
(Unit_Name
) = E_Package
5808 and then Present
(Renamed_Entity
(Unit_Name
))
5810 Error_Pragma
("pragma% not allowed for renamed package");
5814 -- Pragma appears other than after a compilation unit
5817 -- Here we check for the generic instantiation case and also
5818 -- for the case of processing a generic formal package. We
5819 -- detect these cases by noting that the Sloc on the node
5820 -- does not belong to the current compilation unit.
5822 Sindex
:= Source_Index
(Current_Sem_Unit
);
5824 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
5825 Rewrite
(N
, Make_Null_Statement
(Loc
));
5828 -- If before first declaration, the pragma applies to the
5829 -- enclosing unit, and the name if present must be this name.
5831 elsif Is_Before_First_Decl
(N
, Plist
) then
5832 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
5833 Unit_Kind
:= Nkind
(Unit_Node
);
5835 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
5838 elsif Unit_Kind
= N_Subprogram_Body
5839 and then not Acts_As_Spec
(Unit_Node
)
5843 elsif Nkind
(Parent_Node
) = N_Package_Body
then
5846 elsif Nkind
(Parent_Node
) = N_Package_Specification
5847 and then Plist
= Private_Declarations
(Parent_Node
)
5851 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
5852 or else Nkind
(Parent_Node
) =
5853 N_Generic_Subprogram_Declaration
)
5854 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
5858 elsif Arg_Count
> 0 then
5859 Analyze
(Get_Pragma_Arg
(Arg1
));
5861 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
5863 ("name in pragma% must be enclosing unit", Arg1
);
5866 -- It is legal to have no argument in this context
5872 -- Error if not before first declaration. This is because a
5873 -- library unit pragma argument must be the name of a library
5874 -- unit (RM 10.1.5(7)), but the only names permitted in this
5875 -- context are (RM 10.1.5(6)) names of subprogram declarations,
5876 -- generic subprogram declarations or generic instantiations.
5880 ("pragma% misplaced, must be before first declaration");
5884 end Check_Valid_Library_Unit_Pragma
;
5890 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
5891 Clist
: constant Node_Id
:= Component_List
(Variant
);
5895 Comp
:= First
(Component_Items
(Clist
));
5896 while Present
(Comp
) loop
5897 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
5902 ---------------------------
5903 -- Ensure_Aggregate_Form --
5904 ---------------------------
5906 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
5907 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
5908 Expr
: constant Node_Id
:= Expression
(Arg
);
5909 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
5910 Comps
: List_Id
:= No_List
;
5911 Exprs
: List_Id
:= No_List
;
5912 Nam
: Name_Id
:= No_Name
;
5913 Nam_Loc
: Source_Ptr
;
5916 -- The pragma argument is in positional form:
5918 -- pragma Depends (Nam => ...)
5922 -- Note that the Sloc of the Chars field is the Sloc of the pragma
5923 -- argument association.
5925 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5927 Nam_Loc
:= Sloc
(Arg
);
5929 -- Remove the pragma argument name as this will be captured in the
5932 Set_Chars
(Arg
, No_Name
);
5935 -- The argument is already in aggregate form, but the presence of a
5936 -- name causes this to be interpreted as named association which in
5937 -- turn must be converted into an aggregate.
5939 -- pragma Global (In_Out => (A, B, C))
5943 -- pragma Global ((In_Out => (A, B, C)))
5945 -- aggregate aggregate
5947 if Nkind
(Expr
) = N_Aggregate
then
5948 if Nam
= No_Name
then
5952 -- Do not transform a null argument into an aggregate as N_Null has
5953 -- special meaning in formal verification pragmas.
5955 elsif Nkind
(Expr
) = N_Null
then
5959 -- Everything comes from source if the original comes from source
5961 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
5963 -- Positional argument is transformed into an aggregate with an
5964 -- Expressions list.
5966 if Nam
= No_Name
then
5967 Exprs
:= New_List
(Relocate_Node
(Expr
));
5969 -- An associative argument is transformed into an aggregate with
5970 -- Component_Associations.
5974 Make_Component_Association
(Loc
,
5975 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
5976 Expression
=> Relocate_Node
(Expr
)));
5979 Set_Expression
(Arg
,
5980 Make_Aggregate
(Loc
,
5981 Component_Associations
=> Comps
,
5982 Expressions
=> Exprs
));
5984 -- Restore Comes_From_Source default
5986 Set_Comes_From_Source_Default
(CFSD
);
5987 end Ensure_Aggregate_Form
;
5993 procedure Error_Pragma
(Msg
: String) is
5995 Error_Msg_Name_1
:= Pname
;
5996 Error_Msg_N
(Fix_Error
(Msg
), N
);
6000 ----------------------
6001 -- Error_Pragma_Arg --
6002 ----------------------
6004 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6006 Error_Msg_Name_1
:= Pname
;
6007 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6009 end Error_Pragma_Arg
;
6011 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6013 Error_Msg_Name_1
:= Pname
;
6014 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6015 Error_Pragma_Arg
(Msg2
, Arg
);
6016 end Error_Pragma_Arg
;
6018 ----------------------------
6019 -- Error_Pragma_Arg_Ident --
6020 ----------------------------
6022 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6024 Error_Msg_Name_1
:= Pname
;
6025 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6027 end Error_Pragma_Arg_Ident
;
6029 ----------------------
6030 -- Error_Pragma_Ref --
6031 ----------------------
6033 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6035 Error_Msg_Name_1
:= Pname
;
6036 Error_Msg_Sloc
:= Sloc
(Ref
);
6037 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6039 end Error_Pragma_Ref
;
6041 ------------------------
6042 -- Find_Lib_Unit_Name --
6043 ------------------------
6045 function Find_Lib_Unit_Name
return Entity_Id
is
6047 -- Return inner compilation unit entity, for case of nested
6048 -- categorization pragmas. This happens in generic unit.
6050 if Nkind
(Parent
(N
)) = N_Package_Specification
6051 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6053 return Defining_Entity
(Parent
(N
));
6055 return Current_Scope
;
6057 end Find_Lib_Unit_Name
;
6059 ----------------------------
6060 -- Find_Program_Unit_Name --
6061 ----------------------------
6063 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6064 Unit_Name
: Entity_Id
;
6065 Unit_Kind
: Node_Kind
;
6066 P
: constant Node_Id
:= Parent
(N
);
6069 if Nkind
(P
) = N_Compilation_Unit
then
6070 Unit_Kind
:= Nkind
(Unit
(P
));
6072 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6073 N_Package_Declaration
)
6074 or else Unit_Kind
in N_Generic_Declaration
6076 Unit_Name
:= Defining_Entity
(Unit
(P
));
6078 if Chars
(Id
) = Chars
(Unit_Name
) then
6079 Set_Entity
(Id
, Unit_Name
);
6080 Set_Etype
(Id
, Etype
(Unit_Name
));
6082 Set_Etype
(Id
, Any_Type
);
6084 ("cannot find program unit referenced by pragma%");
6088 Set_Etype
(Id
, Any_Type
);
6089 Error_Pragma
("pragma% inapplicable to this unit");
6095 end Find_Program_Unit_Name
;
6097 -----------------------------------------
6098 -- Find_Unique_Parameterless_Procedure --
6099 -----------------------------------------
6101 function Find_Unique_Parameterless_Procedure
6103 Arg
: Node_Id
) return Entity_Id
6105 Proc
: Entity_Id
:= Empty
;
6108 -- The body of this procedure needs some comments ???
6110 if not Is_Entity_Name
(Name
) then
6112 ("argument of pragma% must be entity name", Arg
);
6114 elsif not Is_Overloaded
(Name
) then
6115 Proc
:= Entity
(Name
);
6117 if Ekind
(Proc
) /= E_Procedure
6118 or else Present
(First_Formal
(Proc
))
6121 ("argument of pragma% must be parameterless procedure", Arg
);
6126 Found
: Boolean := False;
6128 Index
: Interp_Index
;
6131 Get_First_Interp
(Name
, Index
, It
);
6132 while Present
(It
.Nam
) loop
6135 if Ekind
(Proc
) = E_Procedure
6136 and then No
(First_Formal
(Proc
))
6140 Set_Entity
(Name
, Proc
);
6141 Set_Is_Overloaded
(Name
, False);
6144 ("ambiguous handler name for pragma% ", Arg
);
6148 Get_Next_Interp
(Index
, It
);
6153 ("argument of pragma% must be parameterless procedure",
6156 Proc
:= Entity
(Name
);
6162 end Find_Unique_Parameterless_Procedure
;
6168 function Fix_Error
(Msg
: String) return String is
6169 Res
: String (Msg
'Range) := Msg
;
6170 Res_Last
: Natural := Msg
'Last;
6174 -- If we have a rewriting of another pragma, go to that pragma
6176 if Is_Rewrite_Substitution
(N
)
6177 and then Nkind
(Original_Node
(N
)) = N_Pragma
6179 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6182 -- Case where pragma comes from an aspect specification
6184 if From_Aspect_Specification
(N
) then
6186 -- Change appearence of "pragma" in message to "aspect"
6189 while J
<= Res_Last
- 5 loop
6190 if Res
(J
.. J
+ 5) = "pragma" then
6191 Res
(J
.. J
+ 5) := "aspect";
6199 -- Change "argument of" at start of message to "entity for"
6202 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6204 Res
(Res
'First .. Res
'First + 9) := "entity for";
6205 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6206 Res
(Res
'First + 11 .. Res_Last
);
6207 Res_Last
:= Res_Last
- 1;
6210 -- Change "argument" at start of message to "entity"
6213 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6215 Res
(Res
'First .. Res
'First + 5) := "entity";
6216 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6217 Res
(Res
'First + 8 .. Res_Last
);
6218 Res_Last
:= Res_Last
- 2;
6221 -- Get name from corresponding aspect
6223 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6226 -- Return possibly modified message
6228 return Res
(Res
'First .. Res_Last
);
6231 -------------------------
6232 -- Gather_Associations --
6233 -------------------------
6235 procedure Gather_Associations
6237 Args
: out Args_List
)
6242 -- Initialize all parameters to Empty
6244 for J
in Args
'Range loop
6248 -- That's all we have to do if there are no argument associations
6250 if No
(Pragma_Argument_Associations
(N
)) then
6254 -- Otherwise first deal with any positional parameters present
6256 Arg
:= First
(Pragma_Argument_Associations
(N
));
6257 for Index
in Args
'Range loop
6258 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6259 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6263 -- Positional parameters all processed, if any left, then we
6264 -- have too many positional parameters.
6266 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6268 ("too many positional associations for pragma%", Arg
);
6271 -- Process named parameters if any are present
6273 while Present
(Arg
) loop
6274 if Chars
(Arg
) = No_Name
then
6276 ("positional association cannot follow named association",
6280 for Index
in Names
'Range loop
6281 if Names
(Index
) = Chars
(Arg
) then
6282 if Present
(Args
(Index
)) then
6284 ("duplicate argument association for pragma%", Arg
);
6286 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6291 if Index
= Names
'Last then
6292 Error_Msg_Name_1
:= Pname
;
6293 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6295 -- Check for possible misspelling
6297 for Index1
in Names
'Range loop
6298 if Is_Bad_Spelling_Of
6299 (Chars
(Arg
), Names
(Index1
))
6301 Error_Msg_Name_1
:= Names
(Index1
);
6302 Error_Msg_N
-- CODEFIX
6303 ("\possible misspelling of%", Arg
);
6315 end Gather_Associations
;
6321 procedure GNAT_Pragma
is
6323 -- We need to check the No_Implementation_Pragmas restriction for
6324 -- the case of a pragma from source. Note that the case of aspects
6325 -- generating corresponding pragmas marks these pragmas as not being
6326 -- from source, so this test also catches that case.
6328 if Comes_From_Source
(N
) then
6329 Check_Restriction
(No_Implementation_Pragmas
, N
);
6333 --------------------------
6334 -- Is_Before_First_Decl --
6335 --------------------------
6337 function Is_Before_First_Decl
6338 (Pragma_Node
: Node_Id
;
6339 Decls
: List_Id
) return Boolean
6341 Item
: Node_Id
:= First
(Decls
);
6344 -- Only other pragmas can come before this pragma
6347 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6350 elsif Item
= Pragma_Node
then
6356 end Is_Before_First_Decl
;
6358 -----------------------------
6359 -- Is_Configuration_Pragma --
6360 -----------------------------
6362 -- A configuration pragma must appear in the context clause of a
6363 -- compilation unit, and only other pragmas may precede it. Note that
6364 -- the test below also permits use in a configuration pragma file.
6366 function Is_Configuration_Pragma
return Boolean is
6367 Lis
: constant List_Id
:= List_Containing
(N
);
6368 Par
: constant Node_Id
:= Parent
(N
);
6372 -- If no parent, then we are in the configuration pragma file,
6373 -- so the placement is definitely appropriate.
6378 -- Otherwise we must be in the context clause of a compilation unit
6379 -- and the only thing allowed before us in the context list is more
6380 -- configuration pragmas.
6382 elsif Nkind
(Par
) = N_Compilation_Unit
6383 and then Context_Items
(Par
) = Lis
6390 elsif Nkind
(Prg
) /= N_Pragma
then
6400 end Is_Configuration_Pragma
;
6402 --------------------------
6403 -- Is_In_Context_Clause --
6404 --------------------------
6406 function Is_In_Context_Clause
return Boolean is
6408 Parent_Node
: Node_Id
;
6411 if not Is_List_Member
(N
) then
6415 Plist
:= List_Containing
(N
);
6416 Parent_Node
:= Parent
(Plist
);
6418 if Parent_Node
= Empty
6419 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6420 or else Context_Items
(Parent_Node
) /= Plist
6427 end Is_In_Context_Clause
;
6429 ---------------------------------
6430 -- Is_Static_String_Expression --
6431 ---------------------------------
6433 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6434 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6435 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6438 Analyze_And_Resolve
(Argx
);
6440 -- Special case Ada 83, where the expression will never be static,
6441 -- but we will return true if we had a string literal to start with.
6443 if Ada_Version
= Ada_83
then
6446 -- Normal case, true only if we end up with a string literal that
6447 -- is marked as being the result of evaluating a static expression.
6450 return Is_OK_Static_Expression
(Argx
)
6451 and then Nkind
(Argx
) = N_String_Literal
;
6454 end Is_Static_String_Expression
;
6456 ----------------------
6457 -- Pragma_Misplaced --
6458 ----------------------
6460 procedure Pragma_Misplaced
is
6462 Error_Pragma
("incorrect placement of pragma%");
6463 end Pragma_Misplaced
;
6465 ------------------------------------------------
6466 -- Process_Atomic_Independent_Shared_Volatile --
6467 ------------------------------------------------
6469 procedure Process_Atomic_Independent_Shared_Volatile
is
6470 procedure Set_Atomic_VFA
(E
: Entity_Id
);
6471 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6472 -- no explicit alignment was given, set alignment to unknown, since
6473 -- back end knows what the alignment requirements are for atomic and
6474 -- full access arrays. Note: this is necessary for derived types.
6476 --------------------
6477 -- Set_Atomic_VFA --
6478 --------------------
6480 procedure Set_Atomic_VFA
(E
: Entity_Id
) is
6482 if Prag_Id
= Pragma_Volatile_Full_Access
then
6483 Set_Is_Volatile_Full_Access
(E
);
6488 if not Has_Alignment_Clause
(E
) then
6489 Set_Alignment
(E
, Uint_0
);
6499 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6502 Check_Ada_83_Warning
;
6503 Check_No_Identifiers
;
6504 Check_Arg_Count
(1);
6505 Check_Arg_Is_Local_Name
(Arg1
);
6506 E_Arg
:= Get_Pragma_Arg
(Arg1
);
6508 if Etype
(E_Arg
) = Any_Type
then
6512 E
:= Entity
(E_Arg
);
6513 Decl
:= Declaration_Node
(E
);
6515 -- A pragma that applies to a Ghost entity becomes Ghost for the
6516 -- purposes of legality checks and removal of ignored Ghost code.
6518 Mark_Pragma_As_Ghost
(N
, E
);
6520 -- Check duplicate before we chain ourselves
6522 Check_Duplicate_Pragma
(E
);
6524 -- Check Atomic and VFA used together
6526 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
6527 or else (Is_Volatile_Full_Access
(E
)
6528 and then (Prag_Id
= Pragma_Atomic
6530 Prag_Id
= Pragma_Shared
))
6533 ("cannot have Volatile_Full_Access and Atomic for same entity");
6536 -- Check for applying VFA to an entity which has aliased component
6538 if Prag_Id
= Pragma_Volatile_Full_Access
then
6541 Aliased_Comp
: Boolean := False;
6542 -- Set True if aliased component present
6545 if Is_Array_Type
(Etype
(E
)) then
6546 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
6548 -- Record case, too bad Has_Aliased_Components is not also
6549 -- set for records, should it be ???
6551 elsif Is_Record_Type
(Etype
(E
)) then
6552 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
6553 while Present
(Comp
) loop
6554 if Is_Aliased
(Comp
)
6555 or else Is_Aliased
(Etype
(Comp
))
6557 Aliased_Comp
:= True;
6561 Next_Component_Or_Discriminant
(Comp
);
6565 if Aliased_Comp
then
6567 ("cannot apply Volatile_Full_Access (aliased component "
6573 -- Now check appropriateness of the entity
6576 if Rep_Item_Too_Early
(E
, N
)
6578 Rep_Item_Too_Late
(E
, N
)
6582 Check_First_Subtype
(Arg1
);
6585 -- Attribute belongs on the base type. If the view of the type is
6586 -- currently private, it also belongs on the underlying type.
6588 if Prag_Id
= Pragma_Atomic
6590 Prag_Id
= Pragma_Shared
6592 Prag_Id
= Pragma_Volatile_Full_Access
6595 Set_Atomic_VFA
(Base_Type
(E
));
6596 Set_Atomic_VFA
(Underlying_Type
(E
));
6599 -- Atomic/Shared/Volatile_Full_Access imply Independent
6601 if Prag_Id
/= Pragma_Volatile
then
6602 Set_Is_Independent
(E
);
6603 Set_Is_Independent
(Base_Type
(E
));
6604 Set_Is_Independent
(Underlying_Type
(E
));
6606 if Prag_Id
= Pragma_Independent
then
6607 Record_Independence_Check
(N
, Base_Type
(E
));
6611 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6613 if Prag_Id
/= Pragma_Independent
then
6614 Set_Is_Volatile
(E
);
6615 Set_Is_Volatile
(Base_Type
(E
));
6616 Set_Is_Volatile
(Underlying_Type
(E
));
6618 Set_Treat_As_Volatile
(E
);
6619 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6622 elsif Nkind
(Decl
) = N_Object_Declaration
6623 or else (Nkind
(Decl
) = N_Component_Declaration
6624 and then Original_Record_Component
(E
) = E
)
6626 if Rep_Item_Too_Late
(E
, N
) then
6630 if Prag_Id
= Pragma_Atomic
6632 Prag_Id
= Pragma_Shared
6634 Prag_Id
= Pragma_Volatile_Full_Access
6636 if Prag_Id
= Pragma_Volatile_Full_Access
then
6637 Set_Is_Volatile_Full_Access
(E
);
6642 -- If the object declaration has an explicit initialization, a
6643 -- temporary may have to be created to hold the expression, to
6644 -- ensure that access to the object remain atomic.
6646 if Nkind
(Parent
(E
)) = N_Object_Declaration
6647 and then Present
(Expression
(Parent
(E
)))
6649 Set_Has_Delayed_Freeze
(E
);
6653 -- Atomic/Shared/Volatile_Full_Access imply Independent
6655 if Prag_Id
/= Pragma_Volatile
then
6656 Set_Is_Independent
(E
);
6658 if Prag_Id
= Pragma_Independent
then
6659 Record_Independence_Check
(N
, E
);
6663 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6665 if Prag_Id
/= Pragma_Independent
then
6666 Set_Is_Volatile
(E
);
6667 Set_Treat_As_Volatile
(E
);
6671 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6674 -- The following check is only relevant when SPARK_Mode is on as
6675 -- this is not a standard Ada legality rule. Pragma Volatile can
6676 -- only apply to a full type declaration or an object declaration
6677 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6678 -- untagged derived types that are rewritten as subtypes of their
6679 -- respective root types.
6682 and then Prag_Id
= Pragma_Volatile
6684 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
6685 N_Object_Declaration
)
6688 ("argument of pragma % must denote a full type or object "
6689 & "declaration", Arg1
);
6691 end Process_Atomic_Independent_Shared_Volatile
;
6693 -------------------------------------------
6694 -- Process_Compile_Time_Warning_Or_Error --
6695 -------------------------------------------
6697 procedure Process_Compile_Time_Warning_Or_Error
is
6698 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6701 Check_Arg_Count
(2);
6702 Check_No_Identifiers
;
6703 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
6704 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
6706 if Compile_Time_Known_Value
(Arg1x
) then
6707 if Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg1
))) then
6709 Str
: constant String_Id
:=
6710 Strval
(Get_Pragma_Arg
(Arg2
));
6711 Len
: constant Nat
:= String_Length
(Str
);
6716 Cent
: constant Entity_Id
:=
6717 Cunit_Entity
(Current_Sem_Unit
);
6719 Force
: constant Boolean :=
6720 Prag_Id
= Pragma_Compile_Time_Warning
6722 Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
6723 and then (Ekind
(Cent
) /= E_Package
6724 or else not In_Private_Part
(Cent
));
6725 -- Set True if this is the warning case, and we are in the
6726 -- visible part of a package spec, or in a subprogram spec,
6727 -- in which case we want to force the client to see the
6728 -- warning, even though it is not in the main unit.
6731 -- Loop through segments of message separated by line feeds.
6732 -- We output these segments as separate messages with
6733 -- continuation marks for all but the first.
6738 Error_Msg_Strlen
:= 0;
6740 -- Loop to copy characters from argument to error message
6744 exit when Ptr
> Len
;
6745 CC
:= Get_String_Char
(Str
, Ptr
);
6748 -- Ignore wide chars ??? else store character
6750 if In_Character_Range
(CC
) then
6751 C
:= Get_Character
(CC
);
6752 exit when C
= ASCII
.LF
;
6753 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
6754 Error_Msg_String
(Error_Msg_Strlen
) := C
;
6758 -- Here with one line ready to go
6760 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
6762 -- If this is a warning in a spec, then we want clients
6763 -- to see the warning, so mark the message with the
6764 -- special sequence !! to force the warning. In the case
6765 -- of a package spec, we do not force this if we are in
6766 -- the private part of the spec.
6769 if Cont
= False then
6770 Error_Msg_N
("<<~!!", Arg1
);
6773 Error_Msg_N
("\<<~!!", Arg1
);
6776 -- Error, rather than warning, or in a body, so we do not
6777 -- need to force visibility for client (error will be
6778 -- output in any case, and this is the situation in which
6779 -- we do not want a client to get a warning, since the
6780 -- warning is in the body or the spec private part).
6783 if Cont
= False then
6784 Error_Msg_N
("<<~", Arg1
);
6787 Error_Msg_N
("\<<~", Arg1
);
6791 exit when Ptr
> Len
;
6796 end Process_Compile_Time_Warning_Or_Error
;
6798 ------------------------
6799 -- Process_Convention --
6800 ------------------------
6802 procedure Process_Convention
6803 (C
: out Convention_Id
;
6804 Ent
: out Entity_Id
)
6808 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
6809 -- Called if we have more than one Export/Import/Convention pragma.
6810 -- This is generally illegal, but we have a special case of allowing
6811 -- Import and Interface to coexist if they specify the convention in
6812 -- a consistent manner. We are allowed to do this, since Interface is
6813 -- an implementation defined pragma, and we choose to do it since we
6814 -- know Rational allows this combination. S is the entity id of the
6815 -- subprogram in question. This procedure also sets the special flag
6816 -- Import_Interface_Present in both pragmas in the case where we do
6817 -- have matching Import and Interface pragmas.
6819 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
6820 -- Set convention in entity E, and also flag that the entity has a
6821 -- convention pragma. If entity is for a private or incomplete type,
6822 -- also set convention and flag on underlying type. This procedure
6823 -- also deals with the special case of C_Pass_By_Copy convention,
6824 -- and error checks for inappropriate convention specification.
6826 -------------------------------
6827 -- Diagnose_Multiple_Pragmas --
6828 -------------------------------
6830 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
6831 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
6835 function Same_Convention
(Decl
: Node_Id
) return Boolean;
6836 -- Decl is a pragma node. This function returns True if this
6837 -- pragma has a first argument that is an identifier with a
6838 -- Chars field corresponding to the Convention_Id C.
6840 function Same_Name
(Decl
: Node_Id
) return Boolean;
6841 -- Decl is a pragma node. This function returns True if this
6842 -- pragma has a second argument that is an identifier with a
6843 -- Chars field that matches the Chars of the current subprogram.
6845 ---------------------
6846 -- Same_Convention --
6847 ---------------------
6849 function Same_Convention
(Decl
: Node_Id
) return Boolean is
6850 Arg1
: constant Node_Id
:=
6851 First
(Pragma_Argument_Associations
(Decl
));
6854 if Present
(Arg1
) then
6856 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
6858 if Nkind
(Arg
) = N_Identifier
6859 and then Is_Convention_Name
(Chars
(Arg
))
6860 and then Get_Convention_Id
(Chars
(Arg
)) = C
6868 end Same_Convention
;
6874 function Same_Name
(Decl
: Node_Id
) return Boolean is
6875 Arg1
: constant Node_Id
:=
6876 First
(Pragma_Argument_Associations
(Decl
));
6884 Arg2
:= Next
(Arg1
);
6891 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
6893 if Nkind
(Arg
) = N_Identifier
6894 and then Chars
(Arg
) = Chars
(S
)
6903 -- Start of processing for Diagnose_Multiple_Pragmas
6908 -- Definitely give message if we have Convention/Export here
6910 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
6913 -- If we have an Import or Export, scan back from pragma to
6914 -- find any previous pragma applying to the same procedure.
6915 -- The scan will be terminated by the start of the list, or
6916 -- hitting the subprogram declaration. This won't allow one
6917 -- pragma to appear in the public part and one in the private
6918 -- part, but that seems very unlikely in practice.
6922 while Present
(Decl
) and then Decl
/= Pdec
loop
6924 -- Look for pragma with same name as us
6926 if Nkind
(Decl
) = N_Pragma
6927 and then Same_Name
(Decl
)
6929 -- Give error if same as our pragma or Export/Convention
6931 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
6937 -- Case of Import/Interface or the other way round
6939 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
6942 -- Here we know that we have Import and Interface. It
6943 -- doesn't matter which way round they are. See if
6944 -- they specify the same convention. If so, all OK,
6945 -- and set special flags to stop other messages
6947 if Same_Convention
(Decl
) then
6948 Set_Import_Interface_Present
(N
);
6949 Set_Import_Interface_Present
(Decl
);
6952 -- If different conventions, special message
6955 Error_Msg_Sloc
:= Sloc
(Decl
);
6957 ("convention differs from that given#", Arg1
);
6967 -- Give message if needed if we fall through those tests
6968 -- except on Relaxed_RM_Semantics where we let go: either this
6969 -- is a case accepted/ignored by other Ada compilers (e.g.
6970 -- a mix of Convention and Import), or another error will be
6971 -- generated later (e.g. using both Import and Export).
6973 if Err
and not Relaxed_RM_Semantics
then
6975 ("at most one Convention/Export/Import pragma is allowed",
6978 end Diagnose_Multiple_Pragmas
;
6980 --------------------------------
6981 -- Set_Convention_From_Pragma --
6982 --------------------------------
6984 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
6986 -- Ada 2005 (AI-430): Check invalid attempt to change convention
6987 -- for an overridden dispatching operation. Technically this is
6988 -- an amendment and should only be done in Ada 2005 mode. However,
6989 -- this is clearly a mistake, since the problem that is addressed
6990 -- by this AI is that there is a clear gap in the RM.
6992 if Is_Dispatching_Operation
(E
)
6993 and then Present
(Overridden_Operation
(E
))
6994 and then C
/= Convention
(Overridden_Operation
(E
))
6997 ("cannot change convention for overridden dispatching "
6998 & "operation", Arg1
);
7001 -- Special checks for Convention_Stdcall
7003 if C
= Convention_Stdcall
then
7005 -- A dispatching call is not allowed. A dispatching subprogram
7006 -- cannot be used to interface to the Win32 API, so in fact
7007 -- this check does not impose any effective restriction.
7009 if Is_Dispatching_Operation
(E
) then
7010 Error_Msg_Sloc
:= Sloc
(E
);
7012 -- Note: make this unconditional so that if there is more
7013 -- than one call to which the pragma applies, we get a
7014 -- message for each call. Also don't use Error_Pragma,
7015 -- so that we get multiple messages.
7018 ("dispatching subprogram# cannot use Stdcall convention!",
7021 -- Subprograms are not allowed
7023 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
7027 and then Ekind
(E
) /= E_Variable
7029 -- An access to subprogram is also allowed
7033 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7035 -- Allow internal call to set convention of subprogram type
7037 and then not (Ekind
(E
) = E_Subprogram_Type
)
7040 ("second argument of pragma% must be subprogram (type)",
7045 -- Set the convention
7047 Set_Convention
(E
, C
);
7048 Set_Has_Convention_Pragma
(E
);
7050 -- For the case of a record base type, also set the convention of
7051 -- any anonymous access types declared in the record which do not
7052 -- currently have a specified convention.
7054 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7059 Comp
:= First_Component
(E
);
7060 while Present
(Comp
) loop
7061 if Present
(Etype
(Comp
))
7062 and then Ekind_In
(Etype
(Comp
),
7063 E_Anonymous_Access_Type
,
7064 E_Anonymous_Access_Subprogram_Type
)
7065 and then not Has_Convention_Pragma
(Comp
)
7067 Set_Convention
(Comp
, C
);
7070 Next_Component
(Comp
);
7075 -- Deal with incomplete/private type case, where underlying type
7076 -- is available, so set convention of that underlying type.
7078 if Is_Incomplete_Or_Private_Type
(E
)
7079 and then Present
(Underlying_Type
(E
))
7081 Set_Convention
(Underlying_Type
(E
), C
);
7082 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7085 -- A class-wide type should inherit the convention of the specific
7086 -- root type (although this isn't specified clearly by the RM).
7088 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7089 Set_Convention
(Class_Wide_Type
(E
), C
);
7092 -- If the entity is a record type, then check for special case of
7093 -- C_Pass_By_Copy, which is treated the same as C except that the
7094 -- special record flag is set. This convention is only permitted
7095 -- on record types (see AI95-00131).
7097 if Cname
= Name_C_Pass_By_Copy
then
7098 if Is_Record_Type
(E
) then
7099 Set_C_Pass_By_Copy
(Base_Type
(E
));
7100 elsif Is_Incomplete_Or_Private_Type
(E
)
7101 and then Is_Record_Type
(Underlying_Type
(E
))
7103 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7106 ("C_Pass_By_Copy convention allowed only for record type",
7111 -- If the entity is a derived boolean type, check for the special
7112 -- case of convention C, C++, or Fortran, where we consider any
7113 -- nonzero value to represent true.
7115 if Is_Discrete_Type
(E
)
7116 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7122 C
= Convention_Fortran
)
7124 Set_Nonzero_Is_True
(Base_Type
(E
));
7126 end Set_Convention_From_Pragma
;
7130 Comp_Unit
: Unit_Number_Type
;
7135 -- Start of processing for Process_Convention
7138 Check_At_Least_N_Arguments
(2);
7139 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7140 Check_Arg_Is_Identifier
(Arg1
);
7141 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7143 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7144 -- tested again below to set the critical flag).
7146 if Cname
= Name_C_Pass_By_Copy
then
7149 -- Otherwise we must have something in the standard convention list
7151 elsif Is_Convention_Name
(Cname
) then
7152 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7154 -- Otherwise warn on unrecognized convention
7157 if Warn_On_Export_Import
then
7159 ("??unrecognized convention name, C assumed",
7160 Get_Pragma_Arg
(Arg1
));
7166 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7167 Check_Arg_Is_Local_Name
(Arg2
);
7169 Id
:= Get_Pragma_Arg
(Arg2
);
7172 if not Is_Entity_Name
(Id
) then
7173 Error_Pragma_Arg
("entity name required", Arg2
);
7178 -- Set entity to return
7182 -- Ada_Pass_By_Copy special checking
7184 if C
= Convention_Ada_Pass_By_Copy
then
7185 if not Is_First_Subtype
(E
) then
7187 ("convention `Ada_Pass_By_Copy` only allowed for types",
7191 if Is_By_Reference_Type
(E
) then
7193 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7197 -- Ada_Pass_By_Reference special checking
7199 elsif C
= Convention_Ada_Pass_By_Reference
then
7200 if not Is_First_Subtype
(E
) then
7202 ("convention `Ada_Pass_By_Reference` only allowed for types",
7206 if Is_By_Copy_Type
(E
) then
7208 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7213 -- Go to renamed subprogram if present, since convention applies to
7214 -- the actual renamed entity, not to the renaming entity. If the
7215 -- subprogram is inherited, go to parent subprogram.
7217 if Is_Subprogram
(E
)
7218 and then Present
(Alias
(E
))
7220 if Nkind
(Parent
(Declaration_Node
(E
))) =
7221 N_Subprogram_Renaming_Declaration
7223 if Scope
(E
) /= Scope
(Alias
(E
)) then
7225 ("cannot apply pragma% to non-local entity&#", E
);
7230 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7231 N_Private_Extension_Declaration
)
7232 and then Scope
(E
) = Scope
(Alias
(E
))
7236 -- Return the parent subprogram the entity was inherited from
7242 -- Check that we are not applying this to a specless body. Relax this
7243 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7245 if Is_Subprogram
(E
)
7246 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7247 and then not Relaxed_RM_Semantics
7250 ("pragma% requires separate spec and must come before body");
7253 -- Check that we are not applying this to a named constant
7255 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7256 Error_Msg_Name_1
:= Pname
;
7258 ("cannot apply pragma% to named constant!",
7259 Get_Pragma_Arg
(Arg2
));
7261 ("\supply appropriate type for&!", Arg2
);
7264 if Ekind
(E
) = E_Enumeration_Literal
then
7265 Error_Pragma
("enumeration literal not allowed for pragma%");
7268 -- Check for rep item appearing too early or too late
7270 if Etype
(E
) = Any_Type
7271 or else Rep_Item_Too_Early
(E
, N
)
7275 elsif Present
(Underlying_Type
(E
)) then
7276 E
:= Underlying_Type
(E
);
7279 if Rep_Item_Too_Late
(E
, N
) then
7283 if Has_Convention_Pragma
(E
) then
7284 Diagnose_Multiple_Pragmas
(E
);
7286 elsif Convention
(E
) = Convention_Protected
7287 or else Ekind
(Scope
(E
)) = E_Protected_Type
7290 ("a protected operation cannot be given a different convention",
7294 -- For Intrinsic, a subprogram is required
7296 if C
= Convention_Intrinsic
7297 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7299 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7301 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7303 ("second argument of pragma% must be a subprogram", Arg2
);
7307 -- Deal with non-subprogram cases
7309 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7310 Set_Convention_From_Pragma
(E
);
7314 -- The pragma must apply to a first subtype, but it can also
7315 -- apply to a generic type in a generic formal part, in which
7316 -- case it will also appear in the corresponding instance.
7318 if Is_Generic_Type
(E
) or else In_Instance
then
7321 Check_First_Subtype
(Arg2
);
7324 Set_Convention_From_Pragma
(Base_Type
(E
));
7326 -- For access subprograms, we must set the convention on the
7327 -- internally generated directly designated type as well.
7329 if Ekind
(E
) = E_Access_Subprogram_Type
then
7330 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7334 -- For the subprogram case, set proper convention for all homonyms
7335 -- in same scope and the same declarative part, i.e. the same
7336 -- compilation unit.
7339 Comp_Unit
:= Get_Source_Unit
(E
);
7340 Set_Convention_From_Pragma
(E
);
7342 -- Treat a pragma Import as an implicit body, and pragma import
7343 -- as implicit reference (for navigation in GPS).
7345 if Prag_Id
= Pragma_Import
then
7346 Generate_Reference
(E
, Id
, 'b');
7348 -- For exported entities we restrict the generation of references
7349 -- to entities exported to foreign languages since entities
7350 -- exported to Ada do not provide further information to GPS and
7351 -- add undesired references to the output of the gnatxref tool.
7353 elsif Prag_Id
= Pragma_Export
7354 and then Convention
(E
) /= Convention_Ada
7356 Generate_Reference
(E
, Id
, 'i');
7359 -- If the pragma comes from an aspect, it only applies to the
7360 -- given entity, not its homonyms.
7362 if From_Aspect_Specification
(N
) then
7366 -- Otherwise Loop through the homonyms of the pragma argument's
7367 -- entity, an apply convention to those in the current scope.
7373 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7375 -- Ignore entry for which convention is already set
7377 if Has_Convention_Pragma
(E1
) then
7381 -- Do not set the pragma on inherited operations or on formal
7384 if Comes_From_Source
(E1
)
7385 and then Comp_Unit
= Get_Source_Unit
(E1
)
7386 and then not Is_Formal_Subprogram
(E1
)
7387 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7388 N_Full_Type_Declaration
7390 if Present
(Alias
(E1
))
7391 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7394 ("cannot apply pragma% to non-local entity& declared#",
7398 Set_Convention_From_Pragma
(E1
);
7400 if Prag_Id
= Pragma_Import
then
7401 Generate_Reference
(E1
, Id
, 'b');
7409 end Process_Convention
;
7411 ----------------------------------------
7412 -- Process_Disable_Enable_Atomic_Sync --
7413 ----------------------------------------
7415 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7417 Check_No_Identifiers
;
7418 Check_At_Most_N_Arguments
(1);
7420 -- Modeled internally as
7421 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7425 Pragma_Identifier
=>
7426 Make_Identifier
(Loc
, Nam
),
7427 Pragma_Argument_Associations
=> New_List
(
7428 Make_Pragma_Argument_Association
(Loc
,
7430 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7432 if Present
(Arg1
) then
7433 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7437 end Process_Disable_Enable_Atomic_Sync
;
7439 -------------------------------------------------
7440 -- Process_Extended_Import_Export_Internal_Arg --
7441 -------------------------------------------------
7443 procedure Process_Extended_Import_Export_Internal_Arg
7444 (Arg_Internal
: Node_Id
:= Empty
)
7447 if No
(Arg_Internal
) then
7448 Error_Pragma
("Internal parameter required for pragma%");
7451 if Nkind
(Arg_Internal
) = N_Identifier
then
7454 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7455 and then (Prag_Id
= Pragma_Import_Function
7457 Prag_Id
= Pragma_Export_Function
)
7463 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7466 Check_Arg_Is_Local_Name
(Arg_Internal
);
7467 end Process_Extended_Import_Export_Internal_Arg
;
7469 --------------------------------------------------
7470 -- Process_Extended_Import_Export_Object_Pragma --
7471 --------------------------------------------------
7473 procedure Process_Extended_Import_Export_Object_Pragma
7474 (Arg_Internal
: Node_Id
;
7475 Arg_External
: Node_Id
;
7481 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7482 Def_Id
:= Entity
(Arg_Internal
);
7484 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7486 ("pragma% must designate an object", Arg_Internal
);
7489 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7491 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7494 ("previous Common/Psect_Object applies, pragma % not permitted",
7498 if Rep_Item_Too_Late
(Def_Id
, N
) then
7502 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7504 if Present
(Arg_Size
) then
7505 Check_Arg_Is_External_Name
(Arg_Size
);
7508 -- Export_Object case
7510 if Prag_Id
= Pragma_Export_Object
then
7511 if not Is_Library_Level_Entity
(Def_Id
) then
7513 ("argument for pragma% must be library level entity",
7517 if Ekind
(Current_Scope
) = E_Generic_Package
then
7518 Error_Pragma
("pragma& cannot appear in a generic unit");
7521 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7523 ("exported object must have compile time known size",
7527 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7528 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7530 Set_Exported
(Def_Id
, Arg_Internal
);
7533 -- Import_Object case
7536 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7538 ("cannot use pragma% for task/protected object",
7542 if Ekind
(Def_Id
) = E_Constant
then
7544 ("cannot import a constant", Arg_Internal
);
7547 if Warn_On_Export_Import
7548 and then Has_Discriminants
(Etype
(Def_Id
))
7551 ("imported value must be initialized??", Arg_Internal
);
7554 if Warn_On_Export_Import
7555 and then Is_Access_Type
(Etype
(Def_Id
))
7558 ("cannot import object of an access type??", Arg_Internal
);
7561 if Warn_On_Export_Import
7562 and then Is_Imported
(Def_Id
)
7564 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7566 -- Check for explicit initialization present. Note that an
7567 -- initialization generated by the code generator, e.g. for an
7568 -- access type, does not count here.
7570 elsif Present
(Expression
(Parent
(Def_Id
)))
7573 (Original_Node
(Expression
(Parent
(Def_Id
))))
7575 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7577 ("imported entities cannot be initialized (RM B.1(24))",
7578 "\no initialization allowed for & declared#", Arg1
);
7580 Set_Imported
(Def_Id
);
7581 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7584 end Process_Extended_Import_Export_Object_Pragma
;
7586 ------------------------------------------------------
7587 -- Process_Extended_Import_Export_Subprogram_Pragma --
7588 ------------------------------------------------------
7590 procedure Process_Extended_Import_Export_Subprogram_Pragma
7591 (Arg_Internal
: Node_Id
;
7592 Arg_External
: Node_Id
;
7593 Arg_Parameter_Types
: Node_Id
;
7594 Arg_Result_Type
: Node_Id
:= Empty
;
7595 Arg_Mechanism
: Node_Id
;
7596 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7602 Ambiguous
: Boolean;
7605 function Same_Base_Type
7607 Formal
: Entity_Id
) return Boolean;
7608 -- Determines if Ptype references the type of Formal. Note that only
7609 -- the base types need to match according to the spec. Ptype here is
7610 -- the argument from the pragma, which is either a type name, or an
7611 -- access attribute.
7613 --------------------
7614 -- Same_Base_Type --
7615 --------------------
7617 function Same_Base_Type
7619 Formal
: Entity_Id
) return Boolean
7621 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7625 -- Case where pragma argument is typ'Access
7627 if Nkind
(Ptype
) = N_Attribute_Reference
7628 and then Attribute_Name
(Ptype
) = Name_Access
7630 Pref
:= Prefix
(Ptype
);
7633 if not Is_Entity_Name
(Pref
)
7634 or else Entity
(Pref
) = Any_Type
7639 -- We have a match if the corresponding argument is of an
7640 -- anonymous access type, and its designated type matches the
7641 -- type of the prefix of the access attribute
7643 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7644 and then Base_Type
(Entity
(Pref
)) =
7645 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7647 -- Case where pragma argument is a type name
7652 if not Is_Entity_Name
(Ptype
)
7653 or else Entity
(Ptype
) = Any_Type
7658 -- We have a match if the corresponding argument is of the type
7659 -- given in the pragma (comparing base types)
7661 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7665 -- Start of processing for
7666 -- Process_Extended_Import_Export_Subprogram_Pragma
7669 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7673 -- Loop through homonyms (overloadings) of the entity
7675 Hom_Id
:= Entity
(Arg_Internal
);
7676 while Present
(Hom_Id
) loop
7677 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7679 -- We need a subprogram in the current scope
7681 if not Is_Subprogram
(Def_Id
)
7682 or else Scope
(Def_Id
) /= Current_Scope
7689 -- Pragma cannot apply to subprogram body
7691 if Is_Subprogram
(Def_Id
)
7692 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7696 ("pragma% requires separate spec"
7697 & " and must come before body");
7700 -- Test result type if given, note that the result type
7701 -- parameter can only be present for the function cases.
7703 if Present
(Arg_Result_Type
)
7704 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7708 elsif Etype
(Def_Id
) /= Standard_Void_Type
7710 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7714 -- Test parameter types if given. Note that this parameter
7715 -- has not been analyzed (and must not be, since it is
7716 -- semantic nonsense), so we get it as the parser left it.
7718 elsif Present
(Arg_Parameter_Types
) then
7719 Check_Matching_Types
: declare
7724 Formal
:= First_Formal
(Def_Id
);
7726 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7727 if Present
(Formal
) then
7731 -- A list of one type, e.g. (List) is parsed as
7732 -- a parenthesized expression.
7734 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
7735 and then Paren_Count
(Arg_Parameter_Types
) = 1
7738 or else Present
(Next_Formal
(Formal
))
7743 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
7746 -- A list of more than one type is parsed as a aggregate
7748 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
7749 and then Paren_Count
(Arg_Parameter_Types
) = 0
7751 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
7752 while Present
(Ptype
) or else Present
(Formal
) loop
7755 or else not Same_Base_Type
(Ptype
, Formal
)
7760 Next_Formal
(Formal
);
7765 -- Anything else is of the wrong form
7769 ("wrong form for Parameter_Types parameter",
7770 Arg_Parameter_Types
);
7772 end Check_Matching_Types
;
7775 -- Match is now False if the entry we found did not match
7776 -- either a supplied Parameter_Types or Result_Types argument
7782 -- Ambiguous case, the flag Ambiguous shows if we already
7783 -- detected this and output the initial messages.
7786 if not Ambiguous
then
7788 Error_Msg_Name_1
:= Pname
;
7790 ("pragma% does not uniquely identify subprogram!",
7792 Error_Msg_Sloc
:= Sloc
(Ent
);
7793 Error_Msg_N
("matching subprogram #!", N
);
7797 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7798 Error_Msg_N
("matching subprogram #!", N
);
7803 Hom_Id
:= Homonym
(Hom_Id
);
7806 -- See if we found an entry
7809 if not Ambiguous
then
7810 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
7812 ("pragma% cannot be given for generic subprogram");
7815 ("pragma% does not identify local subprogram");
7822 -- Import pragmas must be for imported entities
7824 if Prag_Id
= Pragma_Import_Function
7826 Prag_Id
= Pragma_Import_Procedure
7828 Prag_Id
= Pragma_Import_Valued_Procedure
7830 if not Is_Imported
(Ent
) then
7832 ("pragma Import or Interface must precede pragma%");
7835 -- Here we have the Export case which can set the entity as exported
7837 -- But does not do so if the specified external name is null, since
7838 -- that is taken as a signal in DEC Ada 83 (with which we want to be
7839 -- compatible) to request no external name.
7841 elsif Nkind
(Arg_External
) = N_String_Literal
7842 and then String_Length
(Strval
(Arg_External
)) = 0
7846 -- In all other cases, set entity as exported
7849 Set_Exported
(Ent
, Arg_Internal
);
7852 -- Special processing for Valued_Procedure cases
7854 if Prag_Id
= Pragma_Import_Valued_Procedure
7856 Prag_Id
= Pragma_Export_Valued_Procedure
7858 Formal
:= First_Formal
(Ent
);
7861 Error_Pragma
("at least one parameter required for pragma%");
7863 elsif Ekind
(Formal
) /= E_Out_Parameter
then
7864 Error_Pragma
("first parameter must have mode out for pragma%");
7867 Set_Is_Valued_Procedure
(Ent
);
7871 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
7873 -- Process Result_Mechanism argument if present. We have already
7874 -- checked that this is only allowed for the function case.
7876 if Present
(Arg_Result_Mechanism
) then
7877 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
7880 -- Process Mechanism parameter if present. Note that this parameter
7881 -- is not analyzed, and must not be analyzed since it is semantic
7882 -- nonsense, so we get it in exactly as the parser left it.
7884 if Present
(Arg_Mechanism
) then
7892 -- A single mechanism association without a formal parameter
7893 -- name is parsed as a parenthesized expression. All other
7894 -- cases are parsed as aggregates, so we rewrite the single
7895 -- parameter case as an aggregate for consistency.
7897 if Nkind
(Arg_Mechanism
) /= N_Aggregate
7898 and then Paren_Count
(Arg_Mechanism
) = 1
7900 Rewrite
(Arg_Mechanism
,
7901 Make_Aggregate
(Sloc
(Arg_Mechanism
),
7902 Expressions
=> New_List
(
7903 Relocate_Node
(Arg_Mechanism
))));
7906 -- Case of only mechanism name given, applies to all formals
7908 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
7909 Formal
:= First_Formal
(Ent
);
7910 while Present
(Formal
) loop
7911 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
7912 Next_Formal
(Formal
);
7915 -- Case of list of mechanism associations given
7918 if Null_Record_Present
(Arg_Mechanism
) then
7920 ("inappropriate form for Mechanism parameter",
7924 -- Deal with positional ones first
7926 Formal
:= First_Formal
(Ent
);
7928 if Present
(Expressions
(Arg_Mechanism
)) then
7929 Mname
:= First
(Expressions
(Arg_Mechanism
));
7930 while Present
(Mname
) loop
7933 ("too many mechanism associations", Mname
);
7936 Set_Mechanism_Value
(Formal
, Mname
);
7937 Next_Formal
(Formal
);
7942 -- Deal with named entries
7944 if Present
(Component_Associations
(Arg_Mechanism
)) then
7945 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
7946 while Present
(Massoc
) loop
7947 Choice
:= First
(Choices
(Massoc
));
7949 if Nkind
(Choice
) /= N_Identifier
7950 or else Present
(Next
(Choice
))
7953 ("incorrect form for mechanism association",
7957 Formal
:= First_Formal
(Ent
);
7961 ("parameter name & not present", Choice
);
7964 if Chars
(Choice
) = Chars
(Formal
) then
7966 (Formal
, Expression
(Massoc
));
7968 -- Set entity on identifier (needed by ASIS)
7970 Set_Entity
(Choice
, Formal
);
7975 Next_Formal
(Formal
);
7984 end Process_Extended_Import_Export_Subprogram_Pragma
;
7986 --------------------------
7987 -- Process_Generic_List --
7988 --------------------------
7990 procedure Process_Generic_List
is
7995 Check_No_Identifiers
;
7996 Check_At_Least_N_Arguments
(1);
7998 -- Check all arguments are names of generic units or instances
8001 while Present
(Arg
) loop
8002 Exp
:= Get_Pragma_Arg
(Arg
);
8005 if not Is_Entity_Name
(Exp
)
8007 (not Is_Generic_Instance
(Entity
(Exp
))
8009 not Is_Generic_Unit
(Entity
(Exp
)))
8012 ("pragma% argument must be name of generic unit/instance",
8018 end Process_Generic_List
;
8020 ------------------------------------
8021 -- Process_Import_Predefined_Type --
8022 ------------------------------------
8024 procedure Process_Import_Predefined_Type
is
8025 Loc
: constant Source_Ptr
:= Sloc
(N
);
8027 Ftyp
: Node_Id
:= Empty
;
8033 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
8036 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8037 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8041 Ftyp
:= Node
(Elmt
);
8043 if Present
(Ftyp
) then
8045 -- Don't build a derived type declaration, because predefined C
8046 -- types have no declaration anywhere, so cannot really be named.
8047 -- Instead build a full type declaration, starting with an
8048 -- appropriate type definition is built
8050 if Is_Floating_Point_Type
(Ftyp
) then
8051 Def
:= Make_Floating_Point_Definition
(Loc
,
8052 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8053 Make_Real_Range_Specification
(Loc
,
8054 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8055 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8057 -- Should never have a predefined type we cannot handle
8060 raise Program_Error
;
8063 -- Build and insert a Full_Type_Declaration, which will be
8064 -- analyzed as soon as this list entry has been analyzed.
8066 Decl
:= Make_Full_Type_Declaration
(Loc
,
8067 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8068 Type_Definition
=> Def
);
8070 Insert_After
(N
, Decl
);
8071 Mark_Rewrite_Insertion
(Decl
);
8074 Error_Pragma_Arg
("no matching type found for pragma%",
8077 end Process_Import_Predefined_Type
;
8079 ---------------------------------
8080 -- Process_Import_Or_Interface --
8081 ---------------------------------
8083 procedure Process_Import_Or_Interface
is
8089 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8090 -- pragma Import (Entity, "external name");
8092 if Relaxed_RM_Semantics
8093 and then Arg_Count
= 2
8094 and then Prag_Id
= Pragma_Import
8095 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8098 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8101 if not Is_Entity_Name
(Def_Id
) then
8102 Error_Pragma_Arg
("entity name required", Arg1
);
8105 Def_Id
:= Entity
(Def_Id
);
8106 Kill_Size_Check_Code
(Def_Id
);
8107 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8110 Process_Convention
(C
, Def_Id
);
8112 -- A pragma that applies to a Ghost entity becomes Ghost for the
8113 -- purposes of legality checks and removal of ignored Ghost code.
8115 Mark_Pragma_As_Ghost
(N
, Def_Id
);
8116 Kill_Size_Check_Code
(Def_Id
);
8117 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8120 -- Various error checks
8122 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8124 -- We do not permit Import to apply to a renaming declaration
8126 if Present
(Renamed_Object
(Def_Id
)) then
8128 ("pragma% not allowed for object renaming", Arg2
);
8130 -- User initialization is not allowed for imported object, but
8131 -- the object declaration may contain a default initialization,
8132 -- that will be discarded. Note that an explicit initialization
8133 -- only counts if it comes from source, otherwise it is simply
8134 -- the code generator making an implicit initialization explicit.
8136 elsif Present
(Expression
(Parent
(Def_Id
)))
8137 and then Comes_From_Source
8138 (Original_Node
(Expression
(Parent
(Def_Id
))))
8140 -- Set imported flag to prevent cascaded errors
8142 Set_Is_Imported
(Def_Id
);
8144 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8146 ("no initialization allowed for declaration of& #",
8147 "\imported entities cannot be initialized (RM B.1(24))",
8151 -- If the pragma comes from an aspect specification the
8152 -- Is_Imported flag has already been set.
8154 if not From_Aspect_Specification
(N
) then
8155 Set_Imported
(Def_Id
);
8158 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8160 -- Note that we do not set Is_Public here. That's because we
8161 -- only want to set it if there is no address clause, and we
8162 -- don't know that yet, so we delay that processing till
8165 -- pragma Import completes deferred constants
8167 if Ekind
(Def_Id
) = E_Constant
then
8168 Set_Has_Completion
(Def_Id
);
8171 -- It is not possible to import a constant of an unconstrained
8172 -- array type (e.g. string) because there is no simple way to
8173 -- write a meaningful subtype for it.
8175 if Is_Array_Type
(Etype
(Def_Id
))
8176 and then not Is_Constrained
(Etype
(Def_Id
))
8179 ("imported constant& must have a constrained subtype",
8184 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8186 -- If the name is overloaded, pragma applies to all of the denoted
8187 -- entities in the same declarative part, unless the pragma comes
8188 -- from an aspect specification or was generated by the compiler
8189 -- (such as for pragma Provide_Shift_Operators).
8192 while Present
(Hom_Id
) loop
8194 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8196 -- Ignore inherited subprograms because the pragma will apply
8197 -- to the parent operation, which is the one called.
8199 if Is_Overloadable
(Def_Id
)
8200 and then Present
(Alias
(Def_Id
))
8204 -- If it is not a subprogram, it must be in an outer scope and
8205 -- pragma does not apply.
8207 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8210 -- The pragma does not apply to primitives of interfaces
8212 elsif Is_Dispatching_Operation
(Def_Id
)
8213 and then Present
(Find_Dispatching_Type
(Def_Id
))
8214 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8218 -- Verify that the homonym is in the same declarative part (not
8219 -- just the same scope). If the pragma comes from an aspect
8220 -- specification we know that it is part of the declaration.
8222 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8223 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8224 and then not From_Aspect_Specification
(N
)
8229 -- If the pragma comes from an aspect specification the
8230 -- Is_Imported flag has already been set.
8232 if not From_Aspect_Specification
(N
) then
8233 Set_Imported
(Def_Id
);
8236 -- Reject an Import applied to an abstract subprogram
8238 if Is_Subprogram
(Def_Id
)
8239 and then Is_Abstract_Subprogram
(Def_Id
)
8241 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8243 ("cannot import abstract subprogram& declared#",
8247 -- Special processing for Convention_Intrinsic
8249 if C
= Convention_Intrinsic
then
8251 -- Link_Name argument not allowed for intrinsic
8255 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8257 -- If no external name is present, then check that this
8258 -- is a valid intrinsic subprogram. If an external name
8259 -- is present, then this is handled by the back end.
8262 Check_Intrinsic_Subprogram
8263 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8267 -- Verify that the subprogram does not have a completion
8268 -- through a renaming declaration. For other completions the
8269 -- pragma appears as a too late representation.
8272 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8276 and then Nkind
(Decl
) = N_Subprogram_Declaration
8277 and then Present
(Corresponding_Body
(Decl
))
8278 and then Nkind
(Unit_Declaration_Node
8279 (Corresponding_Body
(Decl
))) =
8280 N_Subprogram_Renaming_Declaration
8282 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8284 ("cannot import&, renaming already provided for "
8285 & "declaration #", N
, Def_Id
);
8289 -- If the pragma comes from an aspect specification, there
8290 -- must be an Import aspect specified as well. In the rare
8291 -- case where Import is set to False, the suprogram needs to
8292 -- have a local completion.
8295 Imp_Aspect
: constant Node_Id
:=
8296 Find_Aspect
(Def_Id
, Aspect_Import
);
8300 if Present
(Imp_Aspect
)
8301 and then Present
(Expression
(Imp_Aspect
))
8303 Expr
:= Expression
(Imp_Aspect
);
8304 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8306 if Is_Entity_Name
(Expr
)
8307 and then Entity
(Expr
) = Standard_True
8309 Set_Has_Completion
(Def_Id
);
8312 -- If there is no expression, the default is True, as for
8313 -- all boolean aspects. Same for the older pragma.
8316 Set_Has_Completion
(Def_Id
);
8320 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8323 if Is_Compilation_Unit
(Hom_Id
) then
8325 -- Its possible homonyms are not affected by the pragma.
8326 -- Such homonyms might be present in the context of other
8327 -- units being compiled.
8331 elsif From_Aspect_Specification
(N
) then
8334 -- If the pragma was created by the compiler, then we don't
8335 -- want it to apply to other homonyms. This kind of case can
8336 -- occur when using pragma Provide_Shift_Operators, which
8337 -- generates implicit shift and rotate operators with Import
8338 -- pragmas that might apply to earlier explicit or implicit
8339 -- declarations marked with Import (for example, coming from
8340 -- an earlier pragma Provide_Shift_Operators for another type),
8341 -- and we don't generally want other homonyms being treated
8342 -- as imported or the pragma flagged as an illegal duplicate.
8344 elsif not Comes_From_Source
(N
) then
8348 Hom_Id
:= Homonym
(Hom_Id
);
8352 -- Import a CPP class
8354 elsif C
= Convention_CPP
8355 and then (Is_Record_Type
(Def_Id
)
8356 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8358 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8359 if Present
(Full_View
(Def_Id
)) then
8360 Def_Id
:= Full_View
(Def_Id
);
8364 ("cannot import 'C'P'P type before full declaration seen",
8365 Get_Pragma_Arg
(Arg2
));
8367 -- Although we have reported the error we decorate it as
8368 -- CPP_Class to avoid reporting spurious errors
8370 Set_Is_CPP_Class
(Def_Id
);
8375 -- Types treated as CPP classes must be declared limited (note:
8376 -- this used to be a warning but there is no real benefit to it
8377 -- since we did effectively intend to treat the type as limited
8380 if not Is_Limited_Type
(Def_Id
) then
8382 ("imported 'C'P'P type must be limited",
8383 Get_Pragma_Arg
(Arg2
));
8386 if Etype
(Def_Id
) /= Def_Id
8387 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8389 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8392 Set_Is_CPP_Class
(Def_Id
);
8394 -- Imported CPP types must not have discriminants (because C++
8395 -- classes do not have discriminants).
8397 if Has_Discriminants
(Def_Id
) then
8399 ("imported 'C'P'P type cannot have discriminants",
8400 First
(Discriminant_Specifications
8401 (Declaration_Node
(Def_Id
))));
8404 -- Check that components of imported CPP types do not have default
8405 -- expressions. For private types this check is performed when the
8406 -- full view is analyzed (see Process_Full_View).
8408 if not Is_Private_Type
(Def_Id
) then
8409 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8412 -- Import a CPP exception
8414 elsif C
= Convention_CPP
8415 and then Ekind
(Def_Id
) = E_Exception
8419 ("'External_'Name arguments is required for 'Cpp exception",
8422 -- As only a string is allowed, Check_Arg_Is_External_Name
8425 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8428 if Present
(Arg4
) then
8430 ("Link_Name argument not allowed for imported Cpp exception",
8434 -- Do not call Set_Interface_Name as the name of the exception
8435 -- shouldn't be modified (and in particular it shouldn't be
8436 -- the External_Name). For exceptions, the External_Name is the
8437 -- name of the RTTI structure.
8439 -- ??? Emit an error if pragma Import/Export_Exception is present
8441 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8443 Check_Arg_Count
(3);
8444 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8446 Process_Import_Predefined_Type
;
8450 ("second argument of pragma% must be object, subprogram "
8451 & "or incomplete type",
8455 -- If this pragma applies to a compilation unit, then the unit, which
8456 -- is a subprogram, does not require (or allow) a body. We also do
8457 -- not need to elaborate imported procedures.
8459 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8461 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8463 Set_Body_Required
(Cunit
, False);
8466 end Process_Import_Or_Interface
;
8468 --------------------
8469 -- Process_Inline --
8470 --------------------
8472 procedure Process_Inline
(Status
: Inline_Status
) is
8479 Ghost_Error_Posted
: Boolean := False;
8480 -- Flag set when an error concerning the illegal mix of Ghost and
8481 -- non-Ghost subprograms is emitted.
8483 Ghost_Id
: Entity_Id
:= Empty
;
8484 -- The entity of the first Ghost subprogram encountered while
8485 -- processing the arguments of the pragma.
8487 procedure Make_Inline
(Subp
: Entity_Id
);
8488 -- Subp is the defining unit name of the subprogram declaration. Set
8489 -- the flag, as well as the flag in the corresponding body, if there
8492 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8493 -- Sets Is_Inlined and Has_Pragma_Inline flags for Subp and also
8494 -- Has_Pragma_Inline_Always for the Inline_Always case.
8496 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8497 -- Returns True if it can be determined at this stage that inlining
8498 -- is not possible, for example if the body is available and contains
8499 -- exception handlers, we prevent inlining, since otherwise we can
8500 -- get undefined symbols at link time. This function also emits a
8501 -- warning if front-end inlining is enabled and the pragma appears
8504 -- ??? is business with link symbols still valid, or does it relate
8505 -- to front end ZCX which is being phased out ???
8507 ---------------------------
8508 -- Inlining_Not_Possible --
8509 ---------------------------
8511 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8512 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8516 if Nkind
(Decl
) = N_Subprogram_Body
then
8517 Stats
:= Handled_Statement_Sequence
(Decl
);
8518 return Present
(Exception_Handlers
(Stats
))
8519 or else Present
(At_End_Proc
(Stats
));
8521 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8522 and then Present
(Corresponding_Body
(Decl
))
8524 if Front_End_Inlining
8525 and then Analyzed
(Corresponding_Body
(Decl
))
8527 Error_Msg_N
("pragma appears too late, ignored??", N
);
8530 -- If the subprogram is a renaming as body, the body is just a
8531 -- call to the renamed subprogram, and inlining is trivially
8535 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8536 N_Subprogram_Renaming_Declaration
8542 Handled_Statement_Sequence
8543 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8546 Present
(Exception_Handlers
(Stats
))
8547 or else Present
(At_End_Proc
(Stats
));
8551 -- If body is not available, assume the best, the check is
8552 -- performed again when compiling enclosing package bodies.
8556 end Inlining_Not_Possible
;
8562 procedure Make_Inline
(Subp
: Entity_Id
) is
8563 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8564 Inner_Subp
: Entity_Id
:= Subp
;
8567 -- Ignore if bad type, avoid cascaded error
8569 if Etype
(Subp
) = Any_Type
then
8573 -- If inlining is not possible, for now do not treat as an error
8575 elsif Status
/= Suppressed
8576 and then Inlining_Not_Possible
(Subp
)
8581 -- Here we have a candidate for inlining, but we must exclude
8582 -- derived operations. Otherwise we would end up trying to inline
8583 -- a phantom declaration, and the result would be to drag in a
8584 -- body which has no direct inlining associated with it. That
8585 -- would not only be inefficient but would also result in the
8586 -- backend doing cross-unit inlining in cases where it was
8587 -- definitely inappropriate to do so.
8589 -- However, a simple Comes_From_Source test is insufficient, since
8590 -- we do want to allow inlining of generic instances which also do
8591 -- not come from source. We also need to recognize specs generated
8592 -- by the front-end for bodies that carry the pragma. Finally,
8593 -- predefined operators do not come from source but are not
8594 -- inlineable either.
8596 elsif Is_Generic_Instance
(Subp
)
8597 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8601 elsif not Comes_From_Source
(Subp
)
8602 and then Scope
(Subp
) /= Standard_Standard
8608 -- The referenced entity must either be the enclosing entity, or
8609 -- an entity declared within the current open scope.
8611 if Present
(Scope
(Subp
))
8612 and then Scope
(Subp
) /= Current_Scope
8613 and then Subp
/= Current_Scope
8616 ("argument of% must be entity in current scope", Assoc
);
8620 -- Processing for procedure, operator or function. If subprogram
8621 -- is aliased (as for an instance) indicate that the renamed
8622 -- entity (if declared in the same unit) is inlined.
8623 -- If this is the anonymous subprogram created for a subprogram
8624 -- instance, the inlining applies to it directly. Otherwise we
8625 -- retrieve it as the alias of the visible subprogram instance.
8627 if Is_Subprogram
(Subp
) then
8628 if Is_Wrapper_Package
(Scope
(Subp
)) then
8631 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8634 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8635 Set_Inline_Flags
(Inner_Subp
);
8637 Decl
:= Parent
(Parent
(Inner_Subp
));
8639 if Nkind
(Decl
) = N_Subprogram_Declaration
8640 and then Present
(Corresponding_Body
(Decl
))
8642 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8644 elsif Is_Generic_Instance
(Subp
)
8645 and then Comes_From_Source
(Subp
)
8647 -- Indicate that the body needs to be created for
8648 -- inlining subsequent calls. The instantiation node
8649 -- follows the declaration of the wrapper package
8650 -- created for it. The subprogram that requires the
8651 -- body is the anonymous one in the wrapper package.
8653 if Scope
(Subp
) /= Standard_Standard
8655 Need_Subprogram_Instance_Body
8656 (Next
(Unit_Declaration_Node
8657 (Scope
(Alias
(Subp
)))), Subp
)
8662 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8663 -- appear in a formal part to apply to a formal subprogram.
8664 -- Do not apply check within an instance or a formal package
8665 -- the test will have been applied to the original generic.
8667 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8668 and then List_Containing
(Decl
) = List_Containing
(N
)
8669 and then not In_Instance
8672 ("Inline cannot apply to a formal subprogram", N
);
8674 -- If Subp is a renaming, it is the renamed entity that
8675 -- will appear in any call, and be inlined. However, for
8676 -- ASIS uses it is convenient to indicate that the renaming
8677 -- itself is an inlined subprogram, so that some gnatcheck
8678 -- rules can be applied in the absence of expansion.
8680 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8681 Set_Inline_Flags
(Subp
);
8687 -- For a generic subprogram set flag as well, for use at the point
8688 -- of instantiation, to determine whether the body should be
8691 elsif Is_Generic_Subprogram
(Subp
) then
8692 Set_Inline_Flags
(Subp
);
8695 -- Literals are by definition inlined
8697 elsif Kind
= E_Enumeration_Literal
then
8700 -- Anything else is an error
8704 ("expect subprogram name for pragma%", Assoc
);
8708 ----------------------
8709 -- Set_Inline_Flags --
8710 ----------------------
8712 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8714 -- First set the Has_Pragma_XXX flags and issue the appropriate
8715 -- errors and warnings for suspicious combinations.
8717 if Prag_Id
= Pragma_No_Inline
then
8718 if Has_Pragma_Inline_Always
(Subp
) then
8720 ("Inline_Always and No_Inline are mutually exclusive", N
);
8721 elsif Has_Pragma_Inline
(Subp
) then
8723 ("Inline and No_Inline both specified for& ??",
8724 N
, Entity
(Subp_Id
));
8727 Set_Has_Pragma_No_Inline
(Subp
);
8729 if Prag_Id
= Pragma_Inline_Always
then
8730 if Has_Pragma_No_Inline
(Subp
) then
8732 ("Inline_Always and No_Inline are mutually exclusive",
8736 Set_Has_Pragma_Inline_Always
(Subp
);
8738 if Has_Pragma_No_Inline
(Subp
) then
8740 ("Inline and No_Inline both specified for& ??",
8741 N
, Entity
(Subp_Id
));
8745 if not Has_Pragma_Inline
(Subp
) then
8746 Set_Has_Pragma_Inline
(Subp
);
8750 -- Then adjust the Is_Inlined flag. It can never be set if the
8751 -- subprogram is subject to pragma No_Inline.
8755 Set_Is_Inlined
(Subp
, False);
8759 if not Has_Pragma_No_Inline
(Subp
) then
8760 Set_Is_Inlined
(Subp
, True);
8764 -- A pragma that applies to a Ghost entity becomes Ghost for the
8765 -- purposes of legality checks and removal of ignored Ghost code.
8767 Mark_Pragma_As_Ghost
(N
, Subp
);
8769 -- Capture the entity of the first Ghost subprogram being
8770 -- processed for error detection purposes.
8772 if Is_Ghost_Entity
(Subp
) then
8773 if No
(Ghost_Id
) then
8777 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
8778 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
8780 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
8781 Ghost_Error_Posted
:= True;
8783 Error_Msg_Name_1
:= Pname
;
8785 ("pragma % cannot mention ghost and non-ghost subprograms",
8788 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
8789 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
8791 Error_Msg_Sloc
:= Sloc
(Subp
);
8792 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
8794 end Set_Inline_Flags
;
8796 -- Start of processing for Process_Inline
8799 Check_No_Identifiers
;
8800 Check_At_Least_N_Arguments
(1);
8802 if Status
= Enabled
then
8803 Inline_Processing_Required
:= True;
8807 while Present
(Assoc
) loop
8808 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
8812 if Is_Entity_Name
(Subp_Id
) then
8813 Subp
:= Entity
(Subp_Id
);
8815 if Subp
= Any_Id
then
8817 -- If previous error, avoid cascaded errors
8819 Check_Error_Detected
;
8825 -- For the pragma case, climb homonym chain. This is
8826 -- what implements allowing the pragma in the renaming
8827 -- case, with the result applying to the ancestors, and
8828 -- also allows Inline to apply to all previous homonyms.
8830 if not From_Aspect_Specification
(N
) then
8831 while Present
(Homonym
(Subp
))
8832 and then Scope
(Homonym
(Subp
)) = Current_Scope
8834 Make_Inline
(Homonym
(Subp
));
8835 Subp
:= Homonym
(Subp
);
8842 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
8849 ----------------------------
8850 -- Process_Interface_Name --
8851 ----------------------------
8853 procedure Process_Interface_Name
8854 (Subprogram_Def
: Entity_Id
;
8860 String_Val
: String_Id
;
8862 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
8863 -- SN is a string literal node for an interface name. This routine
8864 -- performs some minimal checks that the name is reasonable. In
8865 -- particular that no spaces or other obviously incorrect characters
8866 -- appear. This is only a warning, since any characters are allowed.
8868 ----------------------------------
8869 -- Check_Form_Of_Interface_Name --
8870 ----------------------------------
8872 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
8873 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
8874 SL
: constant Nat
:= String_Length
(S
);
8879 Error_Msg_N
("interface name cannot be null string", SN
);
8882 for J
in 1 .. SL
loop
8883 C
:= Get_String_Char
(S
, J
);
8885 -- Look for dubious character and issue unconditional warning.
8886 -- Definitely dubious if not in character range.
8888 if not In_Character_Range
(C
)
8890 -- Commas, spaces and (back)slashes are dubious
8892 or else Get_Character
(C
) = ','
8893 or else Get_Character
(C
) = '\'
8894 or else Get_Character
(C
) = ' '
8895 or else Get_Character
(C
) = '/'
8898 ("??interface name contains illegal character",
8899 Sloc
(SN
) + Source_Ptr
(J
));
8902 end Check_Form_Of_Interface_Name
;
8904 -- Start of processing for Process_Interface_Name
8907 if No
(Link_Arg
) then
8908 if No
(Ext_Arg
) then
8911 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
8913 Link_Nam
:= Expression
(Ext_Arg
);
8916 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8917 Ext_Nam
:= Expression
(Ext_Arg
);
8922 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
8923 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
8924 Ext_Nam
:= Expression
(Ext_Arg
);
8925 Link_Nam
:= Expression
(Link_Arg
);
8928 -- Check expressions for external name and link name are static
8930 if Present
(Ext_Nam
) then
8931 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
8932 Check_Form_Of_Interface_Name
(Ext_Nam
);
8934 -- Verify that external name is not the name of a local entity,
8935 -- which would hide the imported one and could lead to run-time
8936 -- surprises. The problem can only arise for entities declared in
8937 -- a package body (otherwise the external name is fully qualified
8938 -- and will not conflict).
8946 if Prag_Id
= Pragma_Import
then
8947 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
8949 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
8951 if Nam
/= Chars
(Subprogram_Def
)
8952 and then Present
(E
)
8953 and then not Is_Overloadable
(E
)
8954 and then Is_Immediately_Visible
(E
)
8955 and then not Is_Imported
(E
)
8956 and then Ekind
(Scope
(E
)) = E_Package
8959 while Present
(Par
) loop
8960 if Nkind
(Par
) = N_Package_Body
then
8961 Error_Msg_Sloc
:= Sloc
(E
);
8963 ("imported entity is hidden by & declared#",
8968 Par
:= Parent
(Par
);
8975 if Present
(Link_Nam
) then
8976 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
8977 Check_Form_Of_Interface_Name
(Link_Nam
);
8980 -- If there is no link name, just set the external name
8982 if No
(Link_Nam
) then
8983 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
8985 -- For the Link_Name case, the given literal is preceded by an
8986 -- asterisk, which indicates to GCC that the given name should be
8987 -- taken literally, and in particular that no prepending of
8988 -- underlines should occur, even in systems where this is the
8993 Store_String_Char
(Get_Char_Code
('*'));
8994 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
8995 Store_String_Chars
(String_Val
);
8997 Make_String_Literal
(Sloc
(Link_Nam
),
8998 Strval
=> End_String
);
9001 -- Set the interface name. If the entity is a generic instance, use
9002 -- its alias, which is the callable entity.
9004 if Is_Generic_Instance
(Subprogram_Def
) then
9005 Set_Encoded_Interface_Name
9006 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9008 Set_Encoded_Interface_Name
9009 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9012 Check_Duplicated_Export_Name
(Link_Nam
);
9013 end Process_Interface_Name
;
9015 -----------------------------------------
9016 -- Process_Interrupt_Or_Attach_Handler --
9017 -----------------------------------------
9019 procedure Process_Interrupt_Or_Attach_Handler
is
9020 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9021 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9024 -- A pragma that applies to a Ghost entity becomes Ghost for the
9025 -- purposes of legality checks and removal of ignored Ghost code.
9027 Mark_Pragma_As_Ghost
(N
, Handler
);
9028 Set_Is_Interrupt_Handler
(Handler
);
9030 -- If the pragma is not associated with a handler procedure within a
9031 -- protected type, then it must be for a nonprotected procedure for
9032 -- the AAMP target, in which case we don't associate a representation
9033 -- item with the procedure's scope.
9035 if Ekind
(Prot_Typ
) = E_Protected_Type
then
9036 Record_Rep_Item
(Prot_Typ
, N
);
9039 -- Chain the pragma on the contract for completeness
9041 Add_Contract_Item
(N
, Handler
);
9042 end Process_Interrupt_Or_Attach_Handler
;
9044 --------------------------------------------------
9045 -- Process_Restrictions_Or_Restriction_Warnings --
9046 --------------------------------------------------
9048 -- Note: some of the simple identifier cases were handled in par-prag,
9049 -- but it is harmless (and more straightforward) to simply handle all
9050 -- cases here, even if it means we repeat a bit of work in some cases.
9052 procedure Process_Restrictions_Or_Restriction_Warnings
9056 R_Id
: Restriction_Id
;
9062 -- Ignore all Restrictions pragmas in CodePeer mode
9064 if CodePeer_Mode
then
9068 Check_Ada_83_Warning
;
9069 Check_At_Least_N_Arguments
(1);
9070 Check_Valid_Configuration_Pragma
;
9073 while Present
(Arg
) loop
9075 Expr
:= Get_Pragma_Arg
(Arg
);
9077 -- Case of no restriction identifier present
9079 if Id
= No_Name
then
9080 if Nkind
(Expr
) /= N_Identifier
then
9082 ("invalid form for restriction", Arg
);
9087 (Process_Restriction_Synonyms
(Expr
));
9089 if R_Id
not in All_Boolean_Restrictions
then
9090 Error_Msg_Name_1
:= Pname
;
9092 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9094 -- Check for possible misspelling
9096 for J
in Restriction_Id
loop
9098 Rnm
: constant String := Restriction_Id
'Image (J
);
9101 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9102 Name_Len
:= Rnm
'Length;
9103 Set_Casing
(All_Lower_Case
);
9105 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9107 (Identifier_Casing
(Current_Source_File
));
9108 Error_Msg_String
(1 .. Rnm
'Length) :=
9109 Name_Buffer
(1 .. Name_Len
);
9110 Error_Msg_Strlen
:= Rnm
'Length;
9111 Error_Msg_N
-- CODEFIX
9112 ("\possible misspelling of ""~""",
9113 Get_Pragma_Arg
(Arg
));
9122 if Implementation_Restriction
(R_Id
) then
9123 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
9126 -- Special processing for No_Elaboration_Code restriction
9128 if R_Id
= No_Elaboration_Code
then
9130 -- Restriction is only recognized within a configuration
9131 -- pragma file, or within a unit of the main extended
9132 -- program. Note: the test for Main_Unit is needed to
9133 -- properly include the case of configuration pragma files.
9135 if not (Current_Sem_Unit
= Main_Unit
9136 or else In_Extended_Main_Source_Unit
(N
))
9140 -- Don't allow in a subunit unless already specified in
9143 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
9144 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
9145 and then not Restriction_Active
(No_Elaboration_Code
)
9148 ("invalid specification of ""No_Elaboration_Code""",
9151 ("\restriction cannot be specified in a subunit", N
);
9153 ("\unless also specified in body or spec", N
);
9156 -- If we accept a No_Elaboration_Code restriction, then it
9157 -- needs to be added to the configuration restriction set so
9158 -- that we get proper application to other units in the main
9159 -- extended source as required.
9162 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9166 -- If this is a warning, then set the warning unless we already
9167 -- have a real restriction active (we never want a warning to
9168 -- override a real restriction).
9171 if not Restriction_Active
(R_Id
) then
9172 Set_Restriction
(R_Id
, N
);
9173 Restriction_Warnings
(R_Id
) := True;
9176 -- If real restriction case, then set it and make sure that the
9177 -- restriction warning flag is off, since a real restriction
9178 -- always overrides a warning.
9181 Set_Restriction
(R_Id
, N
);
9182 Restriction_Warnings
(R_Id
) := False;
9185 -- Check for obsolescent restrictions in Ada 2005 mode
9188 and then Ada_Version
>= Ada_2005
9189 and then (R_Id
= No_Asynchronous_Control
9191 R_Id
= No_Unchecked_Deallocation
9193 R_Id
= No_Unchecked_Conversion
)
9195 Check_Restriction
(No_Obsolescent_Features
, N
);
9198 -- A very special case that must be processed here: pragma
9199 -- Restrictions (No_Exceptions) turns off all run-time
9200 -- checking. This is a bit dubious in terms of the formal
9201 -- language definition, but it is what is intended by RM
9202 -- H.4(12). Restriction_Warnings never affects generated code
9203 -- so this is done only in the real restriction case.
9205 -- Atomic_Synchronization is not a real check, so it is not
9206 -- affected by this processing).
9208 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9209 -- run-time checks in CodePeer and GNATprove modes: we want to
9210 -- generate checks for analysis purposes, as set respectively
9211 -- by -gnatC and -gnatd.F
9214 and then not (CodePeer_Mode
or GNATprove_Mode
)
9215 and then R_Id
= No_Exceptions
9217 for J
in Scope_Suppress
.Suppress
'Range loop
9218 if J
/= Atomic_Synchronization
then
9219 Scope_Suppress
.Suppress
(J
) := True;
9224 -- Case of No_Dependence => unit-name. Note that the parser
9225 -- already made the necessary entry in the No_Dependence table.
9227 elsif Id
= Name_No_Dependence
then
9228 if not OK_No_Dependence_Unit_Name
(Expr
) then
9232 -- Case of No_Specification_Of_Aspect => aspect-identifier
9234 elsif Id
= Name_No_Specification_Of_Aspect
then
9239 if Nkind
(Expr
) /= N_Identifier
then
9242 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9245 if A_Id
= No_Aspect
then
9246 Error_Pragma_Arg
("invalid restriction name", Arg
);
9248 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9252 -- Case of No_Use_Of_Attribute => attribute-identifier
9254 elsif Id
= Name_No_Use_Of_Attribute
then
9255 if Nkind
(Expr
) /= N_Identifier
9256 or else not Is_Attribute_Name
(Chars
(Expr
))
9258 Error_Msg_N
("unknown attribute name??", Expr
);
9261 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9264 -- Case of No_Use_Of_Entity => fully-qualified-name
9266 elsif Id
= Name_No_Use_Of_Entity
then
9268 -- Restriction is only recognized within a configuration
9269 -- pragma file, or within a unit of the main extended
9270 -- program. Note: the test for Main_Unit is needed to
9271 -- properly include the case of configuration pragma files.
9273 if Current_Sem_Unit
= Main_Unit
9274 or else In_Extended_Main_Source_Unit
(N
)
9276 if not OK_No_Dependence_Unit_Name
(Expr
) then
9277 Error_Msg_N
("wrong form for entity name", Expr
);
9279 Set_Restriction_No_Use_Of_Entity
9280 (Expr
, Warn
, No_Profile
);
9284 -- Case of No_Use_Of_Pragma => pragma-identifier
9286 elsif Id
= Name_No_Use_Of_Pragma
then
9287 if Nkind
(Expr
) /= N_Identifier
9288 or else not Is_Pragma_Name
(Chars
(Expr
))
9290 Error_Msg_N
("unknown pragma name??", Expr
);
9292 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9295 -- All other cases of restriction identifier present
9298 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9299 Analyze_And_Resolve
(Expr
, Any_Integer
);
9301 if R_Id
not in All_Parameter_Restrictions
then
9303 ("invalid restriction parameter identifier", Arg
);
9305 elsif not Is_OK_Static_Expression
(Expr
) then
9306 Flag_Non_Static_Expr
9307 ("value must be static expression!", Expr
);
9310 elsif not Is_Integer_Type
(Etype
(Expr
))
9311 or else Expr_Value
(Expr
) < 0
9314 ("value must be non-negative integer", Arg
);
9317 -- Restriction pragma is active
9319 Val
:= Expr_Value
(Expr
);
9321 if not UI_Is_In_Int_Range
(Val
) then
9323 ("pragma ignored, value too large??", Arg
);
9326 -- Warning case. If the real restriction is active, then we
9327 -- ignore the request, since warning never overrides a real
9328 -- restriction. Otherwise we set the proper warning. Note that
9329 -- this circuit sets the warning again if it is already set,
9330 -- which is what we want, since the constant may have changed.
9333 if not Restriction_Active
(R_Id
) then
9335 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9336 Restriction_Warnings
(R_Id
) := True;
9339 -- Real restriction case, set restriction and make sure warning
9340 -- flag is off since real restriction always overrides warning.
9343 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9344 Restriction_Warnings
(R_Id
) := False;
9350 end Process_Restrictions_Or_Restriction_Warnings
;
9352 ---------------------------------
9353 -- Process_Suppress_Unsuppress --
9354 ---------------------------------
9356 -- Note: this procedure makes entries in the check suppress data
9357 -- structures managed by Sem. See spec of package Sem for full
9358 -- details on how we handle recording of check suppression.
9360 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9365 In_Package_Spec
: constant Boolean :=
9366 Is_Package_Or_Generic_Package
(Current_Scope
)
9367 and then not In_Package_Body
(Current_Scope
);
9369 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9370 -- Used to suppress a single check on the given entity
9372 --------------------------------
9373 -- Suppress_Unsuppress_Echeck --
9374 --------------------------------
9376 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9378 -- Check for error of trying to set atomic synchronization for
9379 -- a non-atomic variable.
9381 if C
= Atomic_Synchronization
9382 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9385 ("pragma & requires atomic type or variable",
9386 Pragma_Identifier
(Original_Node
(N
)));
9389 Set_Checks_May_Be_Suppressed
(E
);
9391 if In_Package_Spec
then
9392 Push_Global_Suppress_Stack_Entry
9395 Suppress
=> Suppress_Case
);
9397 Push_Local_Suppress_Stack_Entry
9400 Suppress
=> Suppress_Case
);
9403 -- If this is a first subtype, and the base type is distinct,
9404 -- then also set the suppress flags on the base type.
9406 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9407 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9409 end Suppress_Unsuppress_Echeck
;
9411 -- Start of processing for Process_Suppress_Unsuppress
9414 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9415 -- on user code: we want to generate checks for analysis purposes, as
9416 -- set respectively by -gnatC and -gnatd.F
9418 if Comes_From_Source
(N
)
9419 and then (CodePeer_Mode
or GNATprove_Mode
)
9424 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9425 -- declarative part or a package spec (RM 11.5(5)).
9427 if not Is_Configuration_Pragma
then
9428 Check_Is_In_Decl_Part_Or_Package_Spec
;
9431 Check_At_Least_N_Arguments
(1);
9432 Check_At_Most_N_Arguments
(2);
9433 Check_No_Identifier
(Arg1
);
9434 Check_Arg_Is_Identifier
(Arg1
);
9436 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9438 if C
= No_Check_Id
then
9440 ("argument of pragma% is not valid check name", Arg1
);
9443 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9445 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9447 ("Suppress of Elaboration_Check ignored in SPARK??",
9448 "\elaboration checking rules are statically enforced "
9449 & "(SPARK RM 7.7)", Arg1
);
9452 -- One-argument case
9454 if Arg_Count
= 1 then
9456 -- Make an entry in the local scope suppress table. This is the
9457 -- table that directly shows the current value of the scope
9458 -- suppress check for any check id value.
9460 if C
= All_Checks
then
9462 -- For All_Checks, we set all specific predefined checks with
9463 -- the exception of Elaboration_Check, which is handled
9464 -- specially because of not wanting All_Checks to have the
9465 -- effect of deactivating static elaboration order processing.
9466 -- Atomic_Synchronization is also not affected, since this is
9467 -- not a real check.
9469 for J
in Scope_Suppress
.Suppress
'Range loop
9470 if J
/= Elaboration_Check
9472 J
/= Atomic_Synchronization
9474 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9478 -- If not All_Checks, and predefined check, then set appropriate
9479 -- scope entry. Note that we will set Elaboration_Check if this
9480 -- is explicitly specified. Atomic_Synchronization is allowed
9481 -- only if internally generated and entity is atomic.
9483 elsif C
in Predefined_Check_Id
9484 and then (not Comes_From_Source
(N
)
9485 or else C
/= Atomic_Synchronization
)
9487 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9490 -- Also make an entry in the Local_Entity_Suppress table
9492 Push_Local_Suppress_Stack_Entry
9495 Suppress
=> Suppress_Case
);
9497 -- Case of two arguments present, where the check is suppressed for
9498 -- a specified entity (given as the second argument of the pragma)
9501 -- This is obsolescent in Ada 2005 mode
9503 if Ada_Version
>= Ada_2005
then
9504 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9507 Check_Optional_Identifier
(Arg2
, Name_On
);
9508 E_Id
:= Get_Pragma_Arg
(Arg2
);
9511 if not Is_Entity_Name
(E_Id
) then
9513 ("second argument of pragma% must be entity name", Arg2
);
9522 -- A pragma that applies to a Ghost entity becomes Ghost for the
9523 -- purposes of legality checks and removal of ignored Ghost code.
9525 Mark_Pragma_As_Ghost
(N
, E
);
9527 -- Enforce RM 11.5(7) which requires that for a pragma that
9528 -- appears within a package spec, the named entity must be
9529 -- within the package spec. We allow the package name itself
9530 -- to be mentioned since that makes sense, although it is not
9531 -- strictly allowed by 11.5(7).
9534 and then E
/= Current_Scope
9535 and then Scope
(E
) /= Current_Scope
9538 ("entity in pragma% is not in package spec (RM 11.5(7))",
9542 -- Loop through homonyms. As noted below, in the case of a package
9543 -- spec, only homonyms within the package spec are considered.
9546 Suppress_Unsuppress_Echeck
(E
, C
);
9548 if Is_Generic_Instance
(E
)
9549 and then Is_Subprogram
(E
)
9550 and then Present
(Alias
(E
))
9552 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9555 -- Move to next homonym if not aspect spec case
9557 exit when From_Aspect_Specification
(N
);
9561 -- If we are within a package specification, the pragma only
9562 -- applies to homonyms in the same scope.
9564 exit when In_Package_Spec
9565 and then Scope
(E
) /= Current_Scope
;
9568 end Process_Suppress_Unsuppress
;
9570 -------------------------------
9571 -- Record_Independence_Check --
9572 -------------------------------
9574 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
9576 -- For GCC back ends the validation is done a priori
9578 if not AAMP_On_Target
then
9582 Independence_Checks
.Append
((N
, E
));
9583 end Record_Independence_Check
;
9589 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9591 if Is_Imported
(E
) then
9593 ("cannot export entity& that was previously imported", Arg
);
9595 elsif Present
(Address_Clause
(E
))
9596 and then not Relaxed_RM_Semantics
9599 ("cannot export entity& that has an address clause", Arg
);
9602 Set_Is_Exported
(E
);
9604 -- Generate a reference for entity explicitly, because the
9605 -- identifier may be overloaded and name resolution will not
9608 Generate_Reference
(E
, Arg
);
9610 -- Deal with exporting non-library level entity
9612 if not Is_Library_Level_Entity
(E
) then
9614 -- Not allowed at all for subprograms
9616 if Is_Subprogram
(E
) then
9617 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9619 -- Otherwise set public and statically allocated
9623 Set_Is_Statically_Allocated
(E
);
9625 -- Warn if the corresponding W flag is set
9627 if Warn_On_Export_Import
9629 -- Only do this for something that was in the source. Not
9630 -- clear if this can be False now (there used for sure to be
9631 -- cases on some systems where it was False), but anyway the
9632 -- test is harmless if not needed, so it is retained.
9634 and then Comes_From_Source
(Arg
)
9637 ("?x?& has been made static as a result of Export",
9640 ("\?x?this usage is non-standard and non-portable",
9646 if Warn_On_Export_Import
and then Is_Type
(E
) then
9647 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9650 if Warn_On_Export_Import
and Inside_A_Generic
then
9652 ("all instances of& will have the same external name?x?",
9657 ----------------------------------------------
9658 -- Set_Extended_Import_Export_External_Name --
9659 ----------------------------------------------
9661 procedure Set_Extended_Import_Export_External_Name
9662 (Internal_Ent
: Entity_Id
;
9663 Arg_External
: Node_Id
)
9665 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9669 if No
(Arg_External
) then
9673 Check_Arg_Is_External_Name
(Arg_External
);
9675 if Nkind
(Arg_External
) = N_String_Literal
then
9676 if String_Length
(Strval
(Arg_External
)) = 0 then
9679 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9682 elsif Nkind
(Arg_External
) = N_Identifier
then
9683 New_Name
:= Get_Default_External_Name
(Arg_External
);
9685 -- Check_Arg_Is_External_Name should let through only identifiers and
9686 -- string literals or static string expressions (which are folded to
9687 -- string literals).
9690 raise Program_Error
;
9693 -- If we already have an external name set (by a prior normal Import
9694 -- or Export pragma), then the external names must match
9696 if Present
(Interface_Name
(Internal_Ent
)) then
9698 -- Ignore mismatching names in CodePeer mode, to support some
9699 -- old compilers which would export the same procedure under
9700 -- different names, e.g:
9702 -- pragma Export_Procedure (P, "a");
9703 -- pragma Export_Procedure (P, "b");
9705 if CodePeer_Mode
then
9709 Check_Matching_Internal_Names
: declare
9710 S1
: constant String_Id
:= Strval
(Old_Name
);
9711 S2
: constant String_Id
:= Strval
(New_Name
);
9714 pragma No_Return
(Mismatch
);
9715 -- Called if names do not match
9721 procedure Mismatch
is
9723 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9725 ("external name does not match that given #",
9729 -- Start of processing for Check_Matching_Internal_Names
9732 if String_Length
(S1
) /= String_Length
(S2
) then
9736 for J
in 1 .. String_Length
(S1
) loop
9737 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
9742 end Check_Matching_Internal_Names
;
9744 -- Otherwise set the given name
9747 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
9748 Check_Duplicated_Export_Name
(New_Name
);
9750 end Set_Extended_Import_Export_External_Name
;
9756 procedure Set_Imported
(E
: Entity_Id
) is
9758 -- Error message if already imported or exported
9760 if Is_Exported
(E
) or else Is_Imported
(E
) then
9762 -- Error if being set Exported twice
9764 if Is_Exported
(E
) then
9765 Error_Msg_NE
("entity& was previously exported", N
, E
);
9767 -- Ignore error in CodePeer mode where we treat all imported
9768 -- subprograms as unknown.
9770 elsif CodePeer_Mode
then
9773 -- OK if Import/Interface case
9775 elsif Import_Interface_Present
(N
) then
9778 -- Error if being set Imported twice
9781 Error_Msg_NE
("entity& was previously imported", N
, E
);
9784 Error_Msg_Name_1
:= Pname
;
9786 ("\(pragma% applies to all previous entities)", N
);
9788 Error_Msg_Sloc
:= Sloc
(E
);
9789 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
9791 -- Here if not previously imported or exported, OK to import
9794 Set_Is_Imported
(E
);
9796 -- For subprogram, set Import_Pragma field
9798 if Is_Subprogram
(E
) then
9799 Set_Import_Pragma
(E
, N
);
9802 -- If the entity is an object that is not at the library level,
9803 -- then it is statically allocated. We do not worry about objects
9804 -- with address clauses in this context since they are not really
9805 -- imported in the linker sense.
9808 and then not Is_Library_Level_Entity
(E
)
9809 and then No
(Address_Clause
(E
))
9811 Set_Is_Statically_Allocated
(E
);
9818 -------------------------
9819 -- Set_Mechanism_Value --
9820 -------------------------
9822 -- Note: the mechanism name has not been analyzed (and cannot indeed be
9823 -- analyzed, since it is semantic nonsense), so we get it in the exact
9824 -- form created by the parser.
9826 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
9827 procedure Bad_Mechanism
;
9828 pragma No_Return
(Bad_Mechanism
);
9829 -- Signal bad mechanism name
9831 -------------------------
9832 -- Bad_Mechanism_Value --
9833 -------------------------
9835 procedure Bad_Mechanism
is
9837 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
9840 -- Start of processing for Set_Mechanism_Value
9843 if Mechanism
(Ent
) /= Default_Mechanism
then
9845 ("mechanism for & has already been set", Mech_Name
, Ent
);
9848 -- MECHANISM_NAME ::= value | reference
9850 if Nkind
(Mech_Name
) = N_Identifier
then
9851 if Chars
(Mech_Name
) = Name_Value
then
9852 Set_Mechanism
(Ent
, By_Copy
);
9855 elsif Chars
(Mech_Name
) = Name_Reference
then
9856 Set_Mechanism
(Ent
, By_Reference
);
9859 elsif Chars
(Mech_Name
) = Name_Copy
then
9861 ("bad mechanism name, Value assumed", Mech_Name
);
9870 end Set_Mechanism_Value
;
9872 --------------------------
9873 -- Set_Rational_Profile --
9874 --------------------------
9876 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
9877 -- extension to the semantics of renaming declarations.
9879 procedure Set_Rational_Profile
is
9881 Implicit_Packing
:= True;
9882 Overriding_Renamings
:= True;
9883 Use_VADS_Size
:= True;
9884 end Set_Rational_Profile
;
9886 ---------------------------
9887 -- Set_Ravenscar_Profile --
9888 ---------------------------
9890 -- The tasks to be done here are
9892 -- Set required policies
9894 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9895 -- pragma Locking_Policy (Ceiling_Locking)
9897 -- Set Detect_Blocking mode
9899 -- Set required restrictions (see System.Rident for detailed list)
9901 -- Set the No_Dependence rules
9902 -- No_Dependence => Ada.Asynchronous_Task_Control
9903 -- No_Dependence => Ada.Calendar
9904 -- No_Dependence => Ada.Execution_Time.Group_Budget
9905 -- No_Dependence => Ada.Execution_Time.Timers
9906 -- No_Dependence => Ada.Task_Attributes
9907 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
9909 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
9910 procedure Set_Error_Msg_To_Profile_Name
;
9911 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
9914 -----------------------------------
9915 -- Set_Error_Msg_To_Profile_Name --
9916 -----------------------------------
9918 procedure Set_Error_Msg_To_Profile_Name
is
9919 Prof_Nam
: constant Node_Id
:=
9921 (First
(Pragma_Argument_Associations
(N
)));
9924 Get_Name_String
(Chars
(Prof_Nam
));
9925 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
9926 Error_Msg_Strlen
:= Name_Len
;
9927 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
9928 end Set_Error_Msg_To_Profile_Name
;
9937 -- Start of processing for Set_Ravenscar_Profile
9940 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
9942 if Task_Dispatching_Policy
/= ' '
9943 and then Task_Dispatching_Policy
/= 'F'
9945 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
9946 Set_Error_Msg_To_Profile_Name
;
9947 Error_Pragma
("Profile (~) incompatible with policy#");
9949 -- Set the FIFO_Within_Priorities policy, but always preserve
9950 -- System_Location since we like the error message with the run time
9954 Task_Dispatching_Policy
:= 'F';
9956 if Task_Dispatching_Policy_Sloc
/= System_Location
then
9957 Task_Dispatching_Policy_Sloc
:= Loc
;
9961 -- pragma Locking_Policy (Ceiling_Locking)
9963 if Locking_Policy
/= ' '
9964 and then Locking_Policy
/= 'C'
9966 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
9967 Set_Error_Msg_To_Profile_Name
;
9968 Error_Pragma
("Profile (~) incompatible with policy#");
9970 -- Set the Ceiling_Locking policy, but preserve System_Location since
9971 -- we like the error message with the run time name.
9974 Locking_Policy
:= 'C';
9976 if Locking_Policy_Sloc
/= System_Location
then
9977 Locking_Policy_Sloc
:= Loc
;
9981 -- pragma Detect_Blocking
9983 Detect_Blocking
:= True;
9985 -- Set the corresponding restrictions
9987 Set_Profile_Restrictions
9988 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
9990 -- Set the No_Dependence restrictions
9992 -- The following No_Dependence restrictions:
9993 -- No_Dependence => Ada.Asynchronous_Task_Control
9994 -- No_Dependence => Ada.Calendar
9995 -- No_Dependence => Ada.Task_Attributes
9996 -- are already set by previous call to Set_Profile_Restrictions.
9998 -- Set the following restrictions which were added to Ada 2005:
9999 -- No_Dependence => Ada.Execution_Time.Group_Budget
10000 -- No_Dependence => Ada.Execution_Time.Timers
10002 -- ??? The use of Name_Buffer here is suspicious. The names should
10003 -- be registered in snames.ads-tmpl and used to build the qualified
10006 if Ada_Version
>= Ada_2005
then
10007 Name_Buffer
(1 .. 3) := "ada";
10010 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
10012 Name_Buffer
(1 .. 14) := "execution_time";
10015 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10018 Make_Selected_Component
10021 Selector_Name
=> Sel_Id
);
10023 Name_Buffer
(1 .. 13) := "group_budgets";
10026 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10029 Make_Selected_Component
10032 Selector_Name
=> Sel_Id
);
10034 Set_Restriction_No_Dependence
10036 Warn
=> Treat_Restrictions_As_Warnings
,
10037 Profile
=> Ravenscar
);
10039 Name_Buffer
(1 .. 6) := "timers";
10042 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10045 Make_Selected_Component
10048 Selector_Name
=> Sel_Id
);
10050 Set_Restriction_No_Dependence
10052 Warn
=> Treat_Restrictions_As_Warnings
,
10053 Profile
=> Ravenscar
);
10056 -- Set the following restriction which was added to Ada 2012 (see
10058 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10060 if Ada_Version
>= Ada_2012
then
10061 Name_Buffer
(1 .. 6) := "system";
10064 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
10066 Name_Buffer
(1 .. 15) := "multiprocessors";
10069 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10072 Make_Selected_Component
10075 Selector_Name
=> Sel_Id
);
10077 Name_Buffer
(1 .. 19) := "dispatching_domains";
10080 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10083 Make_Selected_Component
10086 Selector_Name
=> Sel_Id
);
10088 Set_Restriction_No_Dependence
10090 Warn
=> Treat_Restrictions_As_Warnings
,
10091 Profile
=> Ravenscar
);
10093 end Set_Ravenscar_Profile
;
10095 -- Start of processing for Analyze_Pragma
10098 -- The following code is a defense against recursion. Not clear that
10099 -- this can happen legitimately, but perhaps some error situations can
10100 -- cause it, and we did see this recursion during testing.
10102 if Analyzed
(N
) then
10108 Check_Restriction_No_Use_Of_Pragma
(N
);
10110 -- Deal with unrecognized pragma
10112 Pname
:= Pragma_Name
(N
);
10114 if not Is_Pragma_Name
(Pname
) then
10115 if Warn_On_Unrecognized_Pragma
then
10116 Error_Msg_Name_1
:= Pname
;
10117 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10119 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10120 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10121 Error_Msg_Name_1
:= PN
;
10122 Error_Msg_N
-- CODEFIX
10123 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
10132 -- Ignore pragma if Ignore_Pragma applies
10134 if Get_Name_Table_Boolean3
(Pname
) then
10138 -- Here to start processing for recognized pragma
10140 Prag_Id
:= Get_Pragma_Id
(Pname
);
10141 Pname
:= Original_Aspect_Pragma_Name
(N
);
10143 -- Capture setting of Opt.Uneval_Old
10145 case Opt
.Uneval_Old
is
10147 Set_Uneval_Old_Accept
(N
);
10151 Set_Uneval_Old_Warn
(N
);
10153 raise Program_Error
;
10156 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10157 -- is already set, indicating that we have already checked the policy
10158 -- at the right point. This happens for example in the case of a pragma
10159 -- that is derived from an Aspect.
10161 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10164 -- For a pragma that is a rewriting of another pragma, copy the
10165 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10167 elsif Is_Rewrite_Substitution
(N
)
10168 and then Nkind
(Original_Node
(N
)) = N_Pragma
10169 and then Original_Node
(N
) /= N
10171 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10172 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10174 -- Otherwise query the applicable policy at this point
10177 Check_Applicable_Policy
(N
);
10179 -- If pragma is disabled, rewrite as NULL and skip analysis
10181 if Is_Disabled
(N
) then
10182 Rewrite
(N
, Make_Null_Statement
(Loc
));
10188 -- Preset arguments
10196 if Present
(Pragma_Argument_Associations
(N
)) then
10197 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10198 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10200 if Present
(Arg1
) then
10201 Arg2
:= Next
(Arg1
);
10203 if Present
(Arg2
) then
10204 Arg3
:= Next
(Arg2
);
10206 if Present
(Arg3
) then
10207 Arg4
:= Next
(Arg3
);
10213 -- An enumeration type defines the pragmas that are supported by the
10214 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10215 -- into the corresponding enumeration value for the following case.
10223 -- pragma Abort_Defer;
10225 when Pragma_Abort_Defer
=>
10227 Check_Arg_Count
(0);
10229 -- The only required semantic processing is to check the
10230 -- placement. This pragma must appear at the start of the
10231 -- statement sequence of a handled sequence of statements.
10233 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10234 or else N
/= First
(Statements
(Parent
(N
)))
10239 --------------------
10240 -- Abstract_State --
10241 --------------------
10243 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10245 -- ABSTRACT_STATE_LIST ::=
10247 -- | STATE_NAME_WITH_OPTIONS
10248 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10250 -- STATE_NAME_WITH_OPTIONS ::=
10252 -- | (STATE_NAME with OPTION_LIST)
10254 -- OPTION_LIST ::= OPTION {, OPTION}
10258 -- | NAME_VALUE_OPTION
10260 -- SIMPLE_OPTION ::= Ghost | Synchronous
10262 -- NAME_VALUE_OPTION ::=
10263 -- Part_Of => ABSTRACT_STATE
10264 -- | External [=> EXTERNAL_PROPERTY_LIST]
10266 -- EXTERNAL_PROPERTY_LIST ::=
10267 -- EXTERNAL_PROPERTY
10268 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10270 -- EXTERNAL_PROPERTY ::=
10271 -- Async_Readers [=> boolean_EXPRESSION]
10272 -- | Async_Writers [=> boolean_EXPRESSION]
10273 -- | Effective_Reads [=> boolean_EXPRESSION]
10274 -- | Effective_Writes [=> boolean_EXPRESSION]
10275 -- others => boolean_EXPRESSION
10277 -- STATE_NAME ::= defining_identifier
10279 -- ABSTRACT_STATE ::= name
10281 -- Characteristics:
10283 -- * Analysis - The annotation is fully analyzed immediately upon
10284 -- elaboration as it cannot forward reference entities.
10286 -- * Expansion - None.
10288 -- * Template - The annotation utilizes the generic template of the
10289 -- related package declaration.
10291 -- * Globals - The annotation cannot reference global entities.
10293 -- * Instance - The annotation is instantiated automatically when
10294 -- the related generic package is instantiated.
10296 when Pragma_Abstract_State
=> Abstract_State
: declare
10297 Missing_Parentheses
: Boolean := False;
10298 -- Flag set when a state declaration with options is not properly
10301 -- Flags used to verify the consistency of states
10303 Non_Null_Seen
: Boolean := False;
10304 Null_Seen
: Boolean := False;
10306 procedure Analyze_Abstract_State
10308 Pack_Id
: Entity_Id
);
10309 -- Verify the legality of a single state declaration. Create and
10310 -- decorate a state abstraction entity and introduce it into the
10311 -- visibility chain. Pack_Id denotes the entity or the related
10312 -- package where pragma Abstract_State appears.
10314 procedure Malformed_State_Error
(State
: Node_Id
);
10315 -- Emit an error concerning the illegal declaration of abstract
10316 -- state State. This routine diagnoses syntax errors that lead to
10317 -- a different parse tree. The error is issued regardless of the
10318 -- SPARK mode in effect.
10320 ----------------------------
10321 -- Analyze_Abstract_State --
10322 ----------------------------
10324 procedure Analyze_Abstract_State
10326 Pack_Id
: Entity_Id
)
10328 -- Flags used to verify the consistency of options
10330 AR_Seen
: Boolean := False;
10331 AW_Seen
: Boolean := False;
10332 ER_Seen
: Boolean := False;
10333 EW_Seen
: Boolean := False;
10334 External_Seen
: Boolean := False;
10335 Ghost_Seen
: Boolean := False;
10336 Others_Seen
: Boolean := False;
10337 Part_Of_Seen
: Boolean := False;
10338 Synchronous_Seen
: Boolean := False;
10340 -- Flags used to store the static value of all external states'
10343 AR_Val
: Boolean := False;
10344 AW_Val
: Boolean := False;
10345 ER_Val
: Boolean := False;
10346 EW_Val
: Boolean := False;
10348 State_Id
: Entity_Id
:= Empty
;
10349 -- The entity to be generated for the current state declaration
10351 procedure Analyze_External_Option
(Opt
: Node_Id
);
10352 -- Verify the legality of option External
10354 procedure Analyze_External_Property
10356 Expr
: Node_Id
:= Empty
);
10357 -- Verify the legailty of a single external property. Prop
10358 -- denotes the external property. Expr is the expression used
10359 -- to set the property.
10361 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10362 -- Verify the legality of option Part_Of
10364 procedure Check_Duplicate_Option
10366 Status
: in out Boolean);
10367 -- Flag Status denotes whether a particular option has been
10368 -- seen while processing a state. This routine verifies that
10369 -- Opt is not a duplicate option and sets the flag Status
10370 -- (SPARK RM 7.1.4(1)).
10372 procedure Check_Duplicate_Property
10374 Status
: in out Boolean);
10375 -- Flag Status denotes whether a particular property has been
10376 -- seen while processing option External. This routine verifies
10377 -- that Prop is not a duplicate property and sets flag Status.
10378 -- Opt is not a duplicate property and sets the flag Status.
10379 -- (SPARK RM 7.1.4(2))
10381 procedure Check_Ghost_Synchronous
;
10382 -- Ensure that the abstract state is not subject to both Ghost
10383 -- and Synchronous simple options. Emit an error if this is the
10386 procedure Create_Abstract_State
10390 Is_Null
: Boolean);
10391 -- Generate an abstract state entity with name Nam and enter it
10392 -- into visibility. Decl is the "declaration" of the state as
10393 -- it appears in pragma Abstract_State. Loc is the location of
10394 -- the related state "declaration". Flag Is_Null should be set
10395 -- when the associated Abstract_State pragma defines a null
10398 -----------------------------
10399 -- Analyze_External_Option --
10400 -----------------------------
10402 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10403 Errors
: constant Nat
:= Serious_Errors_Detected
;
10405 Props
: Node_Id
:= Empty
;
10408 if Nkind
(Opt
) = N_Component_Association
then
10409 Props
:= Expression
(Opt
);
10412 -- External state with properties
10414 if Present
(Props
) then
10416 -- Multiple properties appear as an aggregate
10418 if Nkind
(Props
) = N_Aggregate
then
10420 -- Simple property form
10422 Prop
:= First
(Expressions
(Props
));
10423 while Present
(Prop
) loop
10424 Analyze_External_Property
(Prop
);
10428 -- Property with expression form
10430 Prop
:= First
(Component_Associations
(Props
));
10431 while Present
(Prop
) loop
10432 Analyze_External_Property
10433 (Prop
=> First
(Choices
(Prop
)),
10434 Expr
=> Expression
(Prop
));
10442 Analyze_External_Property
(Props
);
10445 -- An external state defined without any properties defaults
10446 -- all properties to True.
10455 -- Once all external properties have been processed, verify
10456 -- their mutual interaction. Do not perform the check when
10457 -- at least one of the properties is illegal as this will
10458 -- produce a bogus error.
10460 if Errors
= Serious_Errors_Detected
then
10461 Check_External_Properties
10462 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10464 end Analyze_External_Option
;
10466 -------------------------------
10467 -- Analyze_External_Property --
10468 -------------------------------
10470 procedure Analyze_External_Property
10472 Expr
: Node_Id
:= Empty
)
10474 Expr_Val
: Boolean;
10477 -- Check the placement of "others" (if available)
10479 if Nkind
(Prop
) = N_Others_Choice
then
10480 if Others_Seen
then
10482 ("only one others choice allowed in option External",
10485 Others_Seen
:= True;
10488 elsif Others_Seen
then
10490 ("others must be the last property in option External",
10493 -- The only remaining legal options are the four predefined
10494 -- external properties.
10496 elsif Nkind
(Prop
) = N_Identifier
10497 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10498 Name_Async_Writers
,
10499 Name_Effective_Reads
,
10500 Name_Effective_Writes
)
10504 -- Otherwise the construct is not a valid property
10507 SPARK_Msg_N
("invalid external state property", Prop
);
10511 -- Ensure that the expression of the external state property
10512 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10514 if Present
(Expr
) then
10515 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10517 if Is_OK_Static_Expression
(Expr
) then
10518 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10521 ("expression of external state property must be "
10525 -- The lack of expression defaults the property to True
10531 -- Named properties
10533 if Nkind
(Prop
) = N_Identifier
then
10534 if Chars
(Prop
) = Name_Async_Readers
then
10535 Check_Duplicate_Property
(Prop
, AR_Seen
);
10536 AR_Val
:= Expr_Val
;
10538 elsif Chars
(Prop
) = Name_Async_Writers
then
10539 Check_Duplicate_Property
(Prop
, AW_Seen
);
10540 AW_Val
:= Expr_Val
;
10542 elsif Chars
(Prop
) = Name_Effective_Reads
then
10543 Check_Duplicate_Property
(Prop
, ER_Seen
);
10544 ER_Val
:= Expr_Val
;
10547 Check_Duplicate_Property
(Prop
, EW_Seen
);
10548 EW_Val
:= Expr_Val
;
10551 -- The handling of property "others" must take into account
10552 -- all other named properties that have been encountered so
10553 -- far. Only those that have not been seen are affected by
10557 if not AR_Seen
then
10558 AR_Val
:= Expr_Val
;
10561 if not AW_Seen
then
10562 AW_Val
:= Expr_Val
;
10565 if not ER_Seen
then
10566 ER_Val
:= Expr_Val
;
10569 if not EW_Seen
then
10570 EW_Val
:= Expr_Val
;
10573 end Analyze_External_Property
;
10575 ----------------------------
10576 -- Analyze_Part_Of_Option --
10577 ----------------------------
10579 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10580 Encap
: constant Node_Id
:= Expression
(Opt
);
10581 Constits
: Elist_Id
;
10582 Encap_Id
: Entity_Id
;
10586 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10589 (Indic
=> First
(Choices
(Opt
)),
10590 Item_Id
=> State_Id
,
10592 Encap_Id
=> Encap_Id
,
10595 -- The Part_Of indicator transforms the abstract state into
10596 -- a constituent of the encapsulating state or single
10597 -- concurrent type.
10600 pragma Assert
(Present
(Encap_Id
));
10601 Constits
:= Part_Of_Constituents
(Encap_Id
);
10603 if No
(Constits
) then
10604 Constits
:= New_Elmt_List
;
10605 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
10608 Append_Elmt
(State_Id
, Constits
);
10609 Set_Encapsulating_State
(State_Id
, Encap_Id
);
10611 end Analyze_Part_Of_Option
;
10613 ----------------------------
10614 -- Check_Duplicate_Option --
10615 ----------------------------
10617 procedure Check_Duplicate_Option
10619 Status
: in out Boolean)
10623 SPARK_Msg_N
("duplicate state option", Opt
);
10627 end Check_Duplicate_Option
;
10629 ------------------------------
10630 -- Check_Duplicate_Property --
10631 ------------------------------
10633 procedure Check_Duplicate_Property
10635 Status
: in out Boolean)
10639 SPARK_Msg_N
("duplicate external property", Prop
);
10643 end Check_Duplicate_Property
;
10645 -----------------------------
10646 -- Check_Ghost_Synchronous --
10647 -----------------------------
10649 procedure Check_Ghost_Synchronous
is
10651 -- A synchronized abstract state cannot be Ghost and vice
10652 -- versa (SPARK RM 6.9(19)).
10654 if Ghost_Seen
and Synchronous_Seen
then
10655 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
10657 end Check_Ghost_Synchronous
;
10659 ---------------------------
10660 -- Create_Abstract_State --
10661 ---------------------------
10663 procedure Create_Abstract_State
10670 -- The abstract state may be semi-declared when the related
10671 -- package was withed through a limited with clause. In that
10672 -- case reuse the entity to fully declare the state.
10674 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10675 State_Id
:= Entity
(Decl
);
10677 -- Otherwise the elaboration of pragma Abstract_State
10678 -- declares the state.
10681 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10683 if Present
(Decl
) then
10684 Set_Entity
(Decl
, State_Id
);
10688 -- Null states never come from source
10690 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10691 Set_Parent
(State_Id
, State
);
10692 Set_Ekind
(State_Id
, E_Abstract_State
);
10693 Set_Etype
(State_Id
, Standard_Void_Type
);
10694 Set_Encapsulating_State
(State_Id
, Empty
);
10696 -- An abstract state declared within a Ghost region becomes
10697 -- Ghost (SPARK RM 6.9(2)).
10699 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
10700 Set_Is_Ghost_Entity
(State_Id
);
10703 -- Establish a link between the state declaration and the
10704 -- abstract state entity. Note that a null state remains as
10705 -- N_Null and does not carry any linkages.
10707 if not Is_Null
then
10708 if Present
(Decl
) then
10709 Set_Entity
(Decl
, State_Id
);
10710 Set_Etype
(Decl
, Standard_Void_Type
);
10713 -- Every non-null state must be defined, nameable and
10716 Push_Scope
(Pack_Id
);
10717 Generate_Definition
(State_Id
);
10718 Enter_Name
(State_Id
);
10721 end Create_Abstract_State
;
10728 -- Start of processing for Analyze_Abstract_State
10731 -- A package with a null abstract state is not allowed to
10732 -- declare additional states.
10736 ("package & has null abstract state", State
, Pack_Id
);
10738 -- Null states appear as internally generated entities
10740 elsif Nkind
(State
) = N_Null
then
10741 Create_Abstract_State
10742 (Nam
=> New_Internal_Name
('S'),
10744 Loc
=> Sloc
(State
),
10748 -- Catch a case where a null state appears in a list of
10749 -- non-null states.
10751 if Non_Null_Seen
then
10753 ("package & has non-null abstract state",
10757 -- Simple state declaration
10759 elsif Nkind
(State
) = N_Identifier
then
10760 Create_Abstract_State
10761 (Nam
=> Chars
(State
),
10763 Loc
=> Sloc
(State
),
10765 Non_Null_Seen
:= True;
10767 -- State declaration with various options. This construct
10768 -- appears as an extension aggregate in the tree.
10770 elsif Nkind
(State
) = N_Extension_Aggregate
then
10771 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
10772 Create_Abstract_State
10773 (Nam
=> Chars
(Ancestor_Part
(State
)),
10774 Decl
=> Ancestor_Part
(State
),
10775 Loc
=> Sloc
(Ancestor_Part
(State
)),
10777 Non_Null_Seen
:= True;
10780 ("state name must be an identifier",
10781 Ancestor_Part
(State
));
10784 -- Options External, Ghost and Synchronous appear as
10787 Opt
:= First
(Expressions
(State
));
10788 while Present
(Opt
) loop
10789 if Nkind
(Opt
) = N_Identifier
then
10793 if Chars
(Opt
) = Name_External
then
10794 Check_Duplicate_Option
(Opt
, External_Seen
);
10795 Analyze_External_Option
(Opt
);
10799 elsif Chars
(Opt
) = Name_Ghost
then
10800 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
10801 Check_Ghost_Synchronous
;
10803 if Present
(State_Id
) then
10804 Set_Is_Ghost_Entity
(State_Id
);
10809 elsif Chars
(Opt
) = Name_Synchronous
then
10810 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
10811 Check_Ghost_Synchronous
;
10813 -- Option Part_Of without an encapsulating state is
10814 -- illegal (SPARK RM 7.1.4(9)).
10816 elsif Chars
(Opt
) = Name_Part_Of
then
10818 ("indicator Part_Of must denote abstract state, "
10819 & "single protected type or single task type",
10822 -- Do not emit an error message when a previous state
10823 -- declaration with options was not parenthesized as
10824 -- the option is actually another state declaration.
10826 -- with Abstract_State
10827 -- (State_1 with ..., -- missing parentheses
10828 -- (State_2 with ...),
10829 -- State_3) -- ok state declaration
10831 elsif Missing_Parentheses
then
10834 -- Otherwise the option is not allowed. Note that it
10835 -- is not possible to distinguish between an option
10836 -- and a state declaration when a previous state with
10837 -- options not properly parentheses.
10839 -- with Abstract_State
10840 -- (State_1 with ..., -- missing parentheses
10841 -- State_2); -- could be an option
10845 ("simple option not allowed in state declaration",
10849 -- Catch a case where missing parentheses around a state
10850 -- declaration with options cause a subsequent state
10851 -- declaration with options to be treated as an option.
10853 -- with Abstract_State
10854 -- (State_1 with ..., -- missing parentheses
10855 -- (State_2 with ...))
10857 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
10858 Missing_Parentheses
:= True;
10860 ("state declaration must be parenthesized",
10861 Ancestor_Part
(State
));
10863 -- Otherwise the option is malformed
10866 SPARK_Msg_N
("malformed option", Opt
);
10872 -- Options External and Part_Of appear as component
10875 Opt
:= First
(Component_Associations
(State
));
10876 while Present
(Opt
) loop
10877 Opt_Nam
:= First
(Choices
(Opt
));
10879 if Nkind
(Opt_Nam
) = N_Identifier
then
10880 if Chars
(Opt_Nam
) = Name_External
then
10881 Analyze_External_Option
(Opt
);
10883 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
10884 Analyze_Part_Of_Option
(Opt
);
10887 SPARK_Msg_N
("invalid state option", Opt
);
10890 SPARK_Msg_N
("invalid state option", Opt
);
10896 -- Any other attempt to declare a state is illegal
10899 Malformed_State_Error
(State
);
10903 -- Guard against a junk state. In such cases no entity is
10904 -- generated and the subsequent checks cannot be applied.
10906 if Present
(State_Id
) then
10908 -- Verify whether the state does not introduce an illegal
10909 -- hidden state within a package subject to a null abstract
10912 Check_No_Hidden_State
(State_Id
);
10914 -- Check whether the lack of option Part_Of agrees with the
10915 -- placement of the abstract state with respect to the state
10918 if not Part_Of_Seen
then
10919 Check_Missing_Part_Of
(State_Id
);
10922 -- Associate the state with its related package
10924 if No
(Abstract_States
(Pack_Id
)) then
10925 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
10928 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
10930 end Analyze_Abstract_State
;
10932 ---------------------------
10933 -- Malformed_State_Error --
10934 ---------------------------
10936 procedure Malformed_State_Error
(State
: Node_Id
) is
10938 Error_Msg_N
("malformed abstract state declaration", State
);
10940 -- An abstract state with a simple option is being declared
10941 -- with "=>" rather than the legal "with". The state appears
10942 -- as a component association.
10944 if Nkind
(State
) = N_Component_Association
then
10945 Error_Msg_N
("\use WITH to specify simple option", State
);
10947 end Malformed_State_Error
;
10951 Pack_Decl
: Node_Id
;
10952 Pack_Id
: Entity_Id
;
10956 -- Start of processing for Abstract_State
10960 Check_No_Identifiers
;
10961 Check_Arg_Count
(1);
10963 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
10965 -- Ensure the proper placement of the pragma. Abstract states must
10966 -- be associated with a package declaration.
10968 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
10969 N_Package_Declaration
)
10973 -- Otherwise the pragma is associated with an illegal construct
10980 Pack_Id
:= Defining_Entity
(Pack_Decl
);
10982 -- Chain the pragma on the contract for completeness
10984 Add_Contract_Item
(N
, Pack_Id
);
10986 -- The legality checks of pragmas Abstract_State, Initializes, and
10987 -- Initial_Condition are affected by the SPARK mode in effect. In
10988 -- addition, these three pragmas are subject to an inherent order:
10990 -- 1) Abstract_State
10992 -- 3) Initial_Condition
10994 -- Analyze all these pragmas in the order outlined above
10996 Analyze_If_Present
(Pragma_SPARK_Mode
);
10998 -- A pragma that applies to a Ghost entity becomes Ghost for the
10999 -- purposes of legality checks and removal of ignored Ghost code.
11001 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
11002 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11004 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11006 -- Multiple non-null abstract states appear as an aggregate
11008 if Nkind
(States
) = N_Aggregate
then
11009 State
:= First
(Expressions
(States
));
11010 while Present
(State
) loop
11011 Analyze_Abstract_State
(State
, Pack_Id
);
11015 -- An abstract state with a simple option is being illegaly
11016 -- declared with "=>" rather than "with". In this case the
11017 -- state declaration appears as a component association.
11019 if Present
(Component_Associations
(States
)) then
11020 State
:= First
(Component_Associations
(States
));
11021 while Present
(State
) loop
11022 Malformed_State_Error
(State
);
11027 -- Various forms of a single abstract state. Note that these may
11028 -- include malformed state declarations.
11031 Analyze_Abstract_State
(States
, Pack_Id
);
11034 Analyze_If_Present
(Pragma_Initializes
);
11035 Analyze_If_Present
(Pragma_Initial_Condition
);
11036 end Abstract_State
;
11044 -- Note: this pragma also has some specific processing in Par.Prag
11045 -- because we want to set the Ada version mode during parsing.
11047 when Pragma_Ada_83
=>
11049 Check_Arg_Count
(0);
11051 -- We really should check unconditionally for proper configuration
11052 -- pragma placement, since we really don't want mixed Ada modes
11053 -- within a single unit, and the GNAT reference manual has always
11054 -- said this was a configuration pragma, but we did not check and
11055 -- are hesitant to add the check now.
11057 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11058 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11059 -- or Ada 2012 mode.
11061 if Ada_Version
>= Ada_2005
then
11062 Check_Valid_Configuration_Pragma
;
11065 -- Now set Ada 83 mode
11067 Ada_Version
:= Ada_83
;
11068 Ada_Version_Explicit
:= Ada_83
;
11069 Ada_Version_Pragma
:= N
;
11077 -- Note: this pragma also has some specific processing in Par.Prag
11078 -- because we want to set the Ada 83 version mode during parsing.
11080 when Pragma_Ada_95
=>
11082 Check_Arg_Count
(0);
11084 -- We really should check unconditionally for proper configuration
11085 -- pragma placement, since we really don't want mixed Ada modes
11086 -- within a single unit, and the GNAT reference manual has always
11087 -- said this was a configuration pragma, but we did not check and
11088 -- are hesitant to add the check now.
11090 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11091 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11093 if Ada_Version
>= Ada_2005
then
11094 Check_Valid_Configuration_Pragma
;
11097 -- Now set Ada 95 mode
11099 Ada_Version
:= Ada_95
;
11100 Ada_Version_Explicit
:= Ada_95
;
11101 Ada_Version_Pragma
:= N
;
11103 ---------------------
11104 -- Ada_05/Ada_2005 --
11105 ---------------------
11108 -- pragma Ada_05 (LOCAL_NAME);
11110 -- pragma Ada_2005;
11111 -- pragma Ada_2005 (LOCAL_NAME):
11113 -- Note: these pragmas also have some specific processing in Par.Prag
11114 -- because we want to set the Ada 2005 version mode during parsing.
11116 -- The one argument form is used for managing the transition from
11117 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11118 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11119 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11120 -- mode, a preference rule is established which does not choose
11121 -- such an entity unless it is unambiguously specified. This avoids
11122 -- extra subprograms marked this way from generating ambiguities in
11123 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11124 -- intended for exclusive use in the GNAT run-time library.
11126 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
11132 if Arg_Count
= 1 then
11133 Check_Arg_Is_Local_Name
(Arg1
);
11134 E_Id
:= Get_Pragma_Arg
(Arg1
);
11136 if Etype
(E_Id
) = Any_Type
then
11140 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
11141 Record_Rep_Item
(Entity
(E_Id
), N
);
11144 Check_Arg_Count
(0);
11146 -- For Ada_2005 we unconditionally enforce the documented
11147 -- configuration pragma placement, since we do not want to
11148 -- tolerate mixed modes in a unit involving Ada 2005. That
11149 -- would cause real difficulties for those cases where there
11150 -- are incompatibilities between Ada 95 and Ada 2005.
11152 Check_Valid_Configuration_Pragma
;
11154 -- Now set appropriate Ada mode
11156 Ada_Version
:= Ada_2005
;
11157 Ada_Version_Explicit
:= Ada_2005
;
11158 Ada_Version_Pragma
:= N
;
11162 ---------------------
11163 -- Ada_12/Ada_2012 --
11164 ---------------------
11167 -- pragma Ada_12 (LOCAL_NAME);
11169 -- pragma Ada_2012;
11170 -- pragma Ada_2012 (LOCAL_NAME):
11172 -- Note: these pragmas also have some specific processing in Par.Prag
11173 -- because we want to set the Ada 2012 version mode during parsing.
11175 -- The one argument form is used for managing the transition from Ada
11176 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11177 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11178 -- mode will generate a warning. In addition, in any pre-Ada_2012
11179 -- mode, a preference rule is established which does not choose
11180 -- such an entity unless it is unambiguously specified. This avoids
11181 -- extra subprograms marked this way from generating ambiguities in
11182 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11183 -- intended for exclusive use in the GNAT run-time library.
11185 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
11191 if Arg_Count
= 1 then
11192 Check_Arg_Is_Local_Name
(Arg1
);
11193 E_Id
:= Get_Pragma_Arg
(Arg1
);
11195 if Etype
(E_Id
) = Any_Type
then
11199 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
11200 Record_Rep_Item
(Entity
(E_Id
), N
);
11203 Check_Arg_Count
(0);
11205 -- For Ada_2012 we unconditionally enforce the documented
11206 -- configuration pragma placement, since we do not want to
11207 -- tolerate mixed modes in a unit involving Ada 2012. That
11208 -- would cause real difficulties for those cases where there
11209 -- are incompatibilities between Ada 95 and Ada 2012. We could
11210 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11212 Check_Valid_Configuration_Pragma
;
11214 -- Now set appropriate Ada mode
11216 Ada_Version
:= Ada_2012
;
11217 Ada_Version_Explicit
:= Ada_2012
;
11218 Ada_Version_Pragma
:= N
;
11222 ----------------------
11223 -- All_Calls_Remote --
11224 ----------------------
11226 -- pragma All_Calls_Remote [(library_package_NAME)];
11228 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
11229 Lib_Entity
: Entity_Id
;
11232 Check_Ada_83_Warning
;
11233 Check_Valid_Library_Unit_Pragma
;
11235 if Nkind
(N
) = N_Null_Statement
then
11239 Lib_Entity
:= Find_Lib_Unit_Name
;
11241 -- A pragma that applies to a Ghost entity becomes Ghost for the
11242 -- purposes of legality checks and removal of ignored Ghost code.
11244 Mark_Pragma_As_Ghost
(N
, Lib_Entity
);
11246 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11248 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
11249 if not Is_Remote_Call_Interface
(Lib_Entity
) then
11250 Error_Pragma
("pragma% only apply to rci unit");
11252 -- Set flag for entity of the library unit
11255 Set_Has_All_Calls_Remote
(Lib_Entity
);
11258 end All_Calls_Remote
;
11260 ---------------------------
11261 -- Allow_Integer_Address --
11262 ---------------------------
11264 -- pragma Allow_Integer_Address;
11266 when Pragma_Allow_Integer_Address
=>
11268 Check_Valid_Configuration_Pragma
;
11269 Check_Arg_Count
(0);
11271 -- If Address is a private type, then set the flag to allow
11272 -- integer address values. If Address is not private, then this
11273 -- pragma has no purpose, so it is simply ignored. Not clear if
11274 -- there are any such targets now.
11276 if Opt
.Address_Is_Private
then
11277 Opt
.Allow_Integer_Address
:= True;
11285 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11286 -- ARG ::= NAME | EXPRESSION
11288 -- The first two arguments are by convention intended to refer to an
11289 -- external tool and a tool-specific function. These arguments are
11292 when Pragma_Annotate
=> Annotate
: declare
11299 Check_At_Least_N_Arguments
(1);
11301 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
11303 -- Determine whether the last argument is "Entity => local_NAME"
11304 -- and if it is, perform the required semantic checks. Remove the
11305 -- argument from further processing.
11307 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
11308 and then Chars
(Nam_Arg
) = Name_Entity
11310 Check_Arg_Is_Local_Name
(Nam_Arg
);
11311 Arg_Count
:= Arg_Count
- 1;
11313 -- A pragma that applies to a Ghost entity becomes Ghost for
11314 -- the purposes of legality checks and removal of ignored Ghost
11317 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
11318 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
11320 Mark_Pragma_As_Ghost
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
11323 -- Not allowed in compiler units (bootstrap issues)
11325 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
11328 -- Continue the processing with last argument removed for now
11330 Check_Arg_Is_Identifier
(Arg1
);
11331 Check_No_Identifiers
;
11334 -- The second parameter is optional, it is never analyzed
11339 -- Otherwise there is a second parameter
11342 -- The second parameter must be an identifier
11344 Check_Arg_Is_Identifier
(Arg2
);
11346 -- Process the remaining parameters (if any)
11348 Arg
:= Next
(Arg2
);
11349 while Present
(Arg
) loop
11350 Expr
:= Get_Pragma_Arg
(Arg
);
11353 if Is_Entity_Name
(Expr
) then
11356 -- For string literals, we assume Standard_String as the
11357 -- type, unless the string contains wide or wide_wide
11360 elsif Nkind
(Expr
) = N_String_Literal
then
11361 if Has_Wide_Wide_Character
(Expr
) then
11362 Resolve
(Expr
, Standard_Wide_Wide_String
);
11363 elsif Has_Wide_Character
(Expr
) then
11364 Resolve
(Expr
, Standard_Wide_String
);
11366 Resolve
(Expr
, Standard_String
);
11369 elsif Is_Overloaded
(Expr
) then
11370 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
11381 -------------------------------------------------
11382 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11383 -------------------------------------------------
11386 -- ( [Check => ] Boolean_EXPRESSION
11387 -- [, [Message =>] Static_String_EXPRESSION]);
11389 -- pragma Assert_And_Cut
11390 -- ( [Check => ] Boolean_EXPRESSION
11391 -- [, [Message =>] Static_String_EXPRESSION]);
11394 -- ( [Check => ] Boolean_EXPRESSION
11395 -- [, [Message =>] Static_String_EXPRESSION]);
11397 -- pragma Loop_Invariant
11398 -- ( [Check => ] Boolean_EXPRESSION
11399 -- [, [Message =>] Static_String_EXPRESSION]);
11401 when Pragma_Assert |
11402 Pragma_Assert_And_Cut |
11404 Pragma_Loop_Invariant
=>
11406 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
11407 -- Determine whether expression Expr contains a Loop_Entry
11408 -- attribute reference.
11410 -------------------------
11411 -- Contains_Loop_Entry --
11412 -------------------------
11414 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
11415 Has_Loop_Entry
: Boolean := False;
11417 function Process
(N
: Node_Id
) return Traverse_Result
;
11418 -- Process function for traversal to look for Loop_Entry
11424 function Process
(N
: Node_Id
) return Traverse_Result
is
11426 if Nkind
(N
) = N_Attribute_Reference
11427 and then Attribute_Name
(N
) = Name_Loop_Entry
11429 Has_Loop_Entry
:= True;
11436 procedure Traverse
is new Traverse_Proc
(Process
);
11438 -- Start of processing for Contains_Loop_Entry
11442 return Has_Loop_Entry
;
11443 end Contains_Loop_Entry
;
11448 New_Args
: List_Id
;
11450 -- Start of processing for Assert
11453 -- Assert is an Ada 2005 RM-defined pragma
11455 if Prag_Id
= Pragma_Assert
then
11458 -- The remaining ones are GNAT pragmas
11464 Check_At_Least_N_Arguments
(1);
11465 Check_At_Most_N_Arguments
(2);
11466 Check_Arg_Order
((Name_Check
, Name_Message
));
11467 Check_Optional_Identifier
(Arg1
, Name_Check
);
11468 Expr
:= Get_Pragma_Arg
(Arg1
);
11470 -- Special processing for Loop_Invariant, Loop_Variant or for
11471 -- other cases where a Loop_Entry attribute is present. If the
11472 -- assertion pragma contains attribute Loop_Entry, ensure that
11473 -- the related pragma is within a loop.
11475 if Prag_Id
= Pragma_Loop_Invariant
11476 or else Prag_Id
= Pragma_Loop_Variant
11477 or else Contains_Loop_Entry
(Expr
)
11479 Check_Loop_Pragma_Placement
;
11481 -- Perform preanalysis to deal with embedded Loop_Entry
11484 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
11487 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11488 -- a corresponding Check pragma:
11490 -- pragma Check (name, condition [, msg]);
11492 -- Where name is the identifier matching the pragma name. So
11493 -- rewrite pragma in this manner, transfer the message argument
11494 -- if present, and analyze the result
11496 -- Note: When dealing with a semantically analyzed tree, the
11497 -- information that a Check node N corresponds to a source Assert,
11498 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11499 -- pragma kind of Original_Node(N).
11501 New_Args
:= New_List
(
11502 Make_Pragma_Argument_Association
(Loc
,
11503 Expression
=> Make_Identifier
(Loc
, Pname
)),
11504 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11505 Expression
=> Expr
));
11507 if Arg_Count
> 1 then
11508 Check_Optional_Identifier
(Arg2
, Name_Message
);
11510 -- Provide semantic annnotations for optional argument, for
11511 -- ASIS use, before rewriting.
11513 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11514 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
11517 -- Rewrite as Check pragma
11521 Chars
=> Name_Check
,
11522 Pragma_Argument_Associations
=> New_Args
));
11527 ----------------------
11528 -- Assertion_Policy --
11529 ----------------------
11531 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11533 -- The following form is Ada 2012 only, but we allow it in all modes
11535 -- Pragma Assertion_Policy (
11536 -- ASSERTION_KIND => POLICY_IDENTIFIER
11537 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11539 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11541 -- RM_ASSERTION_KIND ::= Assert |
11542 -- Static_Predicate |
11543 -- Dynamic_Predicate |
11548 -- Type_Invariant |
11549 -- Type_Invariant'Class
11551 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11553 -- Contract_Cases |
11555 -- Default_Initial_Condition |
11557 -- Initial_Condition |
11558 -- Loop_Invariant |
11564 -- Statement_Assertions
11566 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11567 -- ID_ASSERTION_KIND list contains implementation-defined additions
11568 -- recognized by GNAT. The effect is to control the behavior of
11569 -- identically named aspects and pragmas, depending on the specified
11570 -- policy identifier:
11572 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11574 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11575 -- implementation-defined addition that results in totally ignoring
11576 -- the corresponding assertion. If Disable is specified, then the
11577 -- argument of the assertion is not even analyzed. This is useful
11578 -- when the aspect/pragma argument references entities in a with'ed
11579 -- package that is replaced by a dummy package in the final build.
11581 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11582 -- and Type_Invariant'Class were recognized by the parser and
11583 -- transformed into references to the special internal identifiers
11584 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11585 -- processing is required here.
11587 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11596 -- This can always appear as a configuration pragma
11598 if Is_Configuration_Pragma
then
11601 -- It can also appear in a declarative part or package spec in Ada
11602 -- 2012 mode. We allow this in other modes, but in that case we
11603 -- consider that we have an Ada 2012 pragma on our hands.
11606 Check_Is_In_Decl_Part_Or_Package_Spec
;
11610 -- One argument case with no identifier (first form above)
11613 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11614 or else Chars
(Arg1
) = No_Name
)
11616 Check_Arg_Is_One_Of
11617 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11619 -- Treat one argument Assertion_Policy as equivalent to:
11621 -- pragma Check_Policy (Assertion, policy)
11623 -- So rewrite pragma in that manner and link on to the chain
11624 -- of Check_Policy pragmas, marking the pragma as analyzed.
11626 Policy
:= Get_Pragma_Arg
(Arg1
);
11630 Chars
=> Name_Check_Policy
,
11631 Pragma_Argument_Associations
=> New_List
(
11632 Make_Pragma_Argument_Association
(Loc
,
11633 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11635 Make_Pragma_Argument_Association
(Loc
,
11637 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11640 -- Here if we have two or more arguments
11643 Check_At_Least_N_Arguments
(1);
11646 -- Loop through arguments
11649 while Present
(Arg
) loop
11650 LocP
:= Sloc
(Arg
);
11652 -- Kind must be specified
11654 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11655 or else Chars
(Arg
) = No_Name
11658 ("missing assertion kind for pragma%", Arg
);
11661 -- Check Kind and Policy have allowed forms
11663 Kind
:= Chars
(Arg
);
11664 Policy
:= Get_Pragma_Arg
(Arg
);
11666 if not Is_Valid_Assertion_Kind
(Kind
) then
11668 ("invalid assertion kind for pragma%", Arg
);
11671 Check_Arg_Is_One_Of
11672 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11674 if Kind
= Name_Ghost
then
11676 -- The Ghost policy must be either Check or Ignore
11677 -- (SPARK RM 6.9(6)).
11679 if not Nam_In
(Chars
(Policy
), Name_Check
,
11683 ("argument of pragma % Ghost must be Check or "
11684 & "Ignore", Policy
);
11687 -- Pragma Assertion_Policy specifying a Ghost policy
11688 -- cannot occur within a Ghost subprogram or package
11689 -- (SPARK RM 6.9(14)).
11691 if Ghost_Mode
> None
then
11693 ("pragma % cannot appear within ghost subprogram or "
11698 -- Rewrite the Assertion_Policy pragma as a series of
11699 -- Check_Policy pragmas of the form:
11701 -- Check_Policy (Kind, Policy);
11703 -- Note: the insertion of the pragmas cannot be done with
11704 -- Insert_Action because in the configuration case, there
11705 -- are no scopes on the scope stack and the mechanism will
11708 Insert_Before_And_Analyze
(N
,
11710 Chars
=> Name_Check_Policy
,
11711 Pragma_Argument_Associations
=> New_List
(
11712 Make_Pragma_Argument_Association
(LocP
,
11713 Expression
=> Make_Identifier
(LocP
, Kind
)),
11714 Make_Pragma_Argument_Association
(LocP
,
11715 Expression
=> Policy
))));
11720 -- Rewrite the Assertion_Policy pragma as null since we have
11721 -- now inserted all the equivalent Check pragmas.
11723 Rewrite
(N
, Make_Null_Statement
(Loc
));
11726 end Assertion_Policy
;
11728 ------------------------------
11729 -- Assume_No_Invalid_Values --
11730 ------------------------------
11732 -- pragma Assume_No_Invalid_Values (On | Off);
11734 when Pragma_Assume_No_Invalid_Values
=>
11736 Check_Valid_Configuration_Pragma
;
11737 Check_Arg_Count
(1);
11738 Check_No_Identifiers
;
11739 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
11741 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
11742 Assume_No_Invalid_Values
:= True;
11744 Assume_No_Invalid_Values
:= False;
11747 --------------------------
11748 -- Attribute_Definition --
11749 --------------------------
11751 -- pragma Attribute_Definition
11752 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
11753 -- [Entity =>] LOCAL_NAME,
11754 -- [Expression =>] EXPRESSION | NAME);
11756 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
11757 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
11762 Check_Arg_Count
(3);
11763 Check_Optional_Identifier
(Arg1
, "attribute");
11764 Check_Optional_Identifier
(Arg2
, "entity");
11765 Check_Optional_Identifier
(Arg3
, "expression");
11767 if Nkind
(Attribute_Designator
) /= N_Identifier
then
11768 Error_Msg_N
("attribute name expected", Attribute_Designator
);
11772 Check_Arg_Is_Local_Name
(Arg2
);
11774 -- If the attribute is not recognized, then issue a warning (not
11775 -- an error), and ignore the pragma.
11777 Aname
:= Chars
(Attribute_Designator
);
11779 if not Is_Attribute_Name
(Aname
) then
11780 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
11784 -- Otherwise, rewrite the pragma as an attribute definition clause
11787 Make_Attribute_Definition_Clause
(Loc
,
11788 Name
=> Get_Pragma_Arg
(Arg2
),
11790 Expression
=> Get_Pragma_Arg
(Arg3
)));
11792 end Attribute_Definition
;
11794 ------------------------------------------------------------------
11795 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
11796 ------------------------------------------------------------------
11798 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
11799 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
11800 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
11801 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
11803 when Pragma_Async_Readers |
11804 Pragma_Async_Writers |
11805 Pragma_Effective_Reads |
11806 Pragma_Effective_Writes
=>
11807 Async_Effective
: declare
11808 Obj_Decl
: Node_Id
;
11809 Obj_Id
: Entity_Id
;
11813 Check_No_Identifiers
;
11814 Check_At_Most_N_Arguments
(1);
11816 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
11818 -- Object declaration
11820 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
11823 -- Otherwise the pragma is associated with an illegal construact
11830 Obj_Id
:= Defining_Entity
(Obj_Decl
);
11832 -- Perform minimal verification to ensure that the argument is at
11833 -- least a variable. Subsequent finer grained checks will be done
11834 -- at the end of the declarative region the contains the pragma.
11836 if Ekind
(Obj_Id
) = E_Variable
then
11838 -- Chain the pragma on the contract for further processing by
11839 -- Analyze_External_Property_In_Decl_Part.
11841 Add_Contract_Item
(N
, Obj_Id
);
11843 -- A pragma that applies to a Ghost entity becomes Ghost for
11844 -- the purposes of legality checks and removal of ignored Ghost
11847 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
11849 -- Analyze the Boolean expression (if any)
11851 if Present
(Arg1
) then
11852 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
11855 -- Otherwise the external property applies to a constant
11858 Error_Pragma
("pragma % must apply to a volatile object");
11860 end Async_Effective
;
11866 -- pragma Asynchronous (LOCAL_NAME);
11868 when Pragma_Asynchronous
=> Asynchronous
: declare
11871 Formal
: Entity_Id
;
11876 procedure Process_Async_Pragma
;
11877 -- Common processing for procedure and access-to-procedure case
11879 --------------------------
11880 -- Process_Async_Pragma --
11881 --------------------------
11883 procedure Process_Async_Pragma
is
11886 Set_Is_Asynchronous
(Nm
);
11890 -- The formals should be of mode IN (RM E.4.1(6))
11893 while Present
(S
) loop
11894 Formal
:= Defining_Identifier
(S
);
11896 if Nkind
(Formal
) = N_Defining_Identifier
11897 and then Ekind
(Formal
) /= E_In_Parameter
11900 ("pragma% procedure can only have IN parameter",
11907 Set_Is_Asynchronous
(Nm
);
11908 end Process_Async_Pragma
;
11910 -- Start of processing for pragma Asynchronous
11913 Check_Ada_83_Warning
;
11914 Check_No_Identifiers
;
11915 Check_Arg_Count
(1);
11916 Check_Arg_Is_Local_Name
(Arg1
);
11918 if Debug_Flag_U
then
11922 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
11923 Analyze
(Get_Pragma_Arg
(Arg1
));
11924 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
11926 -- A pragma that applies to a Ghost entity becomes Ghost for the
11927 -- purposes of legality checks and removal of ignored Ghost code.
11929 Mark_Pragma_As_Ghost
(N
, Nm
);
11931 if not Is_Remote_Call_Interface
(C_Ent
)
11932 and then not Is_Remote_Types
(C_Ent
)
11934 -- This pragma should only appear in an RCI or Remote Types
11935 -- unit (RM E.4.1(4)).
11938 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
11941 if Ekind
(Nm
) = E_Procedure
11942 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
11944 if not Is_Remote_Call_Interface
(Nm
) then
11946 ("pragma% cannot be applied on non-remote procedure",
11950 L
:= Parameter_Specifications
(Parent
(Nm
));
11951 Process_Async_Pragma
;
11954 elsif Ekind
(Nm
) = E_Function
then
11956 ("pragma% cannot be applied to function", Arg1
);
11958 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
11959 if Is_Record_Type
(Nm
) then
11961 -- A record type that is the Equivalent_Type for a remote
11962 -- access-to-subprogram type.
11964 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
11967 -- A non-expanded RAS type (distribution is not enabled)
11969 Decl
:= Declaration_Node
(Nm
);
11972 if Nkind
(Decl
) = N_Full_Type_Declaration
11973 and then Nkind
(Type_Definition
(Decl
)) =
11974 N_Access_Procedure_Definition
11976 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
11977 Process_Async_Pragma
;
11979 if Is_Asynchronous
(Nm
)
11980 and then Expander_Active
11981 and then Get_PCS_Name
/= Name_No_DSA
11983 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
11988 ("pragma% cannot reference access-to-function type",
11992 -- Only other possibility is Access-to-class-wide type
11994 elsif Is_Access_Type
(Nm
)
11995 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
11997 Check_First_Subtype
(Arg1
);
11998 Set_Is_Asynchronous
(Nm
);
11999 if Expander_Active
then
12000 RACW_Type_Is_Asynchronous
(Nm
);
12004 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12012 -- pragma Atomic (LOCAL_NAME);
12014 when Pragma_Atomic
=>
12015 Process_Atomic_Independent_Shared_Volatile
;
12017 -----------------------
12018 -- Atomic_Components --
12019 -----------------------
12021 -- pragma Atomic_Components (array_LOCAL_NAME);
12023 -- This processing is shared by Volatile_Components
12025 when Pragma_Atomic_Components |
12026 Pragma_Volatile_Components
=>
12027 Atomic_Components
: declare
12034 Check_Ada_83_Warning
;
12035 Check_No_Identifiers
;
12036 Check_Arg_Count
(1);
12037 Check_Arg_Is_Local_Name
(Arg1
);
12038 E_Id
:= Get_Pragma_Arg
(Arg1
);
12040 if Etype
(E_Id
) = Any_Type
then
12044 E
:= Entity
(E_Id
);
12046 -- A pragma that applies to a Ghost entity becomes Ghost for the
12047 -- purposes of legality checks and removal of ignored Ghost code.
12049 Mark_Pragma_As_Ghost
(N
, E
);
12050 Check_Duplicate_Pragma
(E
);
12052 if Rep_Item_Too_Early
(E
, N
)
12054 Rep_Item_Too_Late
(E
, N
)
12059 D
:= Declaration_Node
(E
);
12062 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
12064 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
12065 and then Nkind
(D
) = N_Object_Declaration
12066 and then Nkind
(Object_Definition
(D
)) =
12067 N_Constrained_Array_Definition
)
12069 -- The flag is set on the object, or on the base type
12071 if Nkind
(D
) /= N_Object_Declaration
then
12072 E
:= Base_Type
(E
);
12075 -- Atomic implies both Independent and Volatile
12077 if Prag_Id
= Pragma_Atomic_Components
then
12078 Set_Has_Atomic_Components
(E
);
12079 Set_Has_Independent_Components
(E
);
12082 Set_Has_Volatile_Components
(E
);
12085 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
12087 end Atomic_Components
;
12089 --------------------
12090 -- Attach_Handler --
12091 --------------------
12093 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12095 when Pragma_Attach_Handler
=>
12096 Check_Ada_83_Warning
;
12097 Check_No_Identifiers
;
12098 Check_Arg_Count
(2);
12100 if No_Run_Time_Mode
then
12101 Error_Msg_CRT
("Attach_Handler pragma", N
);
12103 Check_Interrupt_Or_Attach_Handler
;
12105 -- The expression that designates the attribute may depend on a
12106 -- discriminant, and is therefore a per-object expression, to
12107 -- be expanded in the init proc. If expansion is enabled, then
12108 -- perform semantic checks on a copy only.
12113 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
12116 -- In Relaxed_RM_Semantics mode, we allow any static
12117 -- integer value, for compatibility with other compilers.
12119 if Relaxed_RM_Semantics
12120 and then Nkind
(Parg2
) = N_Integer_Literal
12122 Typ
:= Standard_Integer
;
12124 Typ
:= RTE
(RE_Interrupt_ID
);
12127 if Expander_Active
then
12128 Temp
:= New_Copy_Tree
(Parg2
);
12129 Set_Parent
(Temp
, N
);
12130 Preanalyze_And_Resolve
(Temp
, Typ
);
12133 Resolve
(Parg2
, Typ
);
12137 Process_Interrupt_Or_Attach_Handler
;
12140 --------------------
12141 -- C_Pass_By_Copy --
12142 --------------------
12144 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12146 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
12152 Check_Valid_Configuration_Pragma
;
12153 Check_Arg_Count
(1);
12154 Check_Optional_Identifier
(Arg1
, "max_size");
12156 Arg
:= Get_Pragma_Arg
(Arg1
);
12157 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
12159 Val
:= Expr_Value
(Arg
);
12163 ("maximum size for pragma% must be positive", Arg1
);
12165 elsif UI_Is_In_Int_Range
(Val
) then
12166 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
12168 -- If a giant value is given, Int'Last will do well enough.
12169 -- If sometime someone complains that a record larger than
12170 -- two gigabytes is not copied, we will worry about it then.
12173 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
12175 end C_Pass_By_Copy
;
12181 -- pragma Check ([Name =>] CHECK_KIND,
12182 -- [Check =>] Boolean_EXPRESSION
12183 -- [,[Message =>] String_EXPRESSION]);
12185 -- CHECK_KIND ::= IDENTIFIER |
12188 -- Invariant'Class |
12189 -- Type_Invariant'Class
12191 -- The identifiers Assertions and Statement_Assertions are not
12192 -- allowed, since they have special meaning for Check_Policy.
12194 when Pragma_Check
=> Check
: declare
12200 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
12203 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12204 -- the mode now to ensure that any nodes generated during analysis
12205 -- and expansion are marked as Ghost.
12207 Set_Ghost_Mode
(N
);
12210 Check_At_Least_N_Arguments
(2);
12211 Check_At_Most_N_Arguments
(3);
12212 Check_Optional_Identifier
(Arg1
, Name_Name
);
12213 Check_Optional_Identifier
(Arg2
, Name_Check
);
12215 if Arg_Count
= 3 then
12216 Check_Optional_Identifier
(Arg3
, Name_Message
);
12217 Str
:= Get_Pragma_Arg
(Arg3
);
12220 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
12221 Check_Arg_Is_Identifier
(Arg1
);
12222 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
12224 -- Check forbidden name Assertions or Statement_Assertions
12227 when Name_Assertions
=>
12229 ("""Assertions"" is not allowed as a check kind for "
12230 & "pragma%", Arg1
);
12232 when Name_Statement_Assertions
=>
12234 ("""Statement_Assertions"" is not allowed as a check kind "
12235 & "for pragma%", Arg1
);
12241 -- Check applicable policy. We skip this if Checked/Ignored status
12242 -- is already set (e.g. in the case of a pragma from an aspect).
12244 if Is_Checked
(N
) or else Is_Ignored
(N
) then
12247 -- For a non-source pragma that is a rewriting of another pragma,
12248 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12250 elsif Is_Rewrite_Substitution
(N
)
12251 and then Nkind
(Original_Node
(N
)) = N_Pragma
12252 and then Original_Node
(N
) /= N
12254 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12255 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12257 -- Otherwise query the applicable policy at this point
12260 case Check_Kind
(Cname
) is
12261 when Name_Ignore
=>
12262 Set_Is_Ignored
(N
, True);
12263 Set_Is_Checked
(N
, False);
12266 Set_Is_Ignored
(N
, False);
12267 Set_Is_Checked
(N
, True);
12269 -- For disable, rewrite pragma as null statement and skip
12270 -- rest of the analysis of the pragma.
12272 when Name_Disable
=>
12273 Rewrite
(N
, Make_Null_Statement
(Loc
));
12277 -- No other possibilities
12280 raise Program_Error
;
12284 -- If check kind was not Disable, then continue pragma analysis
12286 Expr
:= Get_Pragma_Arg
(Arg2
);
12288 -- Deal with SCO generation
12292 -- Nothing to do for predicates as the checks occur in the
12293 -- client units. The SCO for the aspect in the declaration
12294 -- unit is conservatively always enabled.
12296 when Name_Predicate
=>
12299 -- Otherwise mark aspect/pragma SCO as enabled
12302 if Is_Checked
(N
) and then not Split_PPC
(N
) then
12303 Set_SCO_Pragma_Enabled
(Loc
);
12307 -- Deal with analyzing the string argument
12309 if Arg_Count
= 3 then
12311 -- If checks are not on we don't want any expansion (since
12312 -- such expansion would not get properly deleted) but
12313 -- we do want to analyze (to get proper references).
12314 -- The Preanalyze_And_Resolve routine does just what we want
12316 if Is_Ignored
(N
) then
12317 Preanalyze_And_Resolve
(Str
, Standard_String
);
12319 -- Otherwise we need a proper analysis and expansion
12322 Analyze_And_Resolve
(Str
, Standard_String
);
12326 -- Now you might think we could just do the same with the Boolean
12327 -- expression if checks are off (and expansion is on) and then
12328 -- rewrite the check as a null statement. This would work but we
12329 -- would lose the useful warnings about an assertion being bound
12330 -- to fail even if assertions are turned off.
12332 -- So instead we wrap the boolean expression in an if statement
12333 -- that looks like:
12335 -- if False and then condition then
12339 -- The reason we do this rewriting during semantic analysis rather
12340 -- than as part of normal expansion is that we cannot analyze and
12341 -- expand the code for the boolean expression directly, or it may
12342 -- cause insertion of actions that would escape the attempt to
12343 -- suppress the check code.
12345 -- Note that the Sloc for the if statement corresponds to the
12346 -- argument condition, not the pragma itself. The reason for
12347 -- this is that we may generate a warning if the condition is
12348 -- False at compile time, and we do not want to delete this
12349 -- warning when we delete the if statement.
12351 if Expander_Active
and Is_Ignored
(N
) then
12352 Eloc
:= Sloc
(Expr
);
12355 Make_If_Statement
(Eloc
,
12357 Make_And_Then
(Eloc
,
12358 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
12359 Right_Opnd
=> Expr
),
12360 Then_Statements
=> New_List
(
12361 Make_Null_Statement
(Eloc
))));
12363 -- Now go ahead and analyze the if statement
12365 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12367 -- One rather special treatment. If we are now in Eliminated
12368 -- overflow mode, then suppress overflow checking since we do
12369 -- not want to drag in the bignum stuff if we are in Ignore
12370 -- mode anyway. This is particularly important if we are using
12371 -- a configurable run time that does not support bignum ops.
12373 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
12375 Svo
: constant Boolean :=
12376 Scope_Suppress
.Suppress
(Overflow_Check
);
12378 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
12379 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
12381 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
12382 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
12385 -- Not that special case
12391 -- All done with this check
12393 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12395 -- Check is active or expansion not active. In these cases we can
12396 -- just go ahead and analyze the boolean with no worries.
12399 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12400 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12401 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12404 Ghost_Mode
:= Save_Ghost_Mode
;
12407 --------------------------
12408 -- Check_Float_Overflow --
12409 --------------------------
12411 -- pragma Check_Float_Overflow;
12413 when Pragma_Check_Float_Overflow
=>
12415 Check_Valid_Configuration_Pragma
;
12416 Check_Arg_Count
(0);
12417 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
12423 -- pragma Check_Name (check_IDENTIFIER);
12425 when Pragma_Check_Name
=>
12427 Check_No_Identifiers
;
12428 Check_Valid_Configuration_Pragma
;
12429 Check_Arg_Count
(1);
12430 Check_Arg_Is_Identifier
(Arg1
);
12433 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12436 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12437 if Check_Names
.Table
(J
) = Nam
then
12442 Check_Names
.Append
(Nam
);
12449 -- This is the old style syntax, which is still allowed in all modes:
12451 -- pragma Check_Policy ([Name =>] CHECK_KIND
12452 -- [Policy =>] POLICY_IDENTIFIER);
12454 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12456 -- CHECK_KIND ::= IDENTIFIER |
12459 -- Type_Invariant'Class |
12462 -- This is the new style syntax, compatible with Assertion_Policy
12463 -- and also allowed in all modes.
12465 -- Pragma Check_Policy (
12466 -- CHECK_KIND => POLICY_IDENTIFIER
12467 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12469 -- Note: the identifiers Name and Policy are not allowed as
12470 -- Check_Kind values. This avoids ambiguities between the old and
12471 -- new form syntax.
12473 when Pragma_Check_Policy
=> Check_Policy
: declare
12478 Check_At_Least_N_Arguments
(1);
12480 -- A Check_Policy pragma can appear either as a configuration
12481 -- pragma, or in a declarative part or a package spec (see RM
12482 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12483 -- followed for Check_Policy).
12485 if not Is_Configuration_Pragma
then
12486 Check_Is_In_Decl_Part_Or_Package_Spec
;
12489 -- Figure out if we have the old or new syntax. We have the
12490 -- old syntax if the first argument has no identifier, or the
12491 -- identifier is Name.
12493 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12494 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12498 Check_Arg_Count
(2);
12499 Check_Optional_Identifier
(Arg1
, Name_Name
);
12500 Kind
:= Get_Pragma_Arg
(Arg1
);
12501 Rewrite_Assertion_Kind
(Kind
);
12502 Check_Arg_Is_Identifier
(Arg1
);
12504 -- Check forbidden check kind
12506 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12507 Error_Msg_Name_2
:= Chars
(Kind
);
12509 ("pragma% does not allow% as check name", Arg1
);
12514 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12515 Check_Arg_Is_One_Of
12517 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12519 -- And chain pragma on the Check_Policy_List for search
12521 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12522 Opt
.Check_Policy_List
:= N
;
12524 -- For the new syntax, what we do is to convert each argument to
12525 -- an old syntax equivalent. We do that because we want to chain
12526 -- old style Check_Policy pragmas for the search (we don't want
12527 -- to have to deal with multiple arguments in the search).
12538 while Present
(Arg
) loop
12539 LocP
:= Sloc
(Arg
);
12540 Argx
:= Get_Pragma_Arg
(Arg
);
12542 -- Kind must be specified
12544 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12545 or else Chars
(Arg
) = No_Name
12548 ("missing assertion kind for pragma%", Arg
);
12551 -- Construct equivalent old form syntax Check_Policy
12552 -- pragma and insert it to get remaining checks.
12556 Chars
=> Name_Check_Policy
,
12557 Pragma_Argument_Associations
=> New_List
(
12558 Make_Pragma_Argument_Association
(LocP
,
12560 Make_Identifier
(LocP
, Chars
(Arg
))),
12561 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12562 Expression
=> Argx
)));
12566 -- For a configuration pragma, insert old form in
12567 -- the corresponding file.
12569 if Is_Configuration_Pragma
then
12570 Insert_After
(N
, New_P
);
12574 Insert_Action
(N
, New_P
);
12578 -- Rewrite original Check_Policy pragma to null, since we
12579 -- have converted it into a series of old syntax pragmas.
12581 Rewrite
(N
, Make_Null_Statement
(Loc
));
12591 -- pragma Comment (static_string_EXPRESSION)
12593 -- Processing for pragma Comment shares the circuitry for pragma
12594 -- Ident. The only differences are that Ident enforces a limit of 31
12595 -- characters on its argument, and also enforces limitations on
12596 -- placement for DEC compatibility. Pragma Comment shares neither of
12597 -- these restrictions.
12599 -------------------
12600 -- Common_Object --
12601 -------------------
12603 -- pragma Common_Object (
12604 -- [Internal =>] LOCAL_NAME
12605 -- [, [External =>] EXTERNAL_SYMBOL]
12606 -- [, [Size =>] EXTERNAL_SYMBOL]);
12608 -- Processing for this pragma is shared with Psect_Object
12610 ------------------------
12611 -- Compile_Time_Error --
12612 ------------------------
12614 -- pragma Compile_Time_Error
12615 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12617 when Pragma_Compile_Time_Error
=>
12619 Process_Compile_Time_Warning_Or_Error
;
12621 --------------------------
12622 -- Compile_Time_Warning --
12623 --------------------------
12625 -- pragma Compile_Time_Warning
12626 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12628 when Pragma_Compile_Time_Warning
=>
12630 Process_Compile_Time_Warning_Or_Error
;
12632 ---------------------------
12633 -- Compiler_Unit_Warning --
12634 ---------------------------
12636 -- pragma Compiler_Unit_Warning;
12640 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12641 -- errors not warnings. This means that we had introduced a big extra
12642 -- inertia to compiler changes, since even if we implemented a new
12643 -- feature, and even if all versions to be used for bootstrapping
12644 -- implemented this new feature, we could not use it, since old
12645 -- compilers would give errors for using this feature in units
12646 -- having Compiler_Unit pragmas.
12648 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12649 -- problem. We no longer have any units mentioning Compiler_Unit,
12650 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12651 -- and thus generates a warning which can be ignored. So that deals
12652 -- with the problem of old compilers not implementing the newer form
12655 -- Newer compilers recognize the new pragma, but generate warning
12656 -- messages instead of errors, which again can be ignored in the
12657 -- case of an old compiler which implements a wanted new feature
12658 -- but at the time felt like warning about it for older compilers.
12660 -- We retain Compiler_Unit so that new compilers can be used to build
12661 -- older run-times that use this pragma. That's an unusual case, but
12662 -- it's easy enough to handle, so why not?
12664 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12666 Check_Arg_Count
(0);
12668 -- Only recognized in main unit
12670 if Current_Sem_Unit
= Main_Unit
then
12671 Compiler_Unit
:= True;
12674 -----------------------------
12675 -- Complete_Representation --
12676 -----------------------------
12678 -- pragma Complete_Representation;
12680 when Pragma_Complete_Representation
=>
12682 Check_Arg_Count
(0);
12684 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12686 ("pragma & must appear within record representation clause");
12689 ----------------------------
12690 -- Complex_Representation --
12691 ----------------------------
12693 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12695 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12702 Check_Arg_Count
(1);
12703 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12704 Check_Arg_Is_Local_Name
(Arg1
);
12705 E_Id
:= Get_Pragma_Arg
(Arg1
);
12707 if Etype
(E_Id
) = Any_Type
then
12711 E
:= Entity
(E_Id
);
12713 if not Is_Record_Type
(E
) then
12715 ("argument for pragma% must be record type", Arg1
);
12718 Ent
:= First_Entity
(E
);
12721 or else No
(Next_Entity
(Ent
))
12722 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
12723 or else not Is_Floating_Point_Type
(Etype
(Ent
))
12724 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
12727 ("record for pragma% must have two fields of the same "
12728 & "floating-point type", Arg1
);
12731 Set_Has_Complex_Representation
(Base_Type
(E
));
12733 -- We need to treat the type has having a non-standard
12734 -- representation, for back-end purposes, even though in
12735 -- general a complex will have the default representation
12736 -- of a record with two real components.
12738 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
12740 end Complex_Representation
;
12742 -------------------------
12743 -- Component_Alignment --
12744 -------------------------
12746 -- pragma Component_Alignment (
12747 -- [Form =>] ALIGNMENT_CHOICE
12748 -- [, [Name =>] type_LOCAL_NAME]);
12750 -- ALIGNMENT_CHOICE ::=
12752 -- | Component_Size_4
12756 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
12757 Args
: Args_List
(1 .. 2);
12758 Names
: constant Name_List
(1 .. 2) := (
12762 Form
: Node_Id
renames Args
(1);
12763 Name
: Node_Id
renames Args
(2);
12765 Atype
: Component_Alignment_Kind
;
12770 Gather_Associations
(Names
, Args
);
12773 Error_Pragma
("missing Form argument for pragma%");
12776 Check_Arg_Is_Identifier
(Form
);
12778 -- Get proper alignment, note that Default = Component_Size on all
12779 -- machines we have so far, and we want to set this value rather
12780 -- than the default value to indicate that it has been explicitly
12781 -- set (and thus will not get overridden by the default component
12782 -- alignment for the current scope)
12784 if Chars
(Form
) = Name_Component_Size
then
12785 Atype
:= Calign_Component_Size
;
12787 elsif Chars
(Form
) = Name_Component_Size_4
then
12788 Atype
:= Calign_Component_Size_4
;
12790 elsif Chars
(Form
) = Name_Default
then
12791 Atype
:= Calign_Component_Size
;
12793 elsif Chars
(Form
) = Name_Storage_Unit
then
12794 Atype
:= Calign_Storage_Unit
;
12798 ("invalid Form parameter for pragma%", Form
);
12801 -- Case with no name, supplied, affects scope table entry
12805 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
12807 -- Case of name supplied
12810 Check_Arg_Is_Local_Name
(Name
);
12812 Typ
:= Entity
(Name
);
12815 or else Rep_Item_Too_Early
(Typ
, N
)
12819 Typ
:= Underlying_Type
(Typ
);
12822 if not Is_Record_Type
(Typ
)
12823 and then not Is_Array_Type
(Typ
)
12826 ("Name parameter of pragma% must identify record or "
12827 & "array type", Name
);
12830 -- An explicit Component_Alignment pragma overrides an
12831 -- implicit pragma Pack, but not an explicit one.
12833 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
12834 Set_Is_Packed
(Base_Type
(Typ
), False);
12835 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
12838 end Component_AlignmentP
;
12840 --------------------------------
12841 -- Constant_After_Elaboration --
12842 --------------------------------
12844 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
12846 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
12848 Obj_Decl
: Node_Id
;
12849 Obj_Id
: Entity_Id
;
12853 Check_No_Identifiers
;
12854 Check_At_Most_N_Arguments
(1);
12856 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12858 -- Object declaration
12860 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12863 -- Otherwise the pragma is associated with an illegal construct
12870 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12872 -- The object declaration must be a library-level variable which
12873 -- is either explicitly initialized or obtains a value during the
12874 -- elaboration of a package body (SPARK RM 3.3.1).
12876 if Ekind
(Obj_Id
) = E_Variable
then
12877 if not Is_Library_Level_Entity
(Obj_Id
) then
12879 ("pragma % must apply to a library level variable");
12883 -- Otherwise the pragma applies to a constant, which is illegal
12886 Error_Pragma
("pragma % must apply to a variable declaration");
12890 -- Chain the pragma on the contract for completeness
12892 Add_Contract_Item
(N
, Obj_Id
);
12894 -- A pragma that applies to a Ghost entity becomes Ghost for the
12895 -- purposes of legality checks and removal of ignored Ghost code.
12897 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
12899 -- Analyze the Boolean expression (if any)
12901 if Present
(Arg1
) then
12902 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12904 end Constant_After_Elaboration
;
12906 --------------------
12907 -- Contract_Cases --
12908 --------------------
12910 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
12912 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
12914 -- CASE_GUARD ::= boolean_EXPRESSION | others
12916 -- CONSEQUENCE ::= boolean_EXPRESSION
12918 -- Characteristics:
12920 -- * Analysis - The annotation undergoes initial checks to verify
12921 -- the legal placement and context. Secondary checks preanalyze the
12924 -- Analyze_Contract_Cases_In_Decl_Part
12926 -- * Expansion - The annotation is expanded during the expansion of
12927 -- the related subprogram [body] contract as performed in:
12929 -- Expand_Subprogram_Contract
12931 -- * Template - The annotation utilizes the generic template of the
12932 -- related subprogram [body] when it is:
12934 -- aspect on subprogram declaration
12935 -- aspect on stand alone subprogram body
12936 -- pragma on stand alone subprogram body
12938 -- The annotation must prepare its own template when it is:
12940 -- pragma on subprogram declaration
12942 -- * Globals - Capture of global references must occur after full
12945 -- * Instance - The annotation is instantiated automatically when
12946 -- the related generic subprogram [body] is instantiated except for
12947 -- the "pragma on subprogram declaration" case. In that scenario
12948 -- the annotation must instantiate itself.
12950 when Pragma_Contract_Cases
=> Contract_Cases
: declare
12951 Spec_Id
: Entity_Id
;
12952 Subp_Decl
: Node_Id
;
12956 Check_No_Identifiers
;
12957 Check_Arg_Count
(1);
12959 -- Ensure the proper placement of the pragma. Contract_Cases must
12960 -- be associated with a subprogram declaration or a body that acts
12964 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
12968 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
12971 -- Generic subprogram
12973 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
12976 -- Body acts as spec
12978 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
12979 and then No
(Corresponding_Spec
(Subp_Decl
))
12983 -- Body stub acts as spec
12985 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
12986 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
12992 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13000 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13002 -- Chain the pragma on the contract for further processing by
13003 -- Analyze_Contract_Cases_In_Decl_Part.
13005 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13007 -- A pragma that applies to a Ghost entity becomes Ghost for the
13008 -- purposes of legality checks and removal of ignored Ghost code.
13010 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
13011 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13013 -- Fully analyze the pragma when it appears inside an entry
13014 -- or subprogram body because it cannot benefit from forward
13017 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13019 N_Subprogram_Body_Stub
)
13021 -- The legality checks of pragma Contract_Cases are affected by
13022 -- the SPARK mode in effect and the volatility of the context.
13023 -- Analyze all pragmas in a specific order.
13025 Analyze_If_Present
(Pragma_SPARK_Mode
);
13026 Analyze_If_Present
(Pragma_Volatile_Function
);
13027 Analyze_Contract_Cases_In_Decl_Part
(N
);
13029 end Contract_Cases
;
13035 -- pragma Controlled (first_subtype_LOCAL_NAME);
13037 when Pragma_Controlled
=> Controlled
: declare
13041 Check_No_Identifiers
;
13042 Check_Arg_Count
(1);
13043 Check_Arg_Is_Local_Name
(Arg1
);
13044 Arg
:= Get_Pragma_Arg
(Arg1
);
13046 if not Is_Entity_Name
(Arg
)
13047 or else not Is_Access_Type
(Entity
(Arg
))
13049 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
13051 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
13059 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13060 -- [Entity =>] LOCAL_NAME);
13062 when Pragma_Convention
=> Convention
: declare
13065 pragma Warnings
(Off
, C
);
13066 pragma Warnings
(Off
, E
);
13068 Check_Arg_Order
((Name_Convention
, Name_Entity
));
13069 Check_Ada_83_Warning
;
13070 Check_Arg_Count
(2);
13071 Process_Convention
(C
, E
);
13073 -- A pragma that applies to a Ghost entity becomes Ghost for the
13074 -- purposes of legality checks and removal of ignored Ghost code.
13076 Mark_Pragma_As_Ghost
(N
, E
);
13079 ---------------------------
13080 -- Convention_Identifier --
13081 ---------------------------
13083 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13084 -- [Convention =>] convention_IDENTIFIER);
13086 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
13092 Check_Arg_Order
((Name_Name
, Name_Convention
));
13093 Check_Arg_Count
(2);
13094 Check_Optional_Identifier
(Arg1
, Name_Name
);
13095 Check_Optional_Identifier
(Arg2
, Name_Convention
);
13096 Check_Arg_Is_Identifier
(Arg1
);
13097 Check_Arg_Is_Identifier
(Arg2
);
13098 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
13099 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
13101 if Is_Convention_Name
(Cname
) then
13102 Record_Convention_Identifier
13103 (Idnam
, Get_Convention_Id
(Cname
));
13106 ("second arg for % pragma must be convention", Arg2
);
13108 end Convention_Identifier
;
13114 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13116 when Pragma_CPP_Class
=> CPP_Class
: declare
13120 if Warn_On_Obsolescent_Feature
then
13122 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13123 & "effect; replace it by pragma import?j?", N
);
13126 Check_Arg_Count
(1);
13130 Chars
=> Name_Import
,
13131 Pragma_Argument_Associations
=> New_List
(
13132 Make_Pragma_Argument_Association
(Loc
,
13133 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
13134 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
13138 ---------------------
13139 -- CPP_Constructor --
13140 ---------------------
13142 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13143 -- [, [External_Name =>] static_string_EXPRESSION ]
13144 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13146 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
13149 Def_Id
: Entity_Id
;
13150 Tag_Typ
: Entity_Id
;
13154 Check_At_Least_N_Arguments
(1);
13155 Check_At_Most_N_Arguments
(3);
13156 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13157 Check_Arg_Is_Local_Name
(Arg1
);
13159 Id
:= Get_Pragma_Arg
(Arg1
);
13160 Find_Program_Unit_Name
(Id
);
13162 -- If we did not find the name, we are done
13164 if Etype
(Id
) = Any_Type
then
13168 Def_Id
:= Entity
(Id
);
13170 -- Check if already defined as constructor
13172 if Is_Constructor
(Def_Id
) then
13174 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
13178 if Ekind
(Def_Id
) = E_Function
13179 and then (Is_CPP_Class
(Etype
(Def_Id
))
13180 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
13182 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
13184 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
13186 ("'C'P'P constructor must be defined in the scope of "
13187 & "its returned type", Arg1
);
13190 if Arg_Count
>= 2 then
13191 Set_Imported
(Def_Id
);
13192 Set_Is_Public
(Def_Id
);
13193 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
13196 Set_Has_Completion
(Def_Id
);
13197 Set_Is_Constructor
(Def_Id
);
13198 Set_Convention
(Def_Id
, Convention_CPP
);
13200 -- Imported C++ constructors are not dispatching primitives
13201 -- because in C++ they don't have a dispatch table slot.
13202 -- However, in Ada the constructor has the profile of a
13203 -- function that returns a tagged type and therefore it has
13204 -- been treated as a primitive operation during semantic
13205 -- analysis. We now remove it from the list of primitive
13206 -- operations of the type.
13208 if Is_Tagged_Type
(Etype
(Def_Id
))
13209 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
13210 and then Is_Dispatching_Operation
(Def_Id
)
13212 Tag_Typ
:= Etype
(Def_Id
);
13214 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
13215 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
13219 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
13220 Set_Is_Dispatching_Operation
(Def_Id
, False);
13223 -- For backward compatibility, if the constructor returns a
13224 -- class wide type, and we internally change the return type to
13225 -- the corresponding root type.
13227 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
13228 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
13232 ("pragma% requires function returning a 'C'P'P_Class type",
13235 end CPP_Constructor
;
13241 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
13245 if Warn_On_Obsolescent_Feature
then
13247 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13256 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
13260 if Warn_On_Obsolescent_Feature
then
13262 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13271 -- pragma CPU (EXPRESSION);
13273 when Pragma_CPU
=> CPU
: declare
13274 P
: constant Node_Id
:= Parent
(N
);
13280 Check_No_Identifiers
;
13281 Check_Arg_Count
(1);
13285 if Nkind
(P
) = N_Subprogram_Body
then
13286 Check_In_Main_Program
;
13288 Arg
:= Get_Pragma_Arg
(Arg1
);
13289 Analyze_And_Resolve
(Arg
, Any_Integer
);
13291 Ent
:= Defining_Unit_Name
(Specification
(P
));
13293 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
13294 Ent
:= Defining_Identifier
(Ent
);
13299 if not Is_OK_Static_Expression
(Arg
) then
13300 Flag_Non_Static_Expr
13301 ("main subprogram affinity is not static!", Arg
);
13304 -- If constraint error, then we already signalled an error
13306 elsif Raises_Constraint_Error
(Arg
) then
13309 -- Otherwise check in range
13313 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
13314 -- This is the entity System.Multiprocessors.CPU_Range;
13316 Val
: constant Uint
:= Expr_Value
(Arg
);
13319 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
13321 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
13324 ("main subprogram CPU is out of range", Arg1
);
13330 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
13334 elsif Nkind
(P
) = N_Task_Definition
then
13335 Arg
:= Get_Pragma_Arg
(Arg1
);
13336 Ent
:= Defining_Identifier
(Parent
(P
));
13338 -- The expression must be analyzed in the special manner
13339 -- described in "Handling of Default and Per-Object
13340 -- Expressions" in sem.ads.
13342 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
13344 -- Anything else is incorrect
13350 -- Check duplicate pragma before we chain the pragma in the Rep
13351 -- Item chain of Ent.
13353 Check_Duplicate_Pragma
(Ent
);
13354 Record_Rep_Item
(Ent
, N
);
13361 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13363 when Pragma_Debug
=> Debug
: declare
13370 -- The condition for executing the call is that the expander
13371 -- is active and that we are not ignoring this debug pragma.
13376 (Expander_Active
and then not Is_Ignored
(N
)),
13379 if not Is_Ignored
(N
) then
13380 Set_SCO_Pragma_Enabled
(Loc
);
13383 if Arg_Count
= 2 then
13385 Make_And_Then
(Loc
,
13386 Left_Opnd
=> Relocate_Node
(Cond
),
13387 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
13388 Call
:= Get_Pragma_Arg
(Arg2
);
13390 Call
:= Get_Pragma_Arg
(Arg1
);
13394 N_Indexed_Component
,
13398 N_Selected_Component
)
13400 -- If this pragma Debug comes from source, its argument was
13401 -- parsed as a name form (which is syntactically identical).
13402 -- In a generic context a parameterless call will be left as
13403 -- an expanded name (if global) or selected_component if local.
13404 -- Change it to a procedure call statement now.
13406 Change_Name_To_Procedure_Call_Statement
(Call
);
13408 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
13410 -- Already in the form of a procedure call statement: nothing
13411 -- to do (could happen in case of an internally generated
13417 -- All other cases: diagnose error
13420 ("argument of pragma ""Debug"" is not procedure call",
13425 -- Rewrite into a conditional with an appropriate condition. We
13426 -- wrap the procedure call in a block so that overhead from e.g.
13427 -- use of the secondary stack does not generate execution overhead
13428 -- for suppressed conditions.
13430 -- Normally the analysis that follows will freeze the subprogram
13431 -- being called. However, if the call is to a null procedure,
13432 -- we want to freeze it before creating the block, because the
13433 -- analysis that follows may be done with expansion disabled, in
13434 -- which case the body will not be generated, leading to spurious
13437 if Nkind
(Call
) = N_Procedure_Call_Statement
13438 and then Is_Entity_Name
(Name
(Call
))
13440 Analyze
(Name
(Call
));
13441 Freeze_Before
(N
, Entity
(Name
(Call
)));
13445 Make_Implicit_If_Statement
(N
,
13447 Then_Statements
=> New_List
(
13448 Make_Block_Statement
(Loc
,
13449 Handled_Statement_Sequence
=>
13450 Make_Handled_Sequence_Of_Statements
(Loc
,
13451 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13454 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13455 -- after analysis of the normally rewritten node, to capture all
13456 -- references to entities, which avoids issuing wrong warnings
13457 -- about unused entities.
13459 if GNATprove_Mode
then
13460 Rewrite
(N
, Make_Null_Statement
(Loc
));
13468 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13470 when Pragma_Debug_Policy
=>
13472 Check_Arg_Count
(1);
13473 Check_No_Identifiers
;
13474 Check_Arg_Is_Identifier
(Arg1
);
13476 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13477 -- rewrite it that way, and let the rest of the checking come
13478 -- from analyzing the rewritten pragma.
13482 Chars
=> Name_Check_Policy
,
13483 Pragma_Argument_Associations
=> New_List
(
13484 Make_Pragma_Argument_Association
(Loc
,
13485 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13487 Make_Pragma_Argument_Association
(Loc
,
13488 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13491 -------------------------------
13492 -- Default_Initial_Condition --
13493 -------------------------------
13495 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13497 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
13504 Check_No_Identifiers
;
13505 Check_At_Most_N_Arguments
(1);
13508 while Present
(Stmt
) loop
13510 -- Skip prior pragmas, but check for duplicates
13512 if Nkind
(Stmt
) = N_Pragma
then
13513 if Pragma_Name
(Stmt
) = Pname
then
13514 Error_Msg_Name_1
:= Pname
;
13515 Error_Msg_Sloc
:= Sloc
(Stmt
);
13516 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13519 -- Skip internally generated code
13521 elsif not Comes_From_Source
(Stmt
) then
13524 -- The associated private type [extension] has been found, stop
13527 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
13528 N_Private_Type_Declaration
)
13530 Typ
:= Defining_Entity
(Stmt
);
13533 -- The pragma does not apply to a legal construct, issue an
13534 -- error and stop the analysis.
13541 Stmt
:= Prev
(Stmt
);
13544 -- A pragma that applies to a Ghost entity becomes Ghost for the
13545 -- purposes of legality checks and removal of ignored Ghost code.
13547 Mark_Pragma_As_Ghost
(N
, Typ
);
13548 Set_Has_Default_Init_Cond
(Typ
);
13549 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
13551 -- Chain the pragma on the rep item chain for further processing
13553 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13554 end Default_Init_Cond
;
13556 ----------------------------------
13557 -- Default_Scalar_Storage_Order --
13558 ----------------------------------
13560 -- pragma Default_Scalar_Storage_Order
13561 -- (High_Order_First | Low_Order_First);
13563 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
13564 Default
: Character;
13568 Check_Arg_Count
(1);
13570 -- Default_Scalar_Storage_Order can appear as a configuration
13571 -- pragma, or in a declarative part of a package spec.
13573 if not Is_Configuration_Pragma
then
13574 Check_Is_In_Decl_Part_Or_Package_Spec
;
13577 Check_No_Identifiers
;
13578 Check_Arg_Is_One_Of
13579 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
13580 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13581 Default
:= Fold_Upper
(Name_Buffer
(1));
13583 if not Support_Nondefault_SSO_On_Target
13584 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
13586 if Warn_On_Unrecognized_Pragma
then
13588 ("non-default Scalar_Storage_Order not supported "
13589 & "on target?g?", N
);
13591 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
13594 -- Here set the specified default
13597 Opt
.Default_SSO
:= Default
;
13601 --------------------------
13602 -- Default_Storage_Pool --
13603 --------------------------
13605 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13607 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
13612 Check_Arg_Count
(1);
13614 -- Default_Storage_Pool can appear as a configuration pragma, or
13615 -- in a declarative part of a package spec.
13617 if not Is_Configuration_Pragma
then
13618 Check_Is_In_Decl_Part_Or_Package_Spec
;
13621 if From_Aspect_Specification
(N
) then
13623 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
13625 if not In_Open_Scopes
(E
) then
13627 ("aspect must apply to package or subprogram", N
);
13632 if Present
(Arg1
) then
13633 Pool
:= Get_Pragma_Arg
(Arg1
);
13635 -- Case of Default_Storage_Pool (null);
13637 if Nkind
(Pool
) = N_Null
then
13640 -- This is an odd case, this is not really an expression,
13641 -- so we don't have a type for it. So just set the type to
13644 Set_Etype
(Pool
, Empty
);
13646 -- Case of Default_Storage_Pool (storage_pool_NAME);
13649 -- If it's a configuration pragma, then the only allowed
13650 -- argument is "null".
13652 if Is_Configuration_Pragma
then
13653 Error_Pragma_Arg
("NULL expected", Arg1
);
13656 -- The expected type for a non-"null" argument is
13657 -- Root_Storage_Pool'Class, and the pool must be a variable.
13659 Analyze_And_Resolve
13660 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13662 if Is_Variable
(Pool
) then
13664 -- A pragma that applies to a Ghost entity becomes Ghost
13665 -- for the purposes of legality checks and removal of
13666 -- ignored Ghost code.
13668 Mark_Pragma_As_Ghost
(N
, Entity
(Pool
));
13672 ("default storage pool must be a variable", Arg1
);
13676 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13677 -- access type will use this information to set the appropriate
13678 -- attributes of the access type.
13680 Default_Pool
:= Pool
;
13682 end Default_Storage_Pool
;
13688 -- pragma Depends (DEPENDENCY_RELATION);
13690 -- DEPENDENCY_RELATION ::=
13692 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
13694 -- DEPENDENCY_CLAUSE ::=
13695 -- OUTPUT_LIST =>[+] INPUT_LIST
13696 -- | NULL_DEPENDENCY_CLAUSE
13698 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13700 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13702 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13704 -- OUTPUT ::= NAME | FUNCTION_RESULT
13707 -- where FUNCTION_RESULT is a function Result attribute_reference
13709 -- Characteristics:
13711 -- * Analysis - The annotation undergoes initial checks to verify
13712 -- the legal placement and context. Secondary checks fully analyze
13713 -- the dependency clauses in:
13715 -- Analyze_Depends_In_Decl_Part
13717 -- * Expansion - None.
13719 -- * Template - The annotation utilizes the generic template of the
13720 -- related subprogram [body] when it is:
13722 -- aspect on subprogram declaration
13723 -- aspect on stand alone subprogram body
13724 -- pragma on stand alone subprogram body
13726 -- The annotation must prepare its own template when it is:
13728 -- pragma on subprogram declaration
13730 -- * Globals - Capture of global references must occur after full
13733 -- * Instance - The annotation is instantiated automatically when
13734 -- the related generic subprogram [body] is instantiated except for
13735 -- the "pragma on subprogram declaration" case. In that scenario
13736 -- the annotation must instantiate itself.
13738 when Pragma_Depends
=> Depends
: declare
13740 Spec_Id
: Entity_Id
;
13741 Subp_Decl
: Node_Id
;
13744 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
13748 -- Chain the pragma on the contract for further processing by
13749 -- Analyze_Depends_In_Decl_Part.
13751 Add_Contract_Item
(N
, Spec_Id
);
13753 -- Fully analyze the pragma when it appears inside an entry
13754 -- or subprogram body because it cannot benefit from forward
13757 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13759 N_Subprogram_Body_Stub
)
13761 -- The legality checks of pragmas Depends and Global are
13762 -- affected by the SPARK mode in effect and the volatility
13763 -- of the context. In addition these two pragmas are subject
13764 -- to an inherent order:
13769 -- Analyze all these pragmas in the order outlined above
13771 Analyze_If_Present
(Pragma_SPARK_Mode
);
13772 Analyze_If_Present
(Pragma_Volatile_Function
);
13773 Analyze_If_Present
(Pragma_Global
);
13774 Analyze_Depends_In_Decl_Part
(N
);
13779 ---------------------
13780 -- Detect_Blocking --
13781 ---------------------
13783 -- pragma Detect_Blocking;
13785 when Pragma_Detect_Blocking
=>
13787 Check_Arg_Count
(0);
13788 Check_Valid_Configuration_Pragma
;
13789 Detect_Blocking
:= True;
13791 ------------------------------------
13792 -- Disable_Atomic_Synchronization --
13793 ------------------------------------
13795 -- pragma Disable_Atomic_Synchronization [(Entity)];
13797 when Pragma_Disable_Atomic_Synchronization
=>
13799 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
13801 -------------------
13802 -- Discard_Names --
13803 -------------------
13805 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
13807 when Pragma_Discard_Names
=> Discard_Names
: declare
13812 Check_Ada_83_Warning
;
13814 -- Deal with configuration pragma case
13816 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
13817 Global_Discard_Names
:= True;
13820 -- Otherwise, check correct appropriate context
13823 Check_Is_In_Decl_Part_Or_Package_Spec
;
13825 if Arg_Count
= 0 then
13827 -- If there is no parameter, then from now on this pragma
13828 -- applies to any enumeration, exception or tagged type
13829 -- defined in the current declarative part, and recursively
13830 -- to any nested scope.
13832 Set_Discard_Names
(Current_Scope
);
13836 Check_Arg_Count
(1);
13837 Check_Optional_Identifier
(Arg1
, Name_On
);
13838 Check_Arg_Is_Local_Name
(Arg1
);
13840 E_Id
:= Get_Pragma_Arg
(Arg1
);
13842 if Etype
(E_Id
) = Any_Type
then
13845 E
:= Entity
(E_Id
);
13848 -- A pragma that applies to a Ghost entity becomes Ghost for
13849 -- the purposes of legality checks and removal of ignored
13852 Mark_Pragma_As_Ghost
(N
, E
);
13854 if (Is_First_Subtype
(E
)
13856 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
13857 or else Ekind
(E
) = E_Exception
13859 Set_Discard_Names
(E
);
13860 Record_Rep_Item
(E
, N
);
13864 ("inappropriate entity for pragma%", Arg1
);
13870 ------------------------
13871 -- Dispatching_Domain --
13872 ------------------------
13874 -- pragma Dispatching_Domain (EXPRESSION);
13876 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
13877 P
: constant Node_Id
:= Parent
(N
);
13883 Check_No_Identifiers
;
13884 Check_Arg_Count
(1);
13886 -- This pragma is born obsolete, but not the aspect
13888 if not From_Aspect_Specification
(N
) then
13890 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
13893 if Nkind
(P
) = N_Task_Definition
then
13894 Arg
:= Get_Pragma_Arg
(Arg1
);
13895 Ent
:= Defining_Identifier
(Parent
(P
));
13897 -- A pragma that applies to a Ghost entity becomes Ghost for
13898 -- the purposes of legality checks and removal of ignored Ghost
13901 Mark_Pragma_As_Ghost
(N
, Ent
);
13903 -- The expression must be analyzed in the special manner
13904 -- described in "Handling of Default and Per-Object
13905 -- Expressions" in sem.ads.
13907 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
13909 -- Check duplicate pragma before we chain the pragma in the Rep
13910 -- Item chain of Ent.
13912 Check_Duplicate_Pragma
(Ent
);
13913 Record_Rep_Item
(Ent
, N
);
13915 -- Anything else is incorrect
13920 end Dispatching_Domain
;
13926 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
13928 when Pragma_Elaborate
=> Elaborate
: declare
13933 -- Pragma must be in context items list of a compilation unit
13935 if not Is_In_Context_Clause
then
13939 -- Must be at least one argument
13941 if Arg_Count
= 0 then
13942 Error_Pragma
("pragma% requires at least one argument");
13945 -- In Ada 83 mode, there can be no items following it in the
13946 -- context list except other pragmas and implicit with clauses
13947 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
13948 -- placement rule does not apply.
13950 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
13952 while Present
(Citem
) loop
13953 if Nkind
(Citem
) = N_Pragma
13954 or else (Nkind
(Citem
) = N_With_Clause
13955 and then Implicit_With
(Citem
))
13960 ("(Ada 83) pragma% must be at end of context clause");
13967 -- Finally, the arguments must all be units mentioned in a with
13968 -- clause in the same context clause. Note we already checked (in
13969 -- Par.Prag) that the arguments are all identifiers or selected
13973 Outer
: while Present
(Arg
) loop
13974 Citem
:= First
(List_Containing
(N
));
13975 Inner
: while Citem
/= N
loop
13976 if Nkind
(Citem
) = N_With_Clause
13977 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
13979 Set_Elaborate_Present
(Citem
, True);
13980 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
13982 -- With the pragma present, elaboration calls on
13983 -- subprograms from the named unit need no further
13984 -- checks, as long as the pragma appears in the current
13985 -- compilation unit. If the pragma appears in some unit
13986 -- in the context, there might still be a need for an
13987 -- Elaborate_All_Desirable from the current compilation
13988 -- to the named unit, so we keep the check enabled.
13990 if In_Extended_Main_Source_Unit
(N
) then
13992 -- This does not apply in SPARK mode, where we allow
13993 -- pragma Elaborate, but we don't trust it to be right
13994 -- so we will still insist on the Elaborate_All.
13996 if SPARK_Mode
/= On
then
13997 Set_Suppress_Elaboration_Warnings
13998 (Entity
(Name
(Citem
)));
14010 ("argument of pragma% is not withed unit", Arg
);
14016 -- Give a warning if operating in static mode with one of the
14017 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14020 and not Dynamic_Elaboration_Checks
14022 -- pragma Elaborate not allowed in SPARK mode anyway. We
14023 -- already complained about it, no point in generating any
14024 -- further complaint.
14026 and SPARK_Mode
/= On
14029 ("?l?use of pragma Elaborate may not be safe", N
);
14031 ("?l?use pragma Elaborate_All instead if possible", N
);
14035 -------------------
14036 -- Elaborate_All --
14037 -------------------
14039 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14041 when Pragma_Elaborate_All
=> Elaborate_All
: declare
14046 Check_Ada_83_Warning
;
14048 -- Pragma must be in context items list of a compilation unit
14050 if not Is_In_Context_Clause
then
14054 -- Must be at least one argument
14056 if Arg_Count
= 0 then
14057 Error_Pragma
("pragma% requires at least one argument");
14060 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14061 -- have to appear at the end of the context clause, but may
14062 -- appear mixed in with other items, even in Ada 83 mode.
14064 -- Final check: the arguments must all be units mentioned in
14065 -- a with clause in the same context clause. Note that we
14066 -- already checked (in Par.Prag) that all the arguments are
14067 -- either identifiers or selected components.
14070 Outr
: while Present
(Arg
) loop
14071 Citem
:= First
(List_Containing
(N
));
14072 Innr
: while Citem
/= N
loop
14073 if Nkind
(Citem
) = N_With_Clause
14074 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14076 Set_Elaborate_All_Present
(Citem
, True);
14077 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14079 -- Suppress warnings and elaboration checks on the named
14080 -- unit if the pragma is in the current compilation, as
14081 -- for pragma Elaborate.
14083 if In_Extended_Main_Source_Unit
(N
) then
14084 Set_Suppress_Elaboration_Warnings
14085 (Entity
(Name
(Citem
)));
14094 Set_Error_Posted
(N
);
14096 ("argument of pragma% is not withed unit", Arg
);
14103 --------------------
14104 -- Elaborate_Body --
14105 --------------------
14107 -- pragma Elaborate_Body [( library_unit_NAME )];
14109 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
14110 Cunit_Node
: Node_Id
;
14111 Cunit_Ent
: Entity_Id
;
14114 Check_Ada_83_Warning
;
14115 Check_Valid_Library_Unit_Pragma
;
14117 if Nkind
(N
) = N_Null_Statement
then
14121 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
14122 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14124 -- A pragma that applies to a Ghost entity becomes Ghost for the
14125 -- purposes of legality checks and removal of ignored Ghost code.
14127 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
14129 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
14132 Error_Pragma
("pragma% must refer to a spec, not a body");
14134 Set_Body_Required
(Cunit_Node
, True);
14135 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
14137 -- If we are in dynamic elaboration mode, then we suppress
14138 -- elaboration warnings for the unit, since it is definitely
14139 -- fine NOT to do dynamic checks at the first level (and such
14140 -- checks will be suppressed because no elaboration boolean
14141 -- is created for Elaborate_Body packages).
14143 -- But in the static model of elaboration, Elaborate_Body is
14144 -- definitely NOT good enough to ensure elaboration safety on
14145 -- its own, since the body may WITH other units that are not
14146 -- safe from an elaboration point of view, so a client must
14147 -- still do an Elaborate_All on such units.
14149 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14150 -- Elaborate_Body always suppressed elab warnings.
14152 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
14153 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
14156 end Elaborate_Body
;
14158 ------------------------
14159 -- Elaboration_Checks --
14160 ------------------------
14162 -- pragma Elaboration_Checks (Static | Dynamic);
14164 when Pragma_Elaboration_Checks
=>
14166 Check_Arg_Count
(1);
14167 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
14169 -- Set flag accordingly (ignore attempt at dynamic elaboration
14170 -- checks in SPARK mode).
14172 Dynamic_Elaboration_Checks
:=
14173 (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
)
14174 and then SPARK_Mode
/= On
;
14180 -- pragma Eliminate (
14181 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14182 -- [,[Entity =>] IDENTIFIER |
14183 -- SELECTED_COMPONENT |
14185 -- [, OVERLOADING_RESOLUTION]);
14187 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14190 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14191 -- FUNCTION_PROFILE
14193 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14195 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14196 -- Result_Type => result_SUBTYPE_NAME]
14198 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14199 -- SUBTYPE_NAME ::= STRING_LITERAL
14201 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14202 -- SOURCE_TRACE ::= STRING_LITERAL
14204 when Pragma_Eliminate
=> Eliminate
: declare
14205 Args
: Args_List
(1 .. 5);
14206 Names
: constant Name_List
(1 .. 5) := (
14209 Name_Parameter_Types
,
14211 Name_Source_Location
);
14213 Unit_Name
: Node_Id
renames Args
(1);
14214 Entity
: Node_Id
renames Args
(2);
14215 Parameter_Types
: Node_Id
renames Args
(3);
14216 Result_Type
: Node_Id
renames Args
(4);
14217 Source_Location
: Node_Id
renames Args
(5);
14221 Check_Valid_Configuration_Pragma
;
14222 Gather_Associations
(Names
, Args
);
14224 if No
(Unit_Name
) then
14225 Error_Pragma
("missing Unit_Name argument for pragma%");
14229 and then (Present
(Parameter_Types
)
14231 Present
(Result_Type
)
14233 Present
(Source_Location
))
14235 Error_Pragma
("missing Entity argument for pragma%");
14238 if (Present
(Parameter_Types
)
14240 Present
(Result_Type
))
14242 Present
(Source_Location
)
14245 ("parameter profile and source location cannot be used "
14246 & "together in pragma%");
14249 Process_Eliminate_Pragma
14258 -----------------------------------
14259 -- Enable_Atomic_Synchronization --
14260 -----------------------------------
14262 -- pragma Enable_Atomic_Synchronization [(Entity)];
14264 when Pragma_Enable_Atomic_Synchronization
=>
14266 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
14273 -- [ Convention =>] convention_IDENTIFIER,
14274 -- [ Entity =>] LOCAL_NAME
14275 -- [, [External_Name =>] static_string_EXPRESSION ]
14276 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14278 when Pragma_Export
=> Export
: declare
14280 Def_Id
: Entity_Id
;
14282 pragma Warnings
(Off
, C
);
14285 Check_Ada_83_Warning
;
14289 Name_External_Name
,
14292 Check_At_Least_N_Arguments
(2);
14293 Check_At_Most_N_Arguments
(4);
14295 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14296 -- pragma Export (Entity, "external name");
14298 if Relaxed_RM_Semantics
14299 and then Arg_Count
= 2
14300 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
14303 Def_Id
:= Get_Pragma_Arg
(Arg1
);
14306 if not Is_Entity_Name
(Def_Id
) then
14307 Error_Pragma_Arg
("entity name required", Arg1
);
14310 Def_Id
:= Entity
(Def_Id
);
14311 Set_Exported
(Def_Id
, Arg1
);
14314 Process_Convention
(C
, Def_Id
);
14316 -- A pragma that applies to a Ghost entity becomes Ghost for
14317 -- the purposes of legality checks and removal of ignored Ghost
14320 Mark_Pragma_As_Ghost
(N
, Def_Id
);
14322 if Ekind
(Def_Id
) /= E_Constant
then
14323 Note_Possible_Modification
14324 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14327 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14328 Set_Exported
(Def_Id
, Arg2
);
14331 -- If the entity is a deferred constant, propagate the information
14332 -- to the full view, because gigi elaborates the full view only.
14334 if Ekind
(Def_Id
) = E_Constant
14335 and then Present
(Full_View
(Def_Id
))
14338 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
14340 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
14341 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
14342 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
14347 ---------------------
14348 -- Export_Function --
14349 ---------------------
14351 -- pragma Export_Function (
14352 -- [Internal =>] LOCAL_NAME
14353 -- [, [External =>] EXTERNAL_SYMBOL]
14354 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14355 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14356 -- [, [Mechanism =>] MECHANISM]
14357 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14359 -- EXTERNAL_SYMBOL ::=
14361 -- | static_string_EXPRESSION
14363 -- PARAMETER_TYPES ::=
14365 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14367 -- TYPE_DESIGNATOR ::=
14369 -- | subtype_Name ' Access
14373 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14375 -- MECHANISM_ASSOCIATION ::=
14376 -- [formal_parameter_NAME =>] MECHANISM_NAME
14378 -- MECHANISM_NAME ::=
14382 when Pragma_Export_Function
=> Export_Function
: declare
14383 Args
: Args_List
(1 .. 6);
14384 Names
: constant Name_List
(1 .. 6) := (
14387 Name_Parameter_Types
,
14390 Name_Result_Mechanism
);
14392 Internal
: Node_Id
renames Args
(1);
14393 External
: Node_Id
renames Args
(2);
14394 Parameter_Types
: Node_Id
renames Args
(3);
14395 Result_Type
: Node_Id
renames Args
(4);
14396 Mechanism
: Node_Id
renames Args
(5);
14397 Result_Mechanism
: Node_Id
renames Args
(6);
14401 Gather_Associations
(Names
, Args
);
14402 Process_Extended_Import_Export_Subprogram_Pragma
(
14403 Arg_Internal
=> Internal
,
14404 Arg_External
=> External
,
14405 Arg_Parameter_Types
=> Parameter_Types
,
14406 Arg_Result_Type
=> Result_Type
,
14407 Arg_Mechanism
=> Mechanism
,
14408 Arg_Result_Mechanism
=> Result_Mechanism
);
14409 end Export_Function
;
14411 -------------------
14412 -- Export_Object --
14413 -------------------
14415 -- pragma Export_Object (
14416 -- [Internal =>] LOCAL_NAME
14417 -- [, [External =>] EXTERNAL_SYMBOL]
14418 -- [, [Size =>] EXTERNAL_SYMBOL]);
14420 -- EXTERNAL_SYMBOL ::=
14422 -- | static_string_EXPRESSION
14424 -- PARAMETER_TYPES ::=
14426 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14428 -- TYPE_DESIGNATOR ::=
14430 -- | subtype_Name ' Access
14434 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14436 -- MECHANISM_ASSOCIATION ::=
14437 -- [formal_parameter_NAME =>] MECHANISM_NAME
14439 -- MECHANISM_NAME ::=
14443 when Pragma_Export_Object
=> Export_Object
: declare
14444 Args
: Args_List
(1 .. 3);
14445 Names
: constant Name_List
(1 .. 3) := (
14450 Internal
: Node_Id
renames Args
(1);
14451 External
: Node_Id
renames Args
(2);
14452 Size
: Node_Id
renames Args
(3);
14456 Gather_Associations
(Names
, Args
);
14457 Process_Extended_Import_Export_Object_Pragma
(
14458 Arg_Internal
=> Internal
,
14459 Arg_External
=> External
,
14463 ----------------------
14464 -- Export_Procedure --
14465 ----------------------
14467 -- pragma Export_Procedure (
14468 -- [Internal =>] LOCAL_NAME
14469 -- [, [External =>] EXTERNAL_SYMBOL]
14470 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14471 -- [, [Mechanism =>] MECHANISM]);
14473 -- EXTERNAL_SYMBOL ::=
14475 -- | static_string_EXPRESSION
14477 -- PARAMETER_TYPES ::=
14479 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14481 -- TYPE_DESIGNATOR ::=
14483 -- | subtype_Name ' Access
14487 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14489 -- MECHANISM_ASSOCIATION ::=
14490 -- [formal_parameter_NAME =>] MECHANISM_NAME
14492 -- MECHANISM_NAME ::=
14496 when Pragma_Export_Procedure
=> Export_Procedure
: declare
14497 Args
: Args_List
(1 .. 4);
14498 Names
: constant Name_List
(1 .. 4) := (
14501 Name_Parameter_Types
,
14504 Internal
: Node_Id
renames Args
(1);
14505 External
: Node_Id
renames Args
(2);
14506 Parameter_Types
: Node_Id
renames Args
(3);
14507 Mechanism
: Node_Id
renames Args
(4);
14511 Gather_Associations
(Names
, Args
);
14512 Process_Extended_Import_Export_Subprogram_Pragma
(
14513 Arg_Internal
=> Internal
,
14514 Arg_External
=> External
,
14515 Arg_Parameter_Types
=> Parameter_Types
,
14516 Arg_Mechanism
=> Mechanism
);
14517 end Export_Procedure
;
14523 -- pragma Export_Value (
14524 -- [Value =>] static_integer_EXPRESSION,
14525 -- [Link_Name =>] static_string_EXPRESSION);
14527 when Pragma_Export_Value
=>
14529 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
14530 Check_Arg_Count
(2);
14532 Check_Optional_Identifier
(Arg1
, Name_Value
);
14533 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
14535 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
14536 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
14538 -----------------------------
14539 -- Export_Valued_Procedure --
14540 -----------------------------
14542 -- pragma Export_Valued_Procedure (
14543 -- [Internal =>] LOCAL_NAME
14544 -- [, [External =>] EXTERNAL_SYMBOL,]
14545 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14546 -- [, [Mechanism =>] MECHANISM]);
14548 -- EXTERNAL_SYMBOL ::=
14550 -- | static_string_EXPRESSION
14552 -- PARAMETER_TYPES ::=
14554 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14556 -- TYPE_DESIGNATOR ::=
14558 -- | subtype_Name ' Access
14562 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14564 -- MECHANISM_ASSOCIATION ::=
14565 -- [formal_parameter_NAME =>] MECHANISM_NAME
14567 -- MECHANISM_NAME ::=
14571 when Pragma_Export_Valued_Procedure
=>
14572 Export_Valued_Procedure
: declare
14573 Args
: Args_List
(1 .. 4);
14574 Names
: constant Name_List
(1 .. 4) := (
14577 Name_Parameter_Types
,
14580 Internal
: Node_Id
renames Args
(1);
14581 External
: Node_Id
renames Args
(2);
14582 Parameter_Types
: Node_Id
renames Args
(3);
14583 Mechanism
: Node_Id
renames Args
(4);
14587 Gather_Associations
(Names
, Args
);
14588 Process_Extended_Import_Export_Subprogram_Pragma
(
14589 Arg_Internal
=> Internal
,
14590 Arg_External
=> External
,
14591 Arg_Parameter_Types
=> Parameter_Types
,
14592 Arg_Mechanism
=> Mechanism
);
14593 end Export_Valued_Procedure
;
14595 -------------------
14596 -- Extend_System --
14597 -------------------
14599 -- pragma Extend_System ([Name =>] Identifier);
14601 when Pragma_Extend_System
=> Extend_System
: declare
14604 Check_Valid_Configuration_Pragma
;
14605 Check_Arg_Count
(1);
14606 Check_Optional_Identifier
(Arg1
, Name_Name
);
14607 Check_Arg_Is_Identifier
(Arg1
);
14609 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14612 and then Name_Buffer
(1 .. 4) = "aux_"
14614 if Present
(System_Extend_Pragma_Arg
) then
14615 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14616 Chars
(Expression
(System_Extend_Pragma_Arg
))
14620 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14621 Error_Pragma
("pragma% conflicts with that #");
14625 System_Extend_Pragma_Arg
:= Arg1
;
14627 if not GNAT_Mode
then
14628 System_Extend_Unit
:= Arg1
;
14632 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14636 ------------------------
14637 -- Extensions_Allowed --
14638 ------------------------
14640 -- pragma Extensions_Allowed (ON | OFF);
14642 when Pragma_Extensions_Allowed
=>
14644 Check_Arg_Count
(1);
14645 Check_No_Identifiers
;
14646 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14648 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14649 Extensions_Allowed
:= True;
14650 Ada_Version
:= Ada_Version_Type
'Last;
14653 Extensions_Allowed
:= False;
14654 Ada_Version
:= Ada_Version_Explicit
;
14655 Ada_Version_Pragma
:= Empty
;
14658 ------------------------
14659 -- Extensions_Visible --
14660 ------------------------
14662 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14664 -- Characteristics:
14666 -- * Analysis - The annotation is fully analyzed immediately upon
14667 -- elaboration as its expression must be static.
14669 -- * Expansion - None.
14671 -- * Template - The annotation utilizes the generic template of the
14672 -- related subprogram [body] when it is:
14674 -- aspect on subprogram declaration
14675 -- aspect on stand alone subprogram body
14676 -- pragma on stand alone subprogram body
14678 -- The annotation must prepare its own template when it is:
14680 -- pragma on subprogram declaration
14682 -- * Globals - Capture of global references must occur after full
14685 -- * Instance - The annotation is instantiated automatically when
14686 -- the related generic subprogram [body] is instantiated except for
14687 -- the "pragma on subprogram declaration" case. In that scenario
14688 -- the annotation must instantiate itself.
14690 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
14691 Formal
: Entity_Id
;
14692 Has_OK_Formal
: Boolean := False;
14693 Spec_Id
: Entity_Id
;
14694 Subp_Decl
: Node_Id
;
14698 Check_No_Identifiers
;
14699 Check_At_Most_N_Arguments
(1);
14702 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14704 -- Abstract subprogram declaration
14706 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
14709 -- Generic subprogram declaration
14711 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
14714 -- Body acts as spec
14716 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
14717 and then No
(Corresponding_Spec
(Subp_Decl
))
14721 -- Body stub acts as spec
14723 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
14724 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
14728 -- Subprogram declaration
14730 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
14733 -- Otherwise the pragma is associated with an illegal construct
14736 Error_Pragma
("pragma % must apply to a subprogram");
14740 -- Chain the pragma on the contract for completeness
14742 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
14744 -- The legality checks of pragma Extension_Visible are affected
14745 -- by the SPARK mode in effect. Analyze all pragmas in specific
14748 Analyze_If_Present
(Pragma_SPARK_Mode
);
14750 -- Mark the pragma as Ghost if the related subprogram is also
14751 -- Ghost. This also ensures that any expansion performed further
14752 -- below will produce Ghost nodes.
14754 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
14755 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
14757 -- Examine the formals of the related subprogram
14759 Formal
:= First_Formal
(Spec_Id
);
14760 while Present
(Formal
) loop
14762 -- At least one of the formals is of a specific tagged type,
14763 -- the pragma is legal.
14765 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
14766 Has_OK_Formal
:= True;
14769 -- A generic subprogram with at least one formal of a private
14770 -- type ensures the legality of the pragma because the actual
14771 -- may be specifically tagged. Note that this is verified by
14772 -- the check above at instantiation time.
14774 elsif Is_Private_Type
(Etype
(Formal
))
14775 and then Is_Generic_Type
(Etype
(Formal
))
14777 Has_OK_Formal
:= True;
14781 Next_Formal
(Formal
);
14784 if not Has_OK_Formal
then
14785 Error_Msg_Name_1
:= Pname
;
14786 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
14788 ("\subprogram & lacks parameter of specific tagged or "
14789 & "generic private type", N
, Spec_Id
);
14794 -- Analyze the Boolean expression (if any)
14796 if Present
(Arg1
) then
14797 Check_Static_Boolean_Expression
14798 (Expression
(Get_Argument
(N
, Spec_Id
)));
14800 end Extensions_Visible
;
14806 -- pragma External (
14807 -- [ Convention =>] convention_IDENTIFIER,
14808 -- [ Entity =>] LOCAL_NAME
14809 -- [, [External_Name =>] static_string_EXPRESSION ]
14810 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14812 when Pragma_External
=> External
: declare
14815 pragma Warnings
(Off
, C
);
14822 Name_External_Name
,
14824 Check_At_Least_N_Arguments
(2);
14825 Check_At_Most_N_Arguments
(4);
14826 Process_Convention
(C
, E
);
14828 -- A pragma that applies to a Ghost entity becomes Ghost for the
14829 -- purposes of legality checks and removal of ignored Ghost code.
14831 Mark_Pragma_As_Ghost
(N
, E
);
14833 Note_Possible_Modification
14834 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14835 Process_Interface_Name
(E
, Arg3
, Arg4
);
14836 Set_Exported
(E
, Arg2
);
14839 --------------------------
14840 -- External_Name_Casing --
14841 --------------------------
14843 -- pragma External_Name_Casing (
14844 -- UPPERCASE | LOWERCASE
14845 -- [, AS_IS | UPPERCASE | LOWERCASE]);
14847 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
14850 Check_No_Identifiers
;
14852 if Arg_Count
= 2 then
14853 Check_Arg_Is_One_Of
14854 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
14856 case Chars
(Get_Pragma_Arg
(Arg2
)) is
14858 Opt
.External_Name_Exp_Casing
:= As_Is
;
14860 when Name_Uppercase
=>
14861 Opt
.External_Name_Exp_Casing
:= Uppercase
;
14863 when Name_Lowercase
=>
14864 Opt
.External_Name_Exp_Casing
:= Lowercase
;
14871 Check_Arg_Count
(1);
14874 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
14876 case Chars
(Get_Pragma_Arg
(Arg1
)) is
14877 when Name_Uppercase
=>
14878 Opt
.External_Name_Imp_Casing
:= Uppercase
;
14880 when Name_Lowercase
=>
14881 Opt
.External_Name_Imp_Casing
:= Lowercase
;
14886 end External_Name_Casing
;
14892 -- pragma Fast_Math;
14894 when Pragma_Fast_Math
=>
14896 Check_No_Identifiers
;
14897 Check_Valid_Configuration_Pragma
;
14900 --------------------------
14901 -- Favor_Top_Level --
14902 --------------------------
14904 -- pragma Favor_Top_Level (type_NAME);
14906 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
14911 Check_No_Identifiers
;
14912 Check_Arg_Count
(1);
14913 Check_Arg_Is_Local_Name
(Arg1
);
14914 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
14916 -- A pragma that applies to a Ghost entity becomes Ghost for the
14917 -- purposes of legality checks and removal of ignored Ghost code.
14919 Mark_Pragma_As_Ghost
(N
, Typ
);
14921 -- If it's an access-to-subprogram type (in particular, not a
14922 -- subtype), set the flag on that type.
14924 if Is_Access_Subprogram_Type
(Typ
) then
14925 Set_Can_Use_Internal_Rep
(Typ
, False);
14927 -- Otherwise it's an error (name denotes the wrong sort of entity)
14931 ("access-to-subprogram type expected",
14932 Get_Pragma_Arg
(Arg1
));
14934 end Favor_Top_Level
;
14936 ---------------------------
14937 -- Finalize_Storage_Only --
14938 ---------------------------
14940 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
14942 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
14943 Assoc
: constant Node_Id
:= Arg1
;
14944 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
14949 Check_No_Identifiers
;
14950 Check_Arg_Count
(1);
14951 Check_Arg_Is_Local_Name
(Arg1
);
14953 Find_Type
(Type_Id
);
14954 Typ
:= Entity
(Type_Id
);
14957 or else Rep_Item_Too_Early
(Typ
, N
)
14961 Typ
:= Underlying_Type
(Typ
);
14964 if not Is_Controlled
(Typ
) then
14965 Error_Pragma
("pragma% must specify controlled type");
14968 Check_First_Subtype
(Arg1
);
14970 if Finalize_Storage_Only
(Typ
) then
14971 Error_Pragma
("duplicate pragma%, only one allowed");
14973 elsif not Rep_Item_Too_Late
(Typ
, N
) then
14974 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
14976 end Finalize_Storage
;
14982 -- pragma Ghost [ (boolean_EXPRESSION) ];
14984 when Pragma_Ghost
=> Ghost
: declare
14988 Orig_Stmt
: Node_Id
;
14989 Prev_Id
: Entity_Id
;
14994 Check_No_Identifiers
;
14995 Check_At_Most_N_Arguments
(1);
14999 while Present
(Stmt
) loop
15001 -- Skip prior pragmas, but check for duplicates
15003 if Nkind
(Stmt
) = N_Pragma
then
15004 if Pragma_Name
(Stmt
) = Pname
then
15005 Error_Msg_Name_1
:= Pname
;
15006 Error_Msg_Sloc
:= Sloc
(Stmt
);
15007 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
15010 -- Task unit declared without a definition cannot be subject to
15011 -- pragma Ghost (SPARK RM 6.9(19)).
15013 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15014 N_Task_Type_Declaration
)
15016 Error_Pragma
("pragma % cannot apply to a task type");
15019 -- Skip internally generated code
15021 elsif not Comes_From_Source
(Stmt
) then
15022 Orig_Stmt
:= Original_Node
(Stmt
);
15024 -- When pragma Ghost applies to an untagged derivation, the
15025 -- derivation is transformed into a [sub]type declaration.
15027 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15028 N_Subtype_Declaration
)
15029 and then Comes_From_Source
(Orig_Stmt
)
15030 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15031 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15032 N_Derived_Type_Definition
15034 Id
:= Defining_Entity
(Stmt
);
15037 -- When pragma Ghost applies to an object declaration which
15038 -- is initialized by means of a function call that returns
15039 -- on the secondary stack, the object declaration becomes a
15042 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
15043 and then Comes_From_Source
(Orig_Stmt
)
15044 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
15046 Id
:= Defining_Entity
(Stmt
);
15049 -- When pragma Ghost applies to an expression function, the
15050 -- expression function is transformed into a subprogram.
15052 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
15053 and then Comes_From_Source
(Orig_Stmt
)
15054 and then Nkind
(Orig_Stmt
) = N_Expression_Function
15056 Id
:= Defining_Entity
(Stmt
);
15060 -- The pragma applies to a legal construct, stop the traversal
15062 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
15063 N_Full_Type_Declaration
,
15064 N_Generic_Subprogram_Declaration
,
15065 N_Object_Declaration
,
15066 N_Private_Extension_Declaration
,
15067 N_Private_Type_Declaration
,
15068 N_Subprogram_Declaration
,
15069 N_Subtype_Declaration
)
15071 Id
:= Defining_Entity
(Stmt
);
15074 -- The pragma does not apply to a legal construct, issue an
15075 -- error and stop the analysis.
15079 ("pragma % must apply to an object, package, subprogram "
15084 Stmt
:= Prev
(Stmt
);
15087 Context
:= Parent
(N
);
15089 -- Handle compilation units
15091 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
15092 Context
:= Unit
(Parent
(Context
));
15095 -- Protected and task types cannot be subject to pragma Ghost
15096 -- (SPARK RM 6.9(19)).
15098 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
15100 Error_Pragma
("pragma % cannot apply to a protected type");
15103 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
15104 Error_Pragma
("pragma % cannot apply to a task type");
15110 -- When pragma Ghost is associated with a [generic] package, it
15111 -- appears in the visible declarations.
15113 if Nkind
(Context
) = N_Package_Specification
15114 and then Present
(Visible_Declarations
(Context
))
15115 and then List_Containing
(N
) = Visible_Declarations
(Context
)
15117 Id
:= Defining_Entity
(Context
);
15119 -- Pragma Ghost applies to a stand alone subprogram body
15121 elsif Nkind
(Context
) = N_Subprogram_Body
15122 and then No
(Corresponding_Spec
(Context
))
15124 Id
:= Defining_Entity
(Context
);
15126 -- Pragma Ghost applies to a subprogram declaration that acts
15127 -- as a compilation unit.
15129 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
15130 Id
:= Defining_Entity
(Context
);
15136 ("pragma % must apply to an object, package, subprogram or "
15141 -- Handle completions of types and constants that are subject to
15144 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
15145 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
15147 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
15148 Error_Msg_Name_1
:= Pname
;
15150 -- The full declaration of a deferred constant cannot be
15151 -- subject to pragma Ghost unless the deferred declaration
15152 -- is also Ghost (SPARK RM 6.9(9)).
15154 if Ekind
(Prev_Id
) = E_Constant
then
15155 Error_Msg_Name_1
:= Pname
;
15156 Error_Msg_NE
(Fix_Error
15157 ("pragma % must apply to declaration of deferred "
15158 & "constant &"), N
, Id
);
15161 -- Pragma Ghost may appear on the full view of an incomplete
15162 -- type because the incomplete declaration lacks aspects and
15163 -- cannot be subject to pragma Ghost.
15165 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
15168 -- The full declaration of a type cannot be subject to
15169 -- pragma Ghost unless the partial view is also Ghost
15170 -- (SPARK RM 6.9(9)).
15173 Error_Msg_NE
(Fix_Error
15174 ("pragma % must apply to partial view of type &"),
15180 -- A synchronized object cannot be subject to pragma Ghost
15181 -- (SPARK RM 6.9(19)).
15183 elsif Ekind
(Id
) = E_Variable
then
15184 if Is_Protected_Type
(Etype
(Id
)) then
15185 Error_Pragma
("pragma % cannot apply to a protected object");
15188 elsif Is_Task_Type
(Etype
(Id
)) then
15189 Error_Pragma
("pragma % cannot apply to a task object");
15194 -- Analyze the Boolean expression (if any)
15196 if Present
(Arg1
) then
15197 Expr
:= Get_Pragma_Arg
(Arg1
);
15199 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
15201 if Is_OK_Static_Expression
(Expr
) then
15203 -- "Ghostness" cannot be turned off once enabled within a
15204 -- region (SPARK RM 6.9(6)).
15206 if Is_False
(Expr_Value
(Expr
))
15207 and then Ghost_Mode
> None
15210 ("pragma % with value False cannot appear in enabled "
15215 -- Otherwie the expression is not static
15219 ("expression of pragma % must be static", Expr
);
15224 Set_Is_Ghost_Entity
(Id
);
15231 -- pragma Global (GLOBAL_SPECIFICATION);
15233 -- GLOBAL_SPECIFICATION ::=
15236 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15238 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15240 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15241 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15242 -- GLOBAL_ITEM ::= NAME
15244 -- Characteristics:
15246 -- * Analysis - The annotation undergoes initial checks to verify
15247 -- the legal placement and context. Secondary checks fully analyze
15248 -- the dependency clauses in:
15250 -- Analyze_Global_In_Decl_Part
15252 -- * Expansion - None.
15254 -- * Template - The annotation utilizes the generic template of the
15255 -- related subprogram [body] when it is:
15257 -- aspect on subprogram declaration
15258 -- aspect on stand alone subprogram body
15259 -- pragma on stand alone subprogram body
15261 -- The annotation must prepare its own template when it is:
15263 -- pragma on subprogram declaration
15265 -- * Globals - Capture of global references must occur after full
15268 -- * Instance - The annotation is instantiated automatically when
15269 -- the related generic subprogram [body] is instantiated except for
15270 -- the "pragma on subprogram declaration" case. In that scenario
15271 -- the annotation must instantiate itself.
15273 when Pragma_Global
=> Global
: declare
15275 Spec_Id
: Entity_Id
;
15276 Subp_Decl
: Node_Id
;
15279 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15283 -- Chain the pragma on the contract for further processing by
15284 -- Analyze_Global_In_Decl_Part.
15286 Add_Contract_Item
(N
, Spec_Id
);
15288 -- Fully analyze the pragma when it appears inside an entry
15289 -- or subprogram body because it cannot benefit from forward
15292 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15294 N_Subprogram_Body_Stub
)
15296 -- The legality checks of pragmas Depends and Global are
15297 -- affected by the SPARK mode in effect and the volatility
15298 -- of the context. In addition these two pragmas are subject
15299 -- to an inherent order:
15304 -- Analyze all these pragmas in the order outlined above
15306 Analyze_If_Present
(Pragma_SPARK_Mode
);
15307 Analyze_If_Present
(Pragma_Volatile_Function
);
15308 Analyze_Global_In_Decl_Part
(N
);
15309 Analyze_If_Present
(Pragma_Depends
);
15318 -- pragma Ident (static_string_EXPRESSION)
15320 -- Note: pragma Comment shares this processing. Pragma Ident is
15321 -- identical in effect to pragma Commment.
15323 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
15328 Check_Arg_Count
(1);
15329 Check_No_Identifiers
;
15330 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15333 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
15340 GP
:= Parent
(Parent
(N
));
15342 if Nkind_In
(GP
, N_Package_Declaration
,
15343 N_Generic_Package_Declaration
)
15348 -- If we have a compilation unit, then record the ident value,
15349 -- checking for improper duplication.
15351 if Nkind
(GP
) = N_Compilation_Unit
then
15352 CS
:= Ident_String
(Current_Sem_Unit
);
15354 if Present
(CS
) then
15356 -- If we have multiple instances, concatenate them, but
15357 -- not in ASIS, where we want the original tree.
15359 if not ASIS_Mode
then
15360 Start_String
(Strval
(CS
));
15361 Store_String_Char
(' ');
15362 Store_String_Chars
(Strval
(Str
));
15363 Set_Strval
(CS
, End_String
);
15367 Set_Ident_String
(Current_Sem_Unit
, Str
);
15370 -- For subunits, we just ignore the Ident, since in GNAT these
15371 -- are not separate object files, and hence not separate units
15372 -- in the unit table.
15374 elsif Nkind
(GP
) = N_Subunit
then
15380 -------------------
15381 -- Ignore_Pragma --
15382 -------------------
15384 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15386 -- Entirely handled in the parser, nothing to do here
15388 when Pragma_Ignore_Pragma
=>
15391 ----------------------------
15392 -- Implementation_Defined --
15393 ----------------------------
15395 -- pragma Implementation_Defined (LOCAL_NAME);
15397 -- Marks previously declared entity as implementation defined. For
15398 -- an overloaded entity, applies to the most recent homonym.
15400 -- pragma Implementation_Defined;
15402 -- The form with no arguments appears anywhere within a scope, most
15403 -- typically a package spec, and indicates that all entities that are
15404 -- defined within the package spec are Implementation_Defined.
15406 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15411 Check_No_Identifiers
;
15413 -- Form with no arguments
15415 if Arg_Count
= 0 then
15416 Set_Is_Implementation_Defined
(Current_Scope
);
15418 -- Form with one argument
15421 Check_Arg_Count
(1);
15422 Check_Arg_Is_Local_Name
(Arg1
);
15423 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15424 Set_Is_Implementation_Defined
(Ent
);
15426 end Implementation_Defined
;
15432 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15434 -- IMPLEMENTATION_KIND ::=
15435 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15437 -- "By_Any" and "Optional" are treated as synonyms in order to
15438 -- support Ada 2012 aspect Synchronization.
15440 when Pragma_Implemented
=> Implemented
: declare
15441 Proc_Id
: Entity_Id
;
15446 Check_Arg_Count
(2);
15447 Check_No_Identifiers
;
15448 Check_Arg_Is_Identifier
(Arg1
);
15449 Check_Arg_Is_Local_Name
(Arg1
);
15450 Check_Arg_Is_One_Of
(Arg2
,
15453 Name_By_Protected_Procedure
,
15456 -- Extract the name of the local procedure
15458 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15460 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15461 -- primitive procedure of a synchronized tagged type.
15463 if Ekind
(Proc_Id
) = E_Procedure
15464 and then Is_Primitive
(Proc_Id
)
15465 and then Present
(First_Formal
(Proc_Id
))
15467 Typ
:= Etype
(First_Formal
(Proc_Id
));
15469 if Is_Tagged_Type
(Typ
)
15472 -- Check for a protected, a synchronized or a task interface
15474 ((Is_Interface
(Typ
)
15475 and then Is_Synchronized_Interface
(Typ
))
15477 -- Check for a protected type or a task type that implements
15481 (Is_Concurrent_Record_Type
(Typ
)
15482 and then Present
(Interfaces
(Typ
)))
15484 -- In analysis-only mode, examine original protected type
15487 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
15488 and then Present
(Interface_List
(Parent
(Typ
))))
15490 -- Check for a private record extension with keyword
15494 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
15495 E_Record_Subtype_With_Private
)
15496 and then Synchronized_Present
(Parent
(Typ
))))
15501 ("controlling formal must be of synchronized tagged type",
15506 -- Procedures declared inside a protected type must be accepted
15508 elsif Ekind
(Proc_Id
) = E_Procedure
15509 and then Is_Protected_Type
(Scope
(Proc_Id
))
15513 -- The first argument is not a primitive procedure
15517 ("pragma % must be applied to a primitive procedure", Arg1
);
15521 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15522 -- By_Protected_Procedure to the primitive procedure of a task
15525 if Chars
(Arg2
) = Name_By_Protected_Procedure
15526 and then Is_Interface
(Typ
)
15527 and then Is_Task_Interface
(Typ
)
15530 ("implementation kind By_Protected_Procedure cannot be "
15531 & "applied to a task interface primitive", Arg2
);
15535 Record_Rep_Item
(Proc_Id
, N
);
15538 ----------------------
15539 -- Implicit_Packing --
15540 ----------------------
15542 -- pragma Implicit_Packing;
15544 when Pragma_Implicit_Packing
=>
15546 Check_Arg_Count
(0);
15547 Implicit_Packing
:= True;
15554 -- [Convention =>] convention_IDENTIFIER,
15555 -- [Entity =>] LOCAL_NAME
15556 -- [, [External_Name =>] static_string_EXPRESSION ]
15557 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15559 when Pragma_Import
=>
15560 Check_Ada_83_Warning
;
15564 Name_External_Name
,
15567 Check_At_Least_N_Arguments
(2);
15568 Check_At_Most_N_Arguments
(4);
15569 Process_Import_Or_Interface
;
15571 ---------------------
15572 -- Import_Function --
15573 ---------------------
15575 -- pragma Import_Function (
15576 -- [Internal =>] LOCAL_NAME,
15577 -- [, [External =>] EXTERNAL_SYMBOL]
15578 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15579 -- [, [Result_Type =>] SUBTYPE_MARK]
15580 -- [, [Mechanism =>] MECHANISM]
15581 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15583 -- EXTERNAL_SYMBOL ::=
15585 -- | static_string_EXPRESSION
15587 -- PARAMETER_TYPES ::=
15589 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15591 -- TYPE_DESIGNATOR ::=
15593 -- | subtype_Name ' Access
15597 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15599 -- MECHANISM_ASSOCIATION ::=
15600 -- [formal_parameter_NAME =>] MECHANISM_NAME
15602 -- MECHANISM_NAME ::=
15606 when Pragma_Import_Function
=> Import_Function
: declare
15607 Args
: Args_List
(1 .. 6);
15608 Names
: constant Name_List
(1 .. 6) := (
15611 Name_Parameter_Types
,
15614 Name_Result_Mechanism
);
15616 Internal
: Node_Id
renames Args
(1);
15617 External
: Node_Id
renames Args
(2);
15618 Parameter_Types
: Node_Id
renames Args
(3);
15619 Result_Type
: Node_Id
renames Args
(4);
15620 Mechanism
: Node_Id
renames Args
(5);
15621 Result_Mechanism
: Node_Id
renames Args
(6);
15625 Gather_Associations
(Names
, Args
);
15626 Process_Extended_Import_Export_Subprogram_Pragma
(
15627 Arg_Internal
=> Internal
,
15628 Arg_External
=> External
,
15629 Arg_Parameter_Types
=> Parameter_Types
,
15630 Arg_Result_Type
=> Result_Type
,
15631 Arg_Mechanism
=> Mechanism
,
15632 Arg_Result_Mechanism
=> Result_Mechanism
);
15633 end Import_Function
;
15635 -------------------
15636 -- Import_Object --
15637 -------------------
15639 -- pragma Import_Object (
15640 -- [Internal =>] LOCAL_NAME
15641 -- [, [External =>] EXTERNAL_SYMBOL]
15642 -- [, [Size =>] EXTERNAL_SYMBOL]);
15644 -- EXTERNAL_SYMBOL ::=
15646 -- | static_string_EXPRESSION
15648 when Pragma_Import_Object
=> Import_Object
: declare
15649 Args
: Args_List
(1 .. 3);
15650 Names
: constant Name_List
(1 .. 3) := (
15655 Internal
: Node_Id
renames Args
(1);
15656 External
: Node_Id
renames Args
(2);
15657 Size
: Node_Id
renames Args
(3);
15661 Gather_Associations
(Names
, Args
);
15662 Process_Extended_Import_Export_Object_Pragma
(
15663 Arg_Internal
=> Internal
,
15664 Arg_External
=> External
,
15668 ----------------------
15669 -- Import_Procedure --
15670 ----------------------
15672 -- pragma Import_Procedure (
15673 -- [Internal =>] LOCAL_NAME
15674 -- [, [External =>] EXTERNAL_SYMBOL]
15675 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15676 -- [, [Mechanism =>] MECHANISM]);
15678 -- EXTERNAL_SYMBOL ::=
15680 -- | static_string_EXPRESSION
15682 -- PARAMETER_TYPES ::=
15684 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15686 -- TYPE_DESIGNATOR ::=
15688 -- | subtype_Name ' Access
15692 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15694 -- MECHANISM_ASSOCIATION ::=
15695 -- [formal_parameter_NAME =>] MECHANISM_NAME
15697 -- MECHANISM_NAME ::=
15701 when Pragma_Import_Procedure
=> Import_Procedure
: declare
15702 Args
: Args_List
(1 .. 4);
15703 Names
: constant Name_List
(1 .. 4) := (
15706 Name_Parameter_Types
,
15709 Internal
: Node_Id
renames Args
(1);
15710 External
: Node_Id
renames Args
(2);
15711 Parameter_Types
: Node_Id
renames Args
(3);
15712 Mechanism
: Node_Id
renames Args
(4);
15716 Gather_Associations
(Names
, Args
);
15717 Process_Extended_Import_Export_Subprogram_Pragma
(
15718 Arg_Internal
=> Internal
,
15719 Arg_External
=> External
,
15720 Arg_Parameter_Types
=> Parameter_Types
,
15721 Arg_Mechanism
=> Mechanism
);
15722 end Import_Procedure
;
15724 -----------------------------
15725 -- Import_Valued_Procedure --
15726 -----------------------------
15728 -- pragma Import_Valued_Procedure (
15729 -- [Internal =>] LOCAL_NAME
15730 -- [, [External =>] EXTERNAL_SYMBOL]
15731 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15732 -- [, [Mechanism =>] MECHANISM]);
15734 -- EXTERNAL_SYMBOL ::=
15736 -- | static_string_EXPRESSION
15738 -- PARAMETER_TYPES ::=
15740 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15742 -- TYPE_DESIGNATOR ::=
15744 -- | subtype_Name ' Access
15748 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15750 -- MECHANISM_ASSOCIATION ::=
15751 -- [formal_parameter_NAME =>] MECHANISM_NAME
15753 -- MECHANISM_NAME ::=
15757 when Pragma_Import_Valued_Procedure
=>
15758 Import_Valued_Procedure
: declare
15759 Args
: Args_List
(1 .. 4);
15760 Names
: constant Name_List
(1 .. 4) := (
15763 Name_Parameter_Types
,
15766 Internal
: Node_Id
renames Args
(1);
15767 External
: Node_Id
renames Args
(2);
15768 Parameter_Types
: Node_Id
renames Args
(3);
15769 Mechanism
: Node_Id
renames Args
(4);
15773 Gather_Associations
(Names
, Args
);
15774 Process_Extended_Import_Export_Subprogram_Pragma
(
15775 Arg_Internal
=> Internal
,
15776 Arg_External
=> External
,
15777 Arg_Parameter_Types
=> Parameter_Types
,
15778 Arg_Mechanism
=> Mechanism
);
15779 end Import_Valued_Procedure
;
15785 -- pragma Independent (LOCAL_NAME);
15787 when Pragma_Independent
=>
15788 Process_Atomic_Independent_Shared_Volatile
;
15790 ----------------------------
15791 -- Independent_Components --
15792 ----------------------------
15794 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
15796 when Pragma_Independent_Components
=> Independent_Components
: declare
15804 Check_Ada_83_Warning
;
15806 Check_No_Identifiers
;
15807 Check_Arg_Count
(1);
15808 Check_Arg_Is_Local_Name
(Arg1
);
15809 E_Id
:= Get_Pragma_Arg
(Arg1
);
15811 if Etype
(E_Id
) = Any_Type
then
15815 E
:= Entity
(E_Id
);
15817 -- A pragma that applies to a Ghost entity becomes Ghost for the
15818 -- purposes of legality checks and removal of ignored Ghost code.
15820 Mark_Pragma_As_Ghost
(N
, E
);
15822 -- Check duplicate before we chain ourselves
15824 Check_Duplicate_Pragma
(E
);
15826 -- Check appropriate entity
15828 if Rep_Item_Too_Early
(E
, N
)
15830 Rep_Item_Too_Late
(E
, N
)
15835 D
:= Declaration_Node
(E
);
15838 -- The flag is set on the base type, or on the object
15840 if K
= N_Full_Type_Declaration
15841 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
15843 Set_Has_Independent_Components
(Base_Type
(E
));
15844 Record_Independence_Check
(N
, Base_Type
(E
));
15846 -- For record type, set all components independent
15848 if Is_Record_Type
(E
) then
15849 C
:= First_Component
(E
);
15850 while Present
(C
) loop
15851 Set_Is_Independent
(C
);
15852 Next_Component
(C
);
15856 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
15857 and then Nkind
(D
) = N_Object_Declaration
15858 and then Nkind
(Object_Definition
(D
)) =
15859 N_Constrained_Array_Definition
15861 Set_Has_Independent_Components
(E
);
15862 Record_Independence_Check
(N
, E
);
15865 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
15867 end Independent_Components
;
15869 -----------------------
15870 -- Initial_Condition --
15871 -----------------------
15873 -- pragma Initial_Condition (boolean_EXPRESSION);
15875 -- Characteristics:
15877 -- * Analysis - The annotation undergoes initial checks to verify
15878 -- the legal placement and context. Secondary checks preanalyze the
15881 -- Analyze_Initial_Condition_In_Decl_Part
15883 -- * Expansion - The annotation is expanded during the expansion of
15884 -- the package body whose declaration is subject to the annotation
15887 -- Expand_Pragma_Initial_Condition
15889 -- * Template - The annotation utilizes the generic template of the
15890 -- related package declaration.
15892 -- * Globals - Capture of global references must occur after full
15895 -- * Instance - The annotation is instantiated automatically when
15896 -- the related generic package is instantiated.
15898 when Pragma_Initial_Condition
=> Initial_Condition
: declare
15899 Pack_Decl
: Node_Id
;
15900 Pack_Id
: Entity_Id
;
15904 Check_No_Identifiers
;
15905 Check_Arg_Count
(1);
15907 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
15909 -- Ensure the proper placement of the pragma. Initial_Condition
15910 -- must be associated with a package declaration.
15912 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
15913 N_Package_Declaration
)
15917 -- Otherwise the pragma is associated with an illegal context
15924 Pack_Id
:= Defining_Entity
(Pack_Decl
);
15926 -- Chain the pragma on the contract for further processing by
15927 -- Analyze_Initial_Condition_In_Decl_Part.
15929 Add_Contract_Item
(N
, Pack_Id
);
15931 -- The legality checks of pragmas Abstract_State, Initializes, and
15932 -- Initial_Condition are affected by the SPARK mode in effect. In
15933 -- addition, these three pragmas are subject to an inherent order:
15935 -- 1) Abstract_State
15937 -- 3) Initial_Condition
15939 -- Analyze all these pragmas in the order outlined above
15941 Analyze_If_Present
(Pragma_SPARK_Mode
);
15942 Analyze_If_Present
(Pragma_Abstract_State
);
15943 Analyze_If_Present
(Pragma_Initializes
);
15945 -- A pragma that applies to a Ghost entity becomes Ghost for the
15946 -- purposes of legality checks and removal of ignored Ghost code.
15948 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
15949 end Initial_Condition
;
15951 ------------------------
15952 -- Initialize_Scalars --
15953 ------------------------
15955 -- pragma Initialize_Scalars;
15957 when Pragma_Initialize_Scalars
=>
15959 Check_Arg_Count
(0);
15960 Check_Valid_Configuration_Pragma
;
15961 Check_Restriction
(No_Initialize_Scalars
, N
);
15963 -- Initialize_Scalars creates false positives in CodePeer, and
15964 -- incorrect negative results in GNATprove mode, so ignore this
15965 -- pragma in these modes.
15967 if not Restriction_Active
(No_Initialize_Scalars
)
15968 and then not (CodePeer_Mode
or GNATprove_Mode
)
15970 Init_Or_Norm_Scalars
:= True;
15971 Initialize_Scalars
:= True;
15978 -- pragma Initializes (INITIALIZATION_LIST);
15980 -- INITIALIZATION_LIST ::=
15982 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
15984 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
15989 -- | (INPUT {, INPUT})
15993 -- Characteristics:
15995 -- * Analysis - The annotation undergoes initial checks to verify
15996 -- the legal placement and context. Secondary checks preanalyze the
15999 -- Analyze_Initializes_In_Decl_Part
16001 -- * Expansion - None.
16003 -- * Template - The annotation utilizes the generic template of the
16004 -- related package declaration.
16006 -- * Globals - Capture of global references must occur after full
16009 -- * Instance - The annotation is instantiated automatically when
16010 -- the related generic package is instantiated.
16012 when Pragma_Initializes
=> Initializes
: declare
16013 Pack_Decl
: Node_Id
;
16014 Pack_Id
: Entity_Id
;
16018 Check_No_Identifiers
;
16019 Check_Arg_Count
(1);
16021 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16023 -- Ensure the proper placement of the pragma. Initializes must be
16024 -- associated with a package declaration.
16026 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16027 N_Package_Declaration
)
16031 -- Otherwise the pragma is associated with an illegal construc
16038 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16040 -- Chain the pragma on the contract for further processing by
16041 -- Analyze_Initializes_In_Decl_Part.
16043 Add_Contract_Item
(N
, Pack_Id
);
16045 -- The legality checks of pragmas Abstract_State, Initializes, and
16046 -- Initial_Condition are affected by the SPARK mode in effect. In
16047 -- addition, these three pragmas are subject to an inherent order:
16049 -- 1) Abstract_State
16051 -- 3) Initial_Condition
16053 -- Analyze all these pragmas in the order outlined above
16055 Analyze_If_Present
(Pragma_SPARK_Mode
);
16056 Analyze_If_Present
(Pragma_Abstract_State
);
16058 -- A pragma that applies to a Ghost entity becomes Ghost for the
16059 -- purposes of legality checks and removal of ignored Ghost code.
16061 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
16062 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
16064 Analyze_If_Present
(Pragma_Initial_Condition
);
16071 -- pragma Inline ( NAME {, NAME} );
16073 when Pragma_Inline
=>
16075 -- Pragma always active unless in GNATprove mode. It is disabled
16076 -- in GNATprove mode because frontend inlining is applied
16077 -- independently of pragmas Inline and Inline_Always for
16078 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16081 if not GNATprove_Mode
then
16083 -- Inline status is Enabled if inlining option is active
16085 if Inline_Active
then
16086 Process_Inline
(Enabled
);
16088 Process_Inline
(Disabled
);
16092 -------------------
16093 -- Inline_Always --
16094 -------------------
16096 -- pragma Inline_Always ( NAME {, NAME} );
16098 when Pragma_Inline_Always
=>
16101 -- Pragma always active unless in CodePeer mode or GNATprove
16102 -- mode. It is disabled in CodePeer mode because inlining is
16103 -- not helpful, and enabling it caused walk order issues. It
16104 -- is disabled in GNATprove mode because frontend inlining is
16105 -- applied independently of pragmas Inline and Inline_Always for
16106 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16109 if not CodePeer_Mode
and not GNATprove_Mode
then
16110 Process_Inline
(Enabled
);
16113 --------------------
16114 -- Inline_Generic --
16115 --------------------
16117 -- pragma Inline_Generic (NAME {, NAME});
16119 when Pragma_Inline_Generic
=>
16121 Process_Generic_List
;
16123 ----------------------
16124 -- Inspection_Point --
16125 ----------------------
16127 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16129 when Pragma_Inspection_Point
=> Inspection_Point
: declare
16136 if Arg_Count
> 0 then
16139 Exp
:= Get_Pragma_Arg
(Arg
);
16142 if not Is_Entity_Name
(Exp
)
16143 or else not Is_Object
(Entity
(Exp
))
16145 Error_Pragma_Arg
("object name required", Arg
);
16149 exit when No
(Arg
);
16152 end Inspection_Point
;
16158 -- pragma Interface (
16159 -- [ Convention =>] convention_IDENTIFIER,
16160 -- [ Entity =>] LOCAL_NAME
16161 -- [, [External_Name =>] static_string_EXPRESSION ]
16162 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16164 when Pragma_Interface
=>
16169 Name_External_Name
,
16171 Check_At_Least_N_Arguments
(2);
16172 Check_At_Most_N_Arguments
(4);
16173 Process_Import_Or_Interface
;
16175 -- In Ada 2005, the permission to use Interface (a reserved word)
16176 -- as a pragma name is considered an obsolescent feature, and this
16177 -- pragma was already obsolescent in Ada 95.
16179 if Ada_Version
>= Ada_95
then
16181 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16183 if Warn_On_Obsolescent_Feature
then
16185 ("pragma Interface is an obsolescent feature?j?", N
);
16187 ("|use pragma Import instead?j?", N
);
16191 --------------------
16192 -- Interface_Name --
16193 --------------------
16195 -- pragma Interface_Name (
16196 -- [ Entity =>] LOCAL_NAME
16197 -- [,[External_Name =>] static_string_EXPRESSION ]
16198 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16200 when Pragma_Interface_Name
=> Interface_Name
: declare
16202 Def_Id
: Entity_Id
;
16203 Hom_Id
: Entity_Id
;
16209 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
16210 Check_At_Least_N_Arguments
(2);
16211 Check_At_Most_N_Arguments
(3);
16212 Id
:= Get_Pragma_Arg
(Arg1
);
16215 -- This is obsolete from Ada 95 on, but it is an implementation
16216 -- defined pragma, so we do not consider that it violates the
16217 -- restriction (No_Obsolescent_Features).
16219 if Ada_Version
>= Ada_95
then
16220 if Warn_On_Obsolescent_Feature
then
16222 ("pragma Interface_Name is an obsolescent feature?j?", N
);
16224 ("|use pragma Import instead?j?", N
);
16228 if not Is_Entity_Name
(Id
) then
16230 ("first argument for pragma% must be entity name", Arg1
);
16231 elsif Etype
(Id
) = Any_Type
then
16234 Def_Id
:= Entity
(Id
);
16237 -- Special DEC-compatible processing for the object case, forces
16238 -- object to be imported.
16240 if Ekind
(Def_Id
) = E_Variable
then
16241 Kill_Size_Check_Code
(Def_Id
);
16242 Note_Possible_Modification
(Id
, Sure
=> False);
16244 -- Initialization is not allowed for imported variable
16246 if Present
(Expression
(Parent
(Def_Id
)))
16247 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
16249 Error_Msg_Sloc
:= Sloc
(Def_Id
);
16251 ("no initialization allowed for declaration of& #",
16255 -- For compatibility, support VADS usage of providing both
16256 -- pragmas Interface and Interface_Name to obtain the effect
16257 -- of a single Import pragma.
16259 if Is_Imported
(Def_Id
)
16260 and then Present
(First_Rep_Item
(Def_Id
))
16261 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
16263 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
16267 Set_Imported
(Def_Id
);
16270 Set_Is_Public
(Def_Id
);
16271 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16274 -- Otherwise must be subprogram
16276 elsif not Is_Subprogram
(Def_Id
) then
16278 ("argument of pragma% is not subprogram", Arg1
);
16281 Check_At_Most_N_Arguments
(3);
16285 -- Loop through homonyms
16288 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
16290 if Is_Imported
(Def_Id
) then
16291 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16295 exit when From_Aspect_Specification
(N
);
16296 Hom_Id
:= Homonym
(Hom_Id
);
16298 exit when No
(Hom_Id
)
16299 or else Scope
(Hom_Id
) /= Current_Scope
;
16304 ("argument of pragma% is not imported subprogram",
16308 end Interface_Name
;
16310 -----------------------
16311 -- Interrupt_Handler --
16312 -----------------------
16314 -- pragma Interrupt_Handler (handler_NAME);
16316 when Pragma_Interrupt_Handler
=>
16317 Check_Ada_83_Warning
;
16318 Check_Arg_Count
(1);
16319 Check_No_Identifiers
;
16321 if No_Run_Time_Mode
then
16322 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
16324 Check_Interrupt_Or_Attach_Handler
;
16325 Process_Interrupt_Or_Attach_Handler
;
16328 ------------------------
16329 -- Interrupt_Priority --
16330 ------------------------
16332 -- pragma Interrupt_Priority [(EXPRESSION)];
16334 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
16335 P
: constant Node_Id
:= Parent
(N
);
16340 Check_Ada_83_Warning
;
16342 if Arg_Count
/= 0 then
16343 Arg
:= Get_Pragma_Arg
(Arg1
);
16344 Check_Arg_Count
(1);
16345 Check_No_Identifiers
;
16347 -- The expression must be analyzed in the special manner
16348 -- described in "Handling of Default and Per-Object
16349 -- Expressions" in sem.ads.
16351 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
16354 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
16359 Ent
:= Defining_Identifier
(Parent
(P
));
16361 -- Check duplicate pragma before we chain the pragma in the Rep
16362 -- Item chain of Ent.
16364 Check_Duplicate_Pragma
(Ent
);
16365 Record_Rep_Item
(Ent
, N
);
16367 -- Check the No_Task_At_Interrupt_Priority restriction
16369 if Nkind
(P
) = N_Task_Definition
then
16370 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16373 end Interrupt_Priority
;
16375 ---------------------
16376 -- Interrupt_State --
16377 ---------------------
16379 -- pragma Interrupt_State (
16380 -- [Name =>] INTERRUPT_ID,
16381 -- [State =>] INTERRUPT_STATE);
16383 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16384 -- INTERRUPT_STATE => System | Runtime | User
16386 -- Note: if the interrupt id is given as an identifier, then it must
16387 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16388 -- given as a static integer expression which must be in the range of
16389 -- Ada.Interrupts.Interrupt_ID.
16391 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16392 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16393 -- This is the entity Ada.Interrupts.Interrupt_ID;
16395 State_Type
: Character;
16396 -- Set to 's'/'r'/'u' for System/Runtime/User
16399 -- Index to entry in Interrupt_States table
16402 -- Value of interrupt
16404 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16405 -- The first argument to the pragma
16407 Int_Ent
: Entity_Id
;
16408 -- Interrupt entity in Ada.Interrupts.Names
16412 Check_Arg_Order
((Name_Name
, Name_State
));
16413 Check_Arg_Count
(2);
16415 Check_Optional_Identifier
(Arg1
, Name_Name
);
16416 Check_Optional_Identifier
(Arg2
, Name_State
);
16417 Check_Arg_Is_Identifier
(Arg2
);
16419 -- First argument is identifier
16421 if Nkind
(Arg1X
) = N_Identifier
then
16423 -- Search list of names in Ada.Interrupts.Names
16425 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16427 if No
(Int_Ent
) then
16428 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16430 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16431 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16435 Next_Entity
(Int_Ent
);
16438 -- First argument is not an identifier, so it must be a static
16439 -- expression of type Ada.Interrupts.Interrupt_ID.
16442 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16443 Int_Val
:= Expr_Value
(Arg1X
);
16445 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16447 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
16450 ("value not in range of type "
16451 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
16457 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16458 when Name_Runtime
=> State_Type
:= 'r';
16459 when Name_System
=> State_Type
:= 's';
16460 when Name_User
=> State_Type
:= 'u';
16463 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
16466 -- Check if entry is already stored
16468 IST_Num
:= Interrupt_States
.First
;
16470 -- If entry not found, add it
16472 if IST_Num
> Interrupt_States
.Last
then
16473 Interrupt_States
.Append
16474 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
16475 Interrupt_State
=> State_Type
,
16476 Pragma_Loc
=> Loc
));
16479 -- Case of entry for the same entry
16481 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
16484 -- If state matches, done, no need to make redundant entry
16487 State_Type
= Interrupt_States
.Table
(IST_Num
).
16490 -- Otherwise if state does not match, error
16493 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
16495 ("state conflicts with that given #", Arg2
);
16499 IST_Num
:= IST_Num
+ 1;
16501 end Interrupt_State
;
16507 -- pragma Invariant
16508 -- ([Entity =>] type_LOCAL_NAME,
16509 -- [Check =>] EXPRESSION
16510 -- [,[Message =>] String_Expression]);
16512 when Pragma_Invariant
=> Invariant
: declare
16519 Check_At_Least_N_Arguments
(2);
16520 Check_At_Most_N_Arguments
(3);
16521 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16522 Check_Optional_Identifier
(Arg2
, Name_Check
);
16524 if Arg_Count
= 3 then
16525 Check_Optional_Identifier
(Arg3
, Name_Message
);
16526 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
16529 Check_Arg_Is_Local_Name
(Arg1
);
16531 Type_Id
:= Get_Pragma_Arg
(Arg1
);
16532 Find_Type
(Type_Id
);
16533 Typ
:= Entity
(Type_Id
);
16535 if Typ
= Any_Type
then
16538 -- Invariants allowed in interface types (RM 7.3.2(3/3))
16540 elsif Is_Interface
(Typ
) then
16543 -- An invariant must apply to a private type, or appear in the
16544 -- private part of a package spec and apply to a completion.
16545 -- a class-wide invariant can only appear on a private declaration
16546 -- or private extension, not a completion.
16548 elsif Ekind_In
(Typ
, E_Private_Type
,
16549 E_Record_Type_With_Private
,
16550 E_Limited_Private_Type
)
16554 elsif In_Private_Part
(Current_Scope
)
16555 and then Has_Private_Declaration
(Typ
)
16556 and then not Class_Present
(N
)
16560 elsif In_Private_Part
(Current_Scope
) then
16562 ("pragma% only allowed for private type declared in "
16563 & "visible part", Arg1
);
16567 ("pragma% only allowed for private type", Arg1
);
16570 -- A pragma that applies to a Ghost entity becomes Ghost for the
16571 -- purposes of legality checks and removal of ignored Ghost code.
16573 Mark_Pragma_As_Ghost
(N
, Typ
);
16575 -- Not allowed for abstract type in the non-class case (it is
16576 -- allowed to use Invariant'Class for abstract types).
16578 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
16580 ("pragma% not allowed for abstract type", Arg1
);
16583 -- Link the pragma on to the rep item chain, for processing when
16584 -- the type is frozen.
16586 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16588 -- Note that the type has at least one invariant, and also that
16589 -- it has inheritable invariants if we have Invariant'Class
16590 -- or Type_Invariant'Class. Build the corresponding invariant
16591 -- procedure declaration, so that calls to it can be generated
16592 -- before the body is built (e.g. within an expression function).
16594 -- Interface types have no invariant procedure; their invariants
16595 -- are propagated to the build invariant procedure of all the
16596 -- types covering the interface type.
16598 if not Is_Interface
(Typ
) then
16599 Insert_After_And_Analyze
16600 (N
, Build_Invariant_Procedure_Declaration
(Typ
));
16603 if Class_Present
(N
) then
16604 Set_Has_Inheritable_Invariants
(Typ
);
16612 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16614 when Pragma_Keep_Names
=> Keep_Names
: declare
16619 Check_Arg_Count
(1);
16620 Check_Optional_Identifier
(Arg1
, Name_On
);
16621 Check_Arg_Is_Local_Name
(Arg1
);
16623 Arg
:= Get_Pragma_Arg
(Arg1
);
16626 if Etype
(Arg
) = Any_Type
then
16630 if not Is_Entity_Name
(Arg
)
16631 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16634 ("pragma% requires a local enumeration type", Arg1
);
16637 Set_Discard_Names
(Entity
(Arg
), False);
16644 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16646 when Pragma_License
=>
16649 -- Do not analyze pragma any further in CodePeer mode, to avoid
16650 -- extraneous errors in this implementation-dependent pragma,
16651 -- which has a different profile on other compilers.
16653 if CodePeer_Mode
then
16657 Check_Arg_Count
(1);
16658 Check_No_Identifiers
;
16659 Check_Valid_Configuration_Pragma
;
16660 Check_Arg_Is_Identifier
(Arg1
);
16663 Sind
: constant Source_File_Index
:=
16664 Source_Index
(Current_Sem_Unit
);
16667 case Chars
(Get_Pragma_Arg
(Arg1
)) is
16669 Set_License
(Sind
, GPL
);
16671 when Name_Modified_GPL
=>
16672 Set_License
(Sind
, Modified_GPL
);
16674 when Name_Restricted
=>
16675 Set_License
(Sind
, Restricted
);
16677 when Name_Unrestricted
=>
16678 Set_License
(Sind
, Unrestricted
);
16681 Error_Pragma_Arg
("invalid license name", Arg1
);
16689 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
16691 when Pragma_Link_With
=> Link_With
: declare
16697 if Operating_Mode
= Generate_Code
16698 and then In_Extended_Main_Source_Unit
(N
)
16700 Check_At_Least_N_Arguments
(1);
16701 Check_No_Identifiers
;
16702 Check_Is_In_Decl_Part_Or_Package_Spec
;
16703 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16707 while Present
(Arg
) loop
16708 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16710 -- Store argument, converting sequences of spaces to a
16711 -- single null character (this is one of the differences
16712 -- in processing between Link_With and Linker_Options).
16714 Arg_Store
: declare
16715 C
: constant Char_Code
:= Get_Char_Code
(' ');
16716 S
: constant String_Id
:=
16717 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
16718 L
: constant Nat
:= String_Length
(S
);
16721 procedure Skip_Spaces
;
16722 -- Advance F past any spaces
16728 procedure Skip_Spaces
is
16730 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
16735 -- Start of processing for Arg_Store
16738 Skip_Spaces
; -- skip leading spaces
16740 -- Loop through characters, changing any embedded
16741 -- sequence of spaces to a single null character (this
16742 -- is how Link_With/Linker_Options differ)
16745 if Get_String_Char
(S
, F
) = C
then
16748 Store_String_Char
(ASCII
.NUL
);
16751 Store_String_Char
(Get_String_Char
(S
, F
));
16759 if Present
(Arg
) then
16760 Store_String_Char
(ASCII
.NUL
);
16764 Store_Linker_Option_String
(End_String
);
16772 -- pragma Linker_Alias (
16773 -- [Entity =>] LOCAL_NAME
16774 -- [Target =>] static_string_EXPRESSION);
16776 when Pragma_Linker_Alias
=>
16778 Check_Arg_Order
((Name_Entity
, Name_Target
));
16779 Check_Arg_Count
(2);
16780 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16781 Check_Optional_Identifier
(Arg2
, Name_Target
);
16782 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16783 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16785 -- The only processing required is to link this item on to the
16786 -- list of rep items for the given entity. This is accomplished
16787 -- by the call to Rep_Item_Too_Late (when no error is detected
16788 -- and False is returned).
16790 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
16793 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
16796 ------------------------
16797 -- Linker_Constructor --
16798 ------------------------
16800 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
16802 -- Code is shared with Linker_Destructor
16804 -----------------------
16805 -- Linker_Destructor --
16806 -----------------------
16808 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
16810 when Pragma_Linker_Constructor |
16811 Pragma_Linker_Destructor
=>
16812 Linker_Constructor
: declare
16818 Check_Arg_Count
(1);
16819 Check_No_Identifiers
;
16820 Check_Arg_Is_Local_Name
(Arg1
);
16821 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
16823 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
16825 if not Is_Library_Level_Entity
(Proc
) then
16827 ("argument for pragma% must be library level entity", Arg1
);
16830 -- The only processing required is to link this item on to the
16831 -- list of rep items for the given entity. This is accomplished
16832 -- by the call to Rep_Item_Too_Late (when no error is detected
16833 -- and False is returned).
16835 if Rep_Item_Too_Late
(Proc
, N
) then
16838 Set_Has_Gigi_Rep_Item
(Proc
);
16840 end Linker_Constructor
;
16842 --------------------
16843 -- Linker_Options --
16844 --------------------
16846 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
16848 when Pragma_Linker_Options
=> Linker_Options
: declare
16852 Check_Ada_83_Warning
;
16853 Check_No_Identifiers
;
16854 Check_Arg_Count
(1);
16855 Check_Is_In_Decl_Part_Or_Package_Spec
;
16856 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
16857 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
16860 while Present
(Arg
) loop
16861 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
16862 Store_String_Char
(ASCII
.NUL
);
16864 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
16868 if Operating_Mode
= Generate_Code
16869 and then In_Extended_Main_Source_Unit
(N
)
16871 Store_Linker_Option_String
(End_String
);
16873 end Linker_Options
;
16875 --------------------
16876 -- Linker_Section --
16877 --------------------
16879 -- pragma Linker_Section (
16880 -- [Entity =>] LOCAL_NAME
16881 -- [Section =>] static_string_EXPRESSION);
16883 when Pragma_Linker_Section
=> Linker_Section
: declare
16888 Ghost_Error_Posted
: Boolean := False;
16889 -- Flag set when an error concerning the illegal mix of Ghost and
16890 -- non-Ghost subprograms is emitted.
16892 Ghost_Id
: Entity_Id
:= Empty
;
16893 -- The entity of the first Ghost subprogram encountered while
16894 -- processing the arguments of the pragma.
16898 Check_Arg_Order
((Name_Entity
, Name_Section
));
16899 Check_Arg_Count
(2);
16900 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16901 Check_Optional_Identifier
(Arg2
, Name_Section
);
16902 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
16903 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
16905 -- Check kind of entity
16907 Arg
:= Get_Pragma_Arg
(Arg1
);
16908 Ent
:= Entity
(Arg
);
16910 case Ekind
(Ent
) is
16912 -- Objects (constants and variables) and types. For these cases
16913 -- all we need to do is to set the Linker_Section_pragma field,
16914 -- checking that we do not have a duplicate.
16916 when E_Constant | E_Variable | Type_Kind
=>
16917 LPE
:= Linker_Section_Pragma
(Ent
);
16919 if Present
(LPE
) then
16920 Error_Msg_Sloc
:= Sloc
(LPE
);
16922 ("Linker_Section already specified for &#", Arg1
, Ent
);
16925 Set_Linker_Section_Pragma
(Ent
, N
);
16927 -- A pragma that applies to a Ghost entity becomes Ghost for
16928 -- the purposes of legality checks and removal of ignored
16931 Mark_Pragma_As_Ghost
(N
, Ent
);
16935 when Subprogram_Kind
=>
16937 -- Aspect case, entity already set
16939 if From_Aspect_Specification
(N
) then
16940 Set_Linker_Section_Pragma
16941 (Entity
(Corresponding_Aspect
(N
)), N
);
16943 -- Pragma case, we must climb the homonym chain, but skip
16944 -- any for which the linker section is already set.
16948 if No
(Linker_Section_Pragma
(Ent
)) then
16949 Set_Linker_Section_Pragma
(Ent
, N
);
16951 -- A pragma that applies to a Ghost entity becomes
16952 -- Ghost for the purposes of legality checks and
16953 -- removal of ignored Ghost code.
16955 Mark_Pragma_As_Ghost
(N
, Ent
);
16957 -- Capture the entity of the first Ghost subprogram
16958 -- being processed for error detection purposes.
16960 if Is_Ghost_Entity
(Ent
) then
16961 if No
(Ghost_Id
) then
16965 -- Otherwise the subprogram is non-Ghost. It is
16966 -- illegal to mix references to Ghost and non-Ghost
16967 -- entities (SPARK RM 6.9).
16969 elsif Present
(Ghost_Id
)
16970 and then not Ghost_Error_Posted
16972 Ghost_Error_Posted
:= True;
16974 Error_Msg_Name_1
:= Pname
;
16976 ("pragma % cannot mention ghost and "
16977 & "non-ghost subprograms", N
);
16979 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
16981 ("\& # declared as ghost", N
, Ghost_Id
);
16983 Error_Msg_Sloc
:= Sloc
(Ent
);
16985 ("\& # declared as non-ghost", N
, Ent
);
16989 Ent
:= Homonym
(Ent
);
16991 or else Scope
(Ent
) /= Current_Scope
;
16995 -- All other cases are illegal
16999 ("pragma% applies only to objects, subprograms, and types",
17002 end Linker_Section
;
17008 -- pragma List (On | Off)
17010 -- There is nothing to do here, since we did all the processing for
17011 -- this pragma in Par.Prag (so that it works properly even in syntax
17014 when Pragma_List
=>
17021 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17023 when Pragma_Lock_Free
=> Lock_Free
: declare
17024 P
: constant Node_Id
:= Parent
(N
);
17030 Check_No_Identifiers
;
17031 Check_At_Most_N_Arguments
(1);
17033 -- Protected definition case
17035 if Nkind
(P
) = N_Protected_Definition
then
17036 Ent
:= Defining_Identifier
(Parent
(P
));
17040 if Arg_Count
= 1 then
17041 Arg
:= Get_Pragma_Arg
(Arg1
);
17042 Val
:= Is_True
(Static_Boolean
(Arg
));
17044 -- No arguments (expression is considered to be True)
17050 -- Check duplicate pragma before we chain the pragma in the Rep
17051 -- Item chain of Ent.
17053 Check_Duplicate_Pragma
(Ent
);
17054 Record_Rep_Item
(Ent
, N
);
17055 Set_Uses_Lock_Free
(Ent
, Val
);
17057 -- Anything else is incorrect placement
17064 --------------------
17065 -- Locking_Policy --
17066 --------------------
17068 -- pragma Locking_Policy (policy_IDENTIFIER);
17070 when Pragma_Locking_Policy
=> declare
17071 subtype LP_Range
is Name_Id
17072 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
17077 Check_Ada_83_Warning
;
17078 Check_Arg_Count
(1);
17079 Check_No_Identifiers
;
17080 Check_Arg_Is_Locking_Policy
(Arg1
);
17081 Check_Valid_Configuration_Pragma
;
17082 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17085 when Name_Ceiling_Locking
=>
17087 when Name_Inheritance_Locking
=>
17089 when Name_Concurrent_Readers_Locking
=>
17093 if Locking_Policy
/= ' '
17094 and then Locking_Policy
/= LP
17096 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17097 Error_Pragma
("locking policy incompatible with policy#");
17099 -- Set new policy, but always preserve System_Location since we
17100 -- like the error message with the run time name.
17103 Locking_Policy
:= LP
;
17105 if Locking_Policy_Sloc
/= System_Location
then
17106 Locking_Policy_Sloc
:= Loc
;
17111 -------------------
17112 -- Loop_Optimize --
17113 -------------------
17115 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17117 -- OPTIMIZATION_HINT ::=
17118 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17120 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
17125 Check_At_Least_N_Arguments
(1);
17126 Check_No_Identifiers
;
17128 Hint
:= First
(Pragma_Argument_Associations
(N
));
17129 while Present
(Hint
) loop
17130 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
17138 Check_Loop_Pragma_Placement
;
17145 -- pragma Loop_Variant
17146 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17148 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17150 -- CHANGE_DIRECTION ::= Increases | Decreases
17152 when Pragma_Loop_Variant
=> Loop_Variant
: declare
17157 Check_At_Least_N_Arguments
(1);
17158 Check_Loop_Pragma_Placement
;
17160 -- Process all increasing / decreasing expressions
17162 Variant
:= First
(Pragma_Argument_Associations
(N
));
17163 while Present
(Variant
) loop
17164 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
17167 Error_Pragma_Arg
("wrong change modifier", Variant
);
17170 Preanalyze_Assert_Expression
17171 (Expression
(Variant
), Any_Discrete
);
17177 -----------------------
17178 -- Machine_Attribute --
17179 -----------------------
17181 -- pragma Machine_Attribute (
17182 -- [Entity =>] LOCAL_NAME,
17183 -- [Attribute_Name =>] static_string_EXPRESSION
17184 -- [, [Info =>] static_EXPRESSION] );
17186 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
17187 Def_Id
: Entity_Id
;
17191 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
17193 if Arg_Count
= 3 then
17194 Check_Optional_Identifier
(Arg3
, Name_Info
);
17195 Check_Arg_Is_OK_Static_Expression
(Arg3
);
17197 Check_Arg_Count
(2);
17200 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17201 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
17202 Check_Arg_Is_Local_Name
(Arg1
);
17203 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17204 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17206 if Is_Access_Type
(Def_Id
) then
17207 Def_Id
:= Designated_Type
(Def_Id
);
17210 if Rep_Item_Too_Early
(Def_Id
, N
) then
17214 Def_Id
:= Underlying_Type
(Def_Id
);
17216 -- The only processing required is to link this item on to the
17217 -- list of rep items for the given entity. This is accomplished
17218 -- by the call to Rep_Item_Too_Late (when no error is detected
17219 -- and False is returned).
17221 if Rep_Item_Too_Late
(Def_Id
, N
) then
17224 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17226 end Machine_Attribute
;
17233 -- (MAIN_OPTION [, MAIN_OPTION]);
17236 -- [STACK_SIZE =>] static_integer_EXPRESSION
17237 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17238 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17240 when Pragma_Main
=> Main
: declare
17241 Args
: Args_List
(1 .. 3);
17242 Names
: constant Name_List
(1 .. 3) := (
17244 Name_Task_Stack_Size_Default
,
17245 Name_Time_Slicing_Enabled
);
17251 Gather_Associations
(Names
, Args
);
17253 for J
in 1 .. 2 loop
17254 if Present
(Args
(J
)) then
17255 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17259 if Present
(Args
(3)) then
17260 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
17264 while Present
(Nod
) loop
17265 if Nkind
(Nod
) = N_Pragma
17266 and then Pragma_Name
(Nod
) = Name_Main
17268 Error_Msg_Name_1
:= Pname
;
17269 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17280 -- pragma Main_Storage
17281 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17283 -- MAIN_STORAGE_OPTION ::=
17284 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17285 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17287 when Pragma_Main_Storage
=> Main_Storage
: declare
17288 Args
: Args_List
(1 .. 2);
17289 Names
: constant Name_List
(1 .. 2) := (
17290 Name_Working_Storage
,
17297 Gather_Associations
(Names
, Args
);
17299 for J
in 1 .. 2 loop
17300 if Present
(Args
(J
)) then
17301 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17305 Check_In_Main_Program
;
17308 while Present
(Nod
) loop
17309 if Nkind
(Nod
) = N_Pragma
17310 and then Pragma_Name
(Nod
) = Name_Main_Storage
17312 Error_Msg_Name_1
:= Pname
;
17313 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17324 -- pragma Memory_Size (NUMERIC_LITERAL)
17326 when Pragma_Memory_Size
=>
17329 -- Memory size is simply ignored
17331 Check_No_Identifiers
;
17332 Check_Arg_Count
(1);
17333 Check_Arg_Is_Integer_Literal
(Arg1
);
17341 -- The only correct use of this pragma is on its own in a file, in
17342 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17343 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17344 -- check for a file containing nothing but a No_Body pragma). If we
17345 -- attempt to process it during normal semantics processing, it means
17346 -- it was misplaced.
17348 when Pragma_No_Body
=>
17352 -----------------------------
17353 -- No_Elaboration_Code_All --
17354 -----------------------------
17356 -- pragma No_Elaboration_Code_All;
17358 when Pragma_No_Elaboration_Code_All
=>
17360 Check_Valid_Library_Unit_Pragma
;
17362 if Nkind
(N
) = N_Null_Statement
then
17366 -- Must appear for a spec or generic spec
17368 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
17369 N_Generic_Package_Declaration
,
17370 N_Generic_Subprogram_Declaration
,
17371 N_Package_Declaration
,
17372 N_Subprogram_Declaration
)
17376 ("pragma% can only occur for package "
17377 & "or subprogram spec"));
17380 -- Set flag in unit table
17382 Set_No_Elab_Code_All
(Current_Sem_Unit
);
17384 -- Set restriction No_Elaboration_Code if this is the main unit
17386 if Current_Sem_Unit
= Main_Unit
then
17387 Set_Restriction
(No_Elaboration_Code
, N
);
17390 -- If we are in the main unit or in an extended main source unit,
17391 -- then we also add it to the configuration restrictions so that
17392 -- it will apply to all units in the extended main source.
17394 if Current_Sem_Unit
= Main_Unit
17395 or else In_Extended_Main_Source_Unit
(N
)
17397 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
17400 -- If in main extended unit, activate transitive with test
17402 if In_Extended_Main_Source_Unit
(N
) then
17403 Opt
.No_Elab_Code_All_Pragma
:= N
;
17410 -- pragma No_Inline ( NAME {, NAME} );
17412 when Pragma_No_Inline
=>
17414 Process_Inline
(Suppressed
);
17420 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17422 when Pragma_No_Return
=> No_Return
: declare
17428 Ghost_Error_Posted
: Boolean := False;
17429 -- Flag set when an error concerning the illegal mix of Ghost and
17430 -- non-Ghost subprograms is emitted.
17432 Ghost_Id
: Entity_Id
:= Empty
;
17433 -- The entity of the first Ghost procedure encountered while
17434 -- processing the arguments of the pragma.
17438 Check_At_Least_N_Arguments
(1);
17440 -- Loop through arguments of pragma
17443 while Present
(Arg
) loop
17444 Check_Arg_Is_Local_Name
(Arg
);
17445 Id
:= Get_Pragma_Arg
(Arg
);
17448 if not Is_Entity_Name
(Id
) then
17449 Error_Pragma_Arg
("entity name required", Arg
);
17452 if Etype
(Id
) = Any_Type
then
17456 -- Loop to find matching procedures
17462 and then Scope
(E
) = Current_Scope
17464 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
17467 -- A pragma that applies to a Ghost entity becomes Ghost
17468 -- for the purposes of legality checks and removal of
17469 -- ignored Ghost code.
17471 Mark_Pragma_As_Ghost
(N
, E
);
17473 -- Capture the entity of the first Ghost procedure being
17474 -- processed for error detection purposes.
17476 if Is_Ghost_Entity
(E
) then
17477 if No
(Ghost_Id
) then
17481 -- Otherwise the subprogram is non-Ghost. It is illegal
17482 -- to mix references to Ghost and non-Ghost entities
17485 elsif Present
(Ghost_Id
)
17486 and then not Ghost_Error_Posted
17488 Ghost_Error_Posted
:= True;
17490 Error_Msg_Name_1
:= Pname
;
17492 ("pragma % cannot mention ghost and non-ghost "
17493 & "procedures", N
);
17495 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17496 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
17498 Error_Msg_Sloc
:= Sloc
(E
);
17499 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
17502 -- Set flag on any alias as well
17504 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
17505 Set_No_Return
(Alias
(E
));
17511 exit when From_Aspect_Specification
(N
);
17515 -- If entity in not in current scope it may be the enclosing
17516 -- suprogram body to which the aspect applies.
17519 if Entity
(Id
) = Current_Scope
17520 and then From_Aspect_Specification
(N
)
17522 Set_No_Return
(Entity
(Id
));
17524 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
17536 -- pragma No_Run_Time;
17538 -- Note: this pragma is retained for backwards compatibility. See
17539 -- body of Rtsfind for full details on its handling.
17541 when Pragma_No_Run_Time
=>
17543 Check_Valid_Configuration_Pragma
;
17544 Check_Arg_Count
(0);
17546 No_Run_Time_Mode
:= True;
17547 Configurable_Run_Time_Mode
:= True;
17549 -- Set Duration to 32 bits if word size is 32
17551 if Ttypes
.System_Word_Size
= 32 then
17552 Duration_32_Bits_On_Target
:= True;
17555 -- Set appropriate restrictions
17557 Set_Restriction
(No_Finalization
, N
);
17558 Set_Restriction
(No_Exception_Handlers
, N
);
17559 Set_Restriction
(Max_Tasks
, N
, 0);
17560 Set_Restriction
(No_Tasking
, N
);
17562 -----------------------
17563 -- No_Tagged_Streams --
17564 -----------------------
17566 -- pragma No_Tagged_Streams;
17567 -- pragma No_Tagged_Streams ([Entity => ]tagged_type_local_NAME);
17569 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
17575 Check_At_Most_N_Arguments
(1);
17577 -- One argument case
17579 if Arg_Count
= 1 then
17580 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17581 Check_Arg_Is_Local_Name
(Arg1
);
17582 E_Id
:= Get_Pragma_Arg
(Arg1
);
17584 if Etype
(E_Id
) = Any_Type
then
17588 E
:= Entity
(E_Id
);
17590 Check_Duplicate_Pragma
(E
);
17592 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
17594 ("argument for pragma% must be root tagged type", Arg1
);
17597 if Rep_Item_Too_Early
(E
, N
)
17599 Rep_Item_Too_Late
(E
, N
)
17603 Set_No_Tagged_Streams_Pragma
(E
, N
);
17606 -- Zero argument case
17609 Check_Is_In_Decl_Part_Or_Package_Spec
;
17610 No_Tagged_Streams
:= N
;
17612 end No_Tagged_Strms
;
17614 ------------------------
17615 -- No_Strict_Aliasing --
17616 ------------------------
17618 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17620 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
17625 Check_At_Most_N_Arguments
(1);
17627 if Arg_Count
= 0 then
17628 Check_Valid_Configuration_Pragma
;
17629 Opt
.No_Strict_Aliasing
:= True;
17632 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17633 Check_Arg_Is_Local_Name
(Arg1
);
17634 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17636 if E_Id
= Any_Type
then
17638 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17639 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17642 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17644 end No_Strict_Aliasing
;
17646 -----------------------
17647 -- Normalize_Scalars --
17648 -----------------------
17650 -- pragma Normalize_Scalars;
17652 when Pragma_Normalize_Scalars
=>
17653 Check_Ada_83_Warning
;
17654 Check_Arg_Count
(0);
17655 Check_Valid_Configuration_Pragma
;
17657 -- Normalize_Scalars creates false positives in CodePeer, and
17658 -- incorrect negative results in GNATprove mode, so ignore this
17659 -- pragma in these modes.
17661 if not (CodePeer_Mode
or GNATprove_Mode
) then
17662 Normalize_Scalars
:= True;
17663 Init_Or_Norm_Scalars
:= True;
17670 -- pragma Obsolescent;
17672 -- pragma Obsolescent (
17673 -- [Message =>] static_string_EXPRESSION
17674 -- [,[Version =>] Ada_05]]);
17676 -- pragma Obsolescent (
17677 -- [Entity =>] NAME
17678 -- [,[Message =>] static_string_EXPRESSION
17679 -- [,[Version =>] Ada_05]] );
17681 when Pragma_Obsolescent
=> Obsolescent
: declare
17685 procedure Set_Obsolescent
(E
: Entity_Id
);
17686 -- Given an entity Ent, mark it as obsolescent if appropriate
17688 ---------------------
17689 -- Set_Obsolescent --
17690 ---------------------
17692 procedure Set_Obsolescent
(E
: Entity_Id
) is
17701 -- A pragma that applies to a Ghost entity becomes Ghost for
17702 -- the purposes of legality checks and removal of ignored Ghost
17705 Mark_Pragma_As_Ghost
(N
, E
);
17707 -- Entity name was given
17709 if Present
(Ename
) then
17711 -- If entity name matches, we are fine. Save entity in
17712 -- pragma argument, for ASIS use.
17714 if Chars
(Ename
) = Chars
(Ent
) then
17715 Set_Entity
(Ename
, Ent
);
17716 Generate_Reference
(Ent
, Ename
);
17718 -- If entity name does not match, only possibility is an
17719 -- enumeration literal from an enumeration type declaration.
17721 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
17723 ("pragma % entity name does not match declaration");
17726 Ent
:= First_Literal
(E
);
17730 ("pragma % entity name does not match any "
17731 & "enumeration literal");
17733 elsif Chars
(Ent
) = Chars
(Ename
) then
17734 Set_Entity
(Ename
, Ent
);
17735 Generate_Reference
(Ent
, Ename
);
17739 Ent
:= Next_Literal
(Ent
);
17745 -- Ent points to entity to be marked
17747 if Arg_Count
>= 1 then
17749 -- Deal with static string argument
17751 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17752 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
17754 for J
in 1 .. String_Length
(S
) loop
17755 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
17757 ("pragma% argument does not allow wide characters",
17762 Obsolescent_Warnings
.Append
17763 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
17765 -- Check for Ada_05 parameter
17767 if Arg_Count
/= 1 then
17768 Check_Arg_Count
(2);
17771 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
17774 Check_Arg_Is_Identifier
(Argx
);
17776 if Chars
(Argx
) /= Name_Ada_05
then
17777 Error_Msg_Name_2
:= Name_Ada_05
;
17779 ("only allowed argument for pragma% is %", Argx
);
17782 if Ada_Version_Explicit
< Ada_2005
17783 or else not Warn_On_Ada_2005_Compatibility
17791 -- Set flag if pragma active
17794 Set_Is_Obsolescent
(Ent
);
17798 end Set_Obsolescent
;
17800 -- Start of processing for pragma Obsolescent
17805 Check_At_Most_N_Arguments
(3);
17807 -- See if first argument specifies an entity name
17811 (Chars
(Arg1
) = Name_Entity
17813 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
17815 N_Operator_Symbol
))
17817 Ename
:= Get_Pragma_Arg
(Arg1
);
17819 -- Eliminate first argument, so we can share processing
17823 Arg_Count
:= Arg_Count
- 1;
17825 -- No Entity name argument given
17831 if Arg_Count
>= 1 then
17832 Check_Optional_Identifier
(Arg1
, Name_Message
);
17834 if Arg_Count
= 2 then
17835 Check_Optional_Identifier
(Arg2
, Name_Version
);
17839 -- Get immediately preceding declaration
17842 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
17846 -- Cases where we do not follow anything other than another pragma
17850 -- First case: library level compilation unit declaration with
17851 -- the pragma immediately following the declaration.
17853 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
17855 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
17858 -- Case 2: library unit placement for package
17862 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
17864 if Is_Package_Or_Generic_Package
(Ent
) then
17865 Set_Obsolescent
(Ent
);
17871 -- Cases where we must follow a declaration, including an
17872 -- abstract subprogram declaration, which is not in the
17873 -- other node subtypes.
17876 if Nkind
(Decl
) not in N_Declaration
17877 and then Nkind
(Decl
) not in N_Later_Decl_Item
17878 and then Nkind
(Decl
) not in N_Generic_Declaration
17879 and then Nkind
(Decl
) not in N_Renaming_Declaration
17880 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
17883 ("pragma% misplaced, "
17884 & "must immediately follow a declaration");
17887 Set_Obsolescent
(Defining_Entity
(Decl
));
17897 -- pragma Optimize (Time | Space | Off);
17899 -- The actual check for optimize is done in Gigi. Note that this
17900 -- pragma does not actually change the optimization setting, it
17901 -- simply checks that it is consistent with the pragma.
17903 when Pragma_Optimize
=>
17904 Check_No_Identifiers
;
17905 Check_Arg_Count
(1);
17906 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
17908 ------------------------
17909 -- Optimize_Alignment --
17910 ------------------------
17912 -- pragma Optimize_Alignment (Time | Space | Off);
17914 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
17916 Check_No_Identifiers
;
17917 Check_Arg_Count
(1);
17918 Check_Valid_Configuration_Pragma
;
17921 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
17925 Opt
.Optimize_Alignment
:= 'T';
17927 Opt
.Optimize_Alignment
:= 'S';
17929 Opt
.Optimize_Alignment
:= 'O';
17931 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
17935 -- Set indication that mode is set locally. If we are in fact in a
17936 -- configuration pragma file, this setting is harmless since the
17937 -- switch will get reset anyway at the start of each unit.
17939 Optimize_Alignment_Local
:= True;
17940 end Optimize_Alignment
;
17946 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
17948 when Pragma_Ordered
=> Ordered
: declare
17949 Assoc
: constant Node_Id
:= Arg1
;
17955 Check_No_Identifiers
;
17956 Check_Arg_Count
(1);
17957 Check_Arg_Is_Local_Name
(Arg1
);
17959 Type_Id
:= Get_Pragma_Arg
(Assoc
);
17960 Find_Type
(Type_Id
);
17961 Typ
:= Entity
(Type_Id
);
17963 if Typ
= Any_Type
then
17966 Typ
:= Underlying_Type
(Typ
);
17969 if not Is_Enumeration_Type
(Typ
) then
17970 Error_Pragma
("pragma% must specify enumeration type");
17973 Check_First_Subtype
(Arg1
);
17974 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
17977 -------------------
17978 -- Overflow_Mode --
17979 -------------------
17981 -- pragma Overflow_Mode
17982 -- ([General => ] MODE [, [Assertions => ] MODE]);
17984 -- MODE := STRICT | MINIMIZED | ELIMINATED
17986 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
17987 -- since System.Bignums makes this assumption. This is true of nearly
17988 -- all (all?) targets.
17990 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
17991 function Get_Overflow_Mode
17993 Arg
: Node_Id
) return Overflow_Mode_Type
;
17994 -- Function to process one pragma argument, Arg. If an identifier
17995 -- is present, it must be Name. Mode type is returned if a valid
17996 -- argument exists, otherwise an error is signalled.
17998 -----------------------
17999 -- Get_Overflow_Mode --
18000 -----------------------
18002 function Get_Overflow_Mode
18004 Arg
: Node_Id
) return Overflow_Mode_Type
18006 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
18009 Check_Optional_Identifier
(Arg
, Name
);
18010 Check_Arg_Is_Identifier
(Argx
);
18012 if Chars
(Argx
) = Name_Strict
then
18015 elsif Chars
(Argx
) = Name_Minimized
then
18018 elsif Chars
(Argx
) = Name_Eliminated
then
18019 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
18021 ("Eliminated not implemented on this target", Argx
);
18027 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
18029 end Get_Overflow_Mode
;
18031 -- Start of processing for Overflow_Mode
18035 Check_At_Least_N_Arguments
(1);
18036 Check_At_Most_N_Arguments
(2);
18038 -- Process first argument
18040 Scope_Suppress
.Overflow_Mode_General
:=
18041 Get_Overflow_Mode
(Name_General
, Arg1
);
18043 -- Case of only one argument
18045 if Arg_Count
= 1 then
18046 Scope_Suppress
.Overflow_Mode_Assertions
:=
18047 Scope_Suppress
.Overflow_Mode_General
;
18049 -- Case of two arguments present
18052 Scope_Suppress
.Overflow_Mode_Assertions
:=
18053 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
18057 --------------------------
18058 -- Overriding Renamings --
18059 --------------------------
18061 -- pragma Overriding_Renamings;
18063 when Pragma_Overriding_Renamings
=>
18065 Check_Arg_Count
(0);
18066 Check_Valid_Configuration_Pragma
;
18067 Overriding_Renamings
:= True;
18073 -- pragma Pack (first_subtype_LOCAL_NAME);
18075 when Pragma_Pack
=> Pack
: declare
18076 Assoc
: constant Node_Id
:= Arg1
;
18078 Ignore
: Boolean := False;
18083 Check_No_Identifiers
;
18084 Check_Arg_Count
(1);
18085 Check_Arg_Is_Local_Name
(Arg1
);
18086 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18088 if not Is_Entity_Name
(Type_Id
)
18089 or else not Is_Type
(Entity
(Type_Id
))
18092 ("argument for pragma% must be type or subtype", Arg1
);
18095 Find_Type
(Type_Id
);
18096 Typ
:= Entity
(Type_Id
);
18099 or else Rep_Item_Too_Early
(Typ
, N
)
18103 Typ
:= Underlying_Type
(Typ
);
18106 -- A pragma that applies to a Ghost entity becomes Ghost for the
18107 -- purposes of legality checks and removal of ignored Ghost code.
18109 Mark_Pragma_As_Ghost
(N
, Typ
);
18111 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
18112 Error_Pragma
("pragma% must specify array or record type");
18115 Check_First_Subtype
(Arg1
);
18116 Check_Duplicate_Pragma
(Typ
);
18120 if Is_Array_Type
(Typ
) then
18121 Ctyp
:= Component_Type
(Typ
);
18123 -- Ignore pack that does nothing
18125 if Known_Static_Esize
(Ctyp
)
18126 and then Known_Static_RM_Size
(Ctyp
)
18127 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
18128 and then Addressable
(Esize
(Ctyp
))
18133 -- Process OK pragma Pack. Note that if there is a separate
18134 -- component clause present, the Pack will be cancelled. This
18135 -- processing is in Freeze.
18137 if not Rep_Item_Too_Late
(Typ
, N
) then
18139 -- In CodePeer mode, we do not need complex front-end
18140 -- expansions related to pragma Pack, so disable handling
18143 if CodePeer_Mode
then
18146 -- Normal case where we do the pack action
18150 Set_Is_Packed
(Base_Type
(Typ
));
18151 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18154 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18158 -- For record types, the pack is always effective
18160 else pragma Assert
(Is_Record_Type
(Typ
));
18161 if not Rep_Item_Too_Late
(Typ
, N
) then
18162 Set_Is_Packed
(Base_Type
(Typ
));
18163 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18164 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18175 -- There is nothing to do here, since we did all the processing for
18176 -- this pragma in Par.Prag (so that it works properly even in syntax
18179 when Pragma_Page
=>
18186 -- pragma Part_Of (ABSTRACT_STATE);
18188 -- ABSTRACT_STATE ::= NAME
18190 when Pragma_Part_Of
=> Part_Of
: declare
18191 procedure Propagate_Part_Of
18192 (Pack_Id
: Entity_Id
;
18193 State_Id
: Entity_Id
;
18194 Instance
: Node_Id
);
18195 -- Propagate the Part_Of indicator to all abstract states and
18196 -- objects declared in the visible state space of a package
18197 -- denoted by Pack_Id. State_Id is the encapsulating state.
18198 -- Instance is the package instantiation node.
18200 -----------------------
18201 -- Propagate_Part_Of --
18202 -----------------------
18204 procedure Propagate_Part_Of
18205 (Pack_Id
: Entity_Id
;
18206 State_Id
: Entity_Id
;
18207 Instance
: Node_Id
)
18209 Has_Item
: Boolean := False;
18210 -- Flag set when the visible state space contains at least one
18211 -- abstract state or variable.
18213 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
18214 -- Propagate the Part_Of indicator to all abstract states and
18215 -- objects declared in the visible state space of a package
18216 -- denoted by Pack_Id.
18218 -----------------------
18219 -- Propagate_Part_Of --
18220 -----------------------
18222 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
18223 Constits
: Elist_Id
;
18224 Item_Id
: Entity_Id
;
18227 -- Traverse the entity chain of the package and set relevant
18228 -- attributes of abstract states and objects declared in the
18229 -- visible state space of the package.
18231 Item_Id
:= First_Entity
(Pack_Id
);
18232 while Present
(Item_Id
)
18233 and then not In_Private_Part
(Item_Id
)
18235 -- Do not consider internally generated items
18237 if not Comes_From_Source
(Item_Id
) then
18240 -- The Part_Of indicator turns an abstract state or an
18241 -- object into a constituent of the encapsulating state.
18243 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
18248 Constits
:= Part_Of_Constituents
(State_Id
);
18250 if No
(Constits
) then
18251 Constits
:= New_Elmt_List
;
18252 Set_Part_Of_Constituents
(State_Id
, Constits
);
18255 Append_Elmt
(Item_Id
, Constits
);
18256 Set_Encapsulating_State
(Item_Id
, State_Id
);
18258 -- Recursively handle nested packages and instantiations
18260 elsif Ekind
(Item_Id
) = E_Package
then
18261 Propagate_Part_Of
(Item_Id
);
18264 Next_Entity
(Item_Id
);
18266 end Propagate_Part_Of
;
18268 -- Start of processing for Propagate_Part_Of
18271 Propagate_Part_Of
(Pack_Id
);
18273 -- Detect a package instantiation that is subject to a Part_Of
18274 -- indicator, but has no visible state.
18276 if not Has_Item
then
18278 ("package instantiation & has Part_Of indicator but "
18279 & "lacks visible state", Instance
, Pack_Id
);
18281 end Propagate_Part_Of
;
18285 Constits
: Elist_Id
;
18287 Encap_Id
: Entity_Id
;
18288 Item_Id
: Entity_Id
;
18292 -- Start of processing for Part_Of
18296 Check_No_Identifiers
;
18297 Check_Arg_Count
(1);
18299 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
18301 -- Object declaration
18303 if Nkind
(Stmt
) = N_Object_Declaration
then
18306 -- Package instantiation
18308 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
18311 -- Single concurrent type declaration
18313 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
18316 -- Otherwise the pragma is associated with an illegal construct
18323 -- Extract the entity of the related object declaration or package
18324 -- instantiation. In the case of the instantiation, use the entity
18325 -- of the instance spec.
18327 if Nkind
(Stmt
) = N_Package_Instantiation
then
18328 Stmt
:= Instance_Spec
(Stmt
);
18331 Item_Id
:= Defining_Entity
(Stmt
);
18332 Encap
:= Get_Pragma_Arg
(Arg1
);
18334 -- A pragma that applies to a Ghost entity becomes Ghost for the
18335 -- purposes of legality checks and removal of ignored Ghost code.
18337 Mark_Pragma_As_Ghost
(N
, Item_Id
);
18339 -- Chain the pragma on the contract for further processing by
18340 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18342 Add_Contract_Item
(N
, Item_Id
);
18344 -- A variable may act as consituent of a single concurrent type
18345 -- which in turn could be declared after the variable. Due to this
18346 -- discrepancy, the full analysis of indicator Part_Of is delayed
18347 -- until the end of the enclosing declarative region (see routine
18348 -- Analyze_Part_Of_In_Decl_Part).
18350 if Ekind
(Item_Id
) = E_Variable
then
18353 -- Otherwise indicator Part_Of applies to a constant or a package
18357 -- Detect any discrepancies between the placement of the
18358 -- constant or package instantiation with respect to state
18359 -- space and the encapsulating state.
18363 Item_Id
=> Item_Id
,
18365 Encap_Id
=> Encap_Id
,
18369 pragma Assert
(Present
(Encap_Id
));
18371 if Ekind
(Item_Id
) = E_Constant
then
18372 Constits
:= Part_Of_Constituents
(Encap_Id
);
18374 if No
(Constits
) then
18375 Constits
:= New_Elmt_List
;
18376 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
18379 Append_Elmt
(Item_Id
, Constits
);
18380 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
18382 -- Propagate the Part_Of indicator to the visible state
18383 -- space of the package instantiation.
18387 (Pack_Id
=> Item_Id
,
18388 State_Id
=> Encap_Id
,
18395 ----------------------------------
18396 -- Partition_Elaboration_Policy --
18397 ----------------------------------
18399 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18401 when Pragma_Partition_Elaboration_Policy
=> declare
18402 subtype PEP_Range
is Name_Id
18403 range First_Partition_Elaboration_Policy_Name
18404 .. Last_Partition_Elaboration_Policy_Name
;
18405 PEP_Val
: PEP_Range
;
18410 Check_Arg_Count
(1);
18411 Check_No_Identifiers
;
18412 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
18413 Check_Valid_Configuration_Pragma
;
18414 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18417 when Name_Concurrent
=>
18419 when Name_Sequential
=>
18423 if Partition_Elaboration_Policy
/= ' '
18424 and then Partition_Elaboration_Policy
/= PEP
18426 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
18428 ("partition elaboration policy incompatible with policy#");
18430 -- Set new policy, but always preserve System_Location since we
18431 -- like the error message with the run time name.
18434 Partition_Elaboration_Policy
:= PEP
;
18436 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
18437 Partition_Elaboration_Policy_Sloc
:= Loc
;
18446 -- pragma Passive [(PASSIVE_FORM)];
18448 -- PASSIVE_FORM ::= Semaphore | No
18450 when Pragma_Passive
=>
18453 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
18454 Error_Pragma
("pragma% must be within task definition");
18457 if Arg_Count
/= 0 then
18458 Check_Arg_Count
(1);
18459 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
18462 ----------------------------------
18463 -- Preelaborable_Initialization --
18464 ----------------------------------
18466 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18468 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
18473 Check_Arg_Count
(1);
18474 Check_No_Identifiers
;
18475 Check_Arg_Is_Identifier
(Arg1
);
18476 Check_Arg_Is_Local_Name
(Arg1
);
18477 Check_First_Subtype
(Arg1
);
18478 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18480 -- A pragma that applies to a Ghost entity becomes Ghost for the
18481 -- purposes of legality checks and removal of ignored Ghost code.
18483 Mark_Pragma_As_Ghost
(N
, Ent
);
18485 -- The pragma may come from an aspect on a private declaration,
18486 -- even if the freeze point at which this is analyzed in the
18487 -- private part after the full view.
18489 if Has_Private_Declaration
(Ent
)
18490 and then From_Aspect_Specification
(N
)
18494 -- Check appropriate type argument
18496 elsif Is_Private_Type
(Ent
)
18497 or else Is_Protected_Type
(Ent
)
18498 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
18500 -- AI05-0028: The pragma applies to all composite types. Note
18501 -- that we apply this binding interpretation to earlier versions
18502 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18503 -- choice since there are other compilers that do the same.
18505 or else Is_Composite_Type
(Ent
)
18511 ("pragma % can only be applied to private, formal derived, "
18512 & "protected, or composite type", Arg1
);
18515 -- Give an error if the pragma is applied to a protected type that
18516 -- does not qualify (due to having entries, or due to components
18517 -- that do not qualify).
18519 if Is_Protected_Type
(Ent
)
18520 and then not Has_Preelaborable_Initialization
(Ent
)
18523 ("protected type & does not have preelaborable "
18524 & "initialization", Ent
);
18526 -- Otherwise mark the type as definitely having preelaborable
18530 Set_Known_To_Have_Preelab_Init
(Ent
);
18533 if Has_Pragma_Preelab_Init
(Ent
)
18534 and then Warn_On_Redundant_Constructs
18536 Error_Pragma
("?r?duplicate pragma%!");
18538 Set_Has_Pragma_Preelab_Init
(Ent
);
18542 --------------------
18543 -- Persistent_BSS --
18544 --------------------
18546 -- pragma Persistent_BSS [(object_NAME)];
18548 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
18555 Check_At_Most_N_Arguments
(1);
18557 -- Case of application to specific object (one argument)
18559 if Arg_Count
= 1 then
18560 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18562 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
18564 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
18567 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
18570 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18571 Decl
:= Parent
(Ent
);
18573 -- A pragma that applies to a Ghost entity becomes Ghost for
18574 -- the purposes of legality checks and removal of ignored Ghost
18577 Mark_Pragma_As_Ghost
(N
, Ent
);
18579 -- Check for duplication before inserting in list of
18580 -- representation items.
18582 Check_Duplicate_Pragma
(Ent
);
18584 if Rep_Item_Too_Late
(Ent
, N
) then
18588 if Present
(Expression
(Decl
)) then
18590 ("object for pragma% cannot have initialization", Arg1
);
18593 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
18595 ("object type for pragma% is not potentially persistent",
18600 Make_Linker_Section_Pragma
18601 (Ent
, Sloc
(N
), ".persistent.bss");
18602 Insert_After
(N
, Prag
);
18605 -- Case of use as configuration pragma with no arguments
18608 Check_Valid_Configuration_Pragma
;
18609 Persistent_BSS_Mode
:= True;
18611 end Persistent_BSS
;
18617 -- pragma Polling (ON | OFF);
18619 when Pragma_Polling
=>
18621 Check_Arg_Count
(1);
18622 Check_No_Identifiers
;
18623 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
18624 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
18626 -----------------------------------
18627 -- Post/Post_Class/Postcondition --
18628 -----------------------------------
18630 -- pragma Post (Boolean_EXPRESSION);
18631 -- pragma Post_Class (Boolean_EXPRESSION);
18632 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18633 -- [,[Message =>] String_EXPRESSION]);
18635 -- Characteristics:
18637 -- * Analysis - The annotation undergoes initial checks to verify
18638 -- the legal placement and context. Secondary checks preanalyze the
18641 -- Analyze_Pre_Post_Condition_In_Decl_Part
18643 -- * Expansion - The annotation is expanded during the expansion of
18644 -- the related subprogram [body] contract as performed in:
18646 -- Expand_Subprogram_Contract
18648 -- * Template - The annotation utilizes the generic template of the
18649 -- related subprogram [body] when it is:
18651 -- aspect on subprogram declaration
18652 -- aspect on stand alone subprogram body
18653 -- pragma on stand alone subprogram body
18655 -- The annotation must prepare its own template when it is:
18657 -- pragma on subprogram declaration
18659 -- * Globals - Capture of global references must occur after full
18662 -- * Instance - The annotation is instantiated automatically when
18663 -- the related generic subprogram [body] is instantiated except for
18664 -- the "pragma on subprogram declaration" case. In that scenario
18665 -- the annotation must instantiate itself.
18668 Pragma_Post_Class |
18669 Pragma_Postcondition
=>
18670 Analyze_Pre_Post_Condition
;
18672 --------------------------------
18673 -- Pre/Pre_Class/Precondition --
18674 --------------------------------
18676 -- pragma Pre (Boolean_EXPRESSION);
18677 -- pragma Pre_Class (Boolean_EXPRESSION);
18678 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
18679 -- [,[Message =>] String_EXPRESSION]);
18681 -- Characteristics:
18683 -- * Analysis - The annotation undergoes initial checks to verify
18684 -- the legal placement and context. Secondary checks preanalyze the
18687 -- Analyze_Pre_Post_Condition_In_Decl_Part
18689 -- * Expansion - The annotation is expanded during the expansion of
18690 -- the related subprogram [body] contract as performed in:
18692 -- Expand_Subprogram_Contract
18694 -- * Template - The annotation utilizes the generic template of the
18695 -- related subprogram [body] when it is:
18697 -- aspect on subprogram declaration
18698 -- aspect on stand alone subprogram body
18699 -- pragma on stand alone subprogram body
18701 -- The annotation must prepare its own template when it is:
18703 -- pragma on subprogram declaration
18705 -- * Globals - Capture of global references must occur after full
18708 -- * Instance - The annotation is instantiated automatically when
18709 -- the related generic subprogram [body] is instantiated except for
18710 -- the "pragma on subprogram declaration" case. In that scenario
18711 -- the annotation must instantiate itself.
18715 Pragma_Precondition
=>
18716 Analyze_Pre_Post_Condition
;
18722 -- pragma Predicate
18723 -- ([Entity =>] type_LOCAL_NAME,
18724 -- [Check =>] boolean_EXPRESSION);
18726 when Pragma_Predicate
=> Predicate
: declare
18733 Check_Arg_Count
(2);
18734 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18735 Check_Optional_Identifier
(Arg2
, Name_Check
);
18737 Check_Arg_Is_Local_Name
(Arg1
);
18739 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18740 Find_Type
(Type_Id
);
18741 Typ
:= Entity
(Type_Id
);
18743 if Typ
= Any_Type
then
18747 -- A pragma that applies to a Ghost entity becomes Ghost for the
18748 -- purposes of legality checks and removal of ignored Ghost code.
18750 Mark_Pragma_As_Ghost
(N
, Typ
);
18752 -- The remaining processing is simply to link the pragma on to
18753 -- the rep item chain, for processing when the type is frozen.
18754 -- This is accomplished by a call to Rep_Item_Too_Late. We also
18755 -- mark the type as having predicates.
18757 Set_Has_Predicates
(Typ
);
18758 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18761 -----------------------
18762 -- Predicate_Failure --
18763 -----------------------
18765 -- pragma Predicate_Failure
18766 -- ([Entity =>] type_LOCAL_NAME,
18767 -- [Message =>] string_EXPRESSION);
18769 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
18776 Check_Arg_Count
(2);
18777 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18778 Check_Optional_Identifier
(Arg2
, Name_Message
);
18780 Check_Arg_Is_Local_Name
(Arg1
);
18782 Type_Id
:= Get_Pragma_Arg
(Arg1
);
18783 Find_Type
(Type_Id
);
18784 Typ
:= Entity
(Type_Id
);
18786 if Typ
= Any_Type
then
18790 -- A pragma that applies to a Ghost entity becomes Ghost for the
18791 -- purposes of legality checks and removal of ignored Ghost code.
18793 Mark_Pragma_As_Ghost
(N
, Typ
);
18795 -- The remaining processing is simply to link the pragma on to
18796 -- the rep item chain, for processing when the type is frozen.
18797 -- This is accomplished by a call to Rep_Item_Too_Late.
18799 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
18800 end Predicate_Failure
;
18806 -- pragma Preelaborate [(library_unit_NAME)];
18808 -- Set the flag Is_Preelaborated of program unit name entity
18810 when Pragma_Preelaborate
=> Preelaborate
: declare
18811 Pa
: constant Node_Id
:= Parent
(N
);
18812 Pk
: constant Node_Kind
:= Nkind
(Pa
);
18816 Check_Ada_83_Warning
;
18817 Check_Valid_Library_Unit_Pragma
;
18819 if Nkind
(N
) = N_Null_Statement
then
18823 Ent
:= Find_Lib_Unit_Name
;
18825 -- A pragma that applies to a Ghost entity becomes Ghost for the
18826 -- purposes of legality checks and removal of ignored Ghost code.
18828 Mark_Pragma_As_Ghost
(N
, Ent
);
18829 Check_Duplicate_Pragma
(Ent
);
18831 -- This filters out pragmas inside generic parents that show up
18832 -- inside instantiations. Pragmas that come from aspects in the
18833 -- unit are not ignored.
18835 if Present
(Ent
) then
18836 if Pk
= N_Package_Specification
18837 and then Present
(Generic_Parent
(Pa
))
18838 and then not From_Aspect_Specification
(N
)
18843 if not Debug_Flag_U
then
18844 Set_Is_Preelaborated
(Ent
);
18845 Set_Suppress_Elaboration_Warnings
(Ent
);
18851 -------------------------------
18852 -- Prefix_Exception_Messages --
18853 -------------------------------
18855 -- pragma Prefix_Exception_Messages;
18857 when Pragma_Prefix_Exception_Messages
=>
18859 Check_Valid_Configuration_Pragma
;
18860 Check_Arg_Count
(0);
18861 Prefix_Exception_Messages
:= True;
18867 -- pragma Priority (EXPRESSION);
18869 when Pragma_Priority
=> Priority
: declare
18870 P
: constant Node_Id
:= Parent
(N
);
18875 Check_No_Identifiers
;
18876 Check_Arg_Count
(1);
18880 if Nkind
(P
) = N_Subprogram_Body
then
18881 Check_In_Main_Program
;
18883 Ent
:= Defining_Unit_Name
(Specification
(P
));
18885 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
18886 Ent
:= Defining_Identifier
(Ent
);
18889 Arg
:= Get_Pragma_Arg
(Arg1
);
18890 Analyze_And_Resolve
(Arg
, Standard_Integer
);
18894 if not Is_OK_Static_Expression
(Arg
) then
18895 Flag_Non_Static_Expr
18896 ("main subprogram priority is not static!", Arg
);
18899 -- If constraint error, then we already signalled an error
18901 elsif Raises_Constraint_Error
(Arg
) then
18904 -- Otherwise check in range except if Relaxed_RM_Semantics
18905 -- where we ignore the value if out of range.
18909 Val
: constant Uint
:= Expr_Value
(Arg
);
18911 if not Relaxed_RM_Semantics
18914 or else Val
> Expr_Value
(Expression
18915 (Parent
(RTE
(RE_Max_Priority
)))))
18918 ("main subprogram priority is out of range", Arg1
);
18921 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
18926 -- Load an arbitrary entity from System.Tasking.Stages or
18927 -- System.Tasking.Restricted.Stages (depending on the
18928 -- supported profile) to make sure that one of these packages
18929 -- is implicitly with'ed, since we need to have the tasking
18930 -- run time active for the pragma Priority to have any effect.
18931 -- Previously we with'ed the package System.Tasking, but this
18932 -- package does not trigger the required initialization of the
18933 -- run-time library.
18936 Discard
: Entity_Id
;
18937 pragma Warnings
(Off
, Discard
);
18939 if Restricted_Profile
then
18940 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
18942 Discard
:= RTE
(RE_Activate_Tasks
);
18946 -- Task or Protected, must be of type Integer
18948 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
18949 Arg
:= Get_Pragma_Arg
(Arg1
);
18950 Ent
:= Defining_Identifier
(Parent
(P
));
18952 -- The expression must be analyzed in the special manner
18953 -- described in "Handling of Default and Per-Object
18954 -- Expressions" in sem.ads.
18956 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
18958 if not Is_OK_Static_Expression
(Arg
) then
18959 Check_Restriction
(Static_Priorities
, Arg
);
18962 -- Anything else is incorrect
18968 -- Check duplicate pragma before we chain the pragma in the Rep
18969 -- Item chain of Ent.
18971 Check_Duplicate_Pragma
(Ent
);
18972 Record_Rep_Item
(Ent
, N
);
18975 -----------------------------------
18976 -- Priority_Specific_Dispatching --
18977 -----------------------------------
18979 -- pragma Priority_Specific_Dispatching (
18980 -- policy_IDENTIFIER,
18981 -- first_priority_EXPRESSION,
18982 -- last_priority_EXPRESSION);
18984 when Pragma_Priority_Specific_Dispatching
=>
18985 Priority_Specific_Dispatching
: declare
18986 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
18987 -- This is the entity System.Any_Priority;
18990 Lower_Bound
: Node_Id
;
18991 Upper_Bound
: Node_Id
;
18997 Check_Arg_Count
(3);
18998 Check_No_Identifiers
;
18999 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19000 Check_Valid_Configuration_Pragma
;
19001 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19002 DP
:= Fold_Upper
(Name_Buffer
(1));
19004 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
19005 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
19006 Lower_Val
:= Expr_Value
(Lower_Bound
);
19008 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
19009 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
19010 Upper_Val
:= Expr_Value
(Upper_Bound
);
19012 -- It is not allowed to use Task_Dispatching_Policy and
19013 -- Priority_Specific_Dispatching in the same partition.
19015 if Task_Dispatching_Policy
/= ' ' then
19016 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19018 ("pragma% incompatible with Task_Dispatching_Policy#");
19020 -- Check lower bound in range
19022 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19024 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19027 ("first_priority is out of range", Arg2
);
19029 -- Check upper bound in range
19031 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19033 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19036 ("last_priority is out of range", Arg3
);
19038 -- Check that the priority range is valid
19040 elsif Lower_Val
> Upper_Val
then
19042 ("last_priority_expression must be greater than or equal to "
19043 & "first_priority_expression");
19045 -- Store the new policy, but always preserve System_Location since
19046 -- we like the error message with the run-time name.
19049 -- Check overlapping in the priority ranges specified in other
19050 -- Priority_Specific_Dispatching pragmas within the same
19051 -- partition. We can only check those we know about.
19054 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
19056 if Specific_Dispatching
.Table
(J
).First_Priority
in
19057 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19058 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
19059 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19062 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
19064 ("priority range overlaps with "
19065 & "Priority_Specific_Dispatching#");
19069 -- The use of Priority_Specific_Dispatching is incompatible
19070 -- with Task_Dispatching_Policy.
19072 if Task_Dispatching_Policy
/= ' ' then
19073 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19075 ("Priority_Specific_Dispatching incompatible "
19076 & "with Task_Dispatching_Policy#");
19079 -- The use of Priority_Specific_Dispatching forces ceiling
19082 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
19083 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19085 ("Priority_Specific_Dispatching incompatible "
19086 & "with Locking_Policy#");
19088 -- Set the Ceiling_Locking policy, but preserve System_Location
19089 -- since we like the error message with the run time name.
19092 Locking_Policy
:= 'C';
19094 if Locking_Policy_Sloc
/= System_Location
then
19095 Locking_Policy_Sloc
:= Loc
;
19099 -- Add entry in the table
19101 Specific_Dispatching
.Append
19102 ((Dispatching_Policy
=> DP
,
19103 First_Priority
=> UI_To_Int
(Lower_Val
),
19104 Last_Priority
=> UI_To_Int
(Upper_Val
),
19105 Pragma_Loc
=> Loc
));
19107 end Priority_Specific_Dispatching
;
19113 -- pragma Profile (profile_IDENTIFIER);
19115 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19117 when Pragma_Profile
=>
19119 Check_Arg_Count
(1);
19120 Check_Valid_Configuration_Pragma
;
19121 Check_No_Identifiers
;
19124 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19127 if Chars
(Argx
) = Name_Ravenscar
then
19128 Set_Ravenscar_Profile
(Ravenscar
, N
);
19130 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
19131 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
19133 elsif Chars
(Argx
) = Name_Restricted
then
19134 Set_Profile_Restrictions
19136 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19138 elsif Chars
(Argx
) = Name_Rational
then
19139 Set_Rational_Profile
;
19141 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19142 Set_Profile_Restrictions
19143 (No_Implementation_Extensions
,
19144 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19147 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19151 ----------------------
19152 -- Profile_Warnings --
19153 ----------------------
19155 -- pragma Profile_Warnings (profile_IDENTIFIER);
19157 -- profile_IDENTIFIER => Restricted | Ravenscar
19159 when Pragma_Profile_Warnings
=>
19161 Check_Arg_Count
(1);
19162 Check_Valid_Configuration_Pragma
;
19163 Check_No_Identifiers
;
19166 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19169 if Chars
(Argx
) = Name_Ravenscar
then
19170 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
19172 elsif Chars
(Argx
) = Name_Restricted
then
19173 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
19175 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19176 Set_Profile_Restrictions
19177 (No_Implementation_Extensions
, N
, Warn
=> True);
19180 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19184 --------------------------
19185 -- Propagate_Exceptions --
19186 --------------------------
19188 -- pragma Propagate_Exceptions;
19190 -- Note: this pragma is obsolete and has no effect
19192 when Pragma_Propagate_Exceptions
=>
19194 Check_Arg_Count
(0);
19196 if Warn_On_Obsolescent_Feature
then
19198 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19199 "and has no effect?j?", N
);
19202 -----------------------------
19203 -- Provide_Shift_Operators --
19204 -----------------------------
19206 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19208 when Pragma_Provide_Shift_Operators
=>
19209 Provide_Shift_Operators
: declare
19212 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
19213 -- Insert declaration and pragma Instrinsic for named shift op
19215 ----------------------------
19216 -- Declare_Shift_Operator --
19217 ----------------------------
19219 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
19225 Make_Subprogram_Declaration
(Loc
,
19226 Make_Function_Specification
(Loc
,
19227 Defining_Unit_Name
=>
19228 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
19230 Result_Definition
=>
19231 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
19233 Parameter_Specifications
=> New_List
(
19234 Make_Parameter_Specification
(Loc
,
19235 Defining_Identifier
=>
19236 Make_Defining_Identifier
(Loc
, Name_Value
),
19238 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
19240 Make_Parameter_Specification
(Loc
,
19241 Defining_Identifier
=>
19242 Make_Defining_Identifier
(Loc
, Name_Amount
),
19244 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
19248 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
19249 Pragma_Argument_Associations
=> New_List
(
19250 Make_Pragma_Argument_Association
(Loc
,
19251 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
19252 Make_Pragma_Argument_Association
(Loc
,
19253 Expression
=> Make_Identifier
(Loc
, Nam
))));
19255 Insert_After
(N
, Import
);
19256 Insert_After
(N
, Func
);
19257 end Declare_Shift_Operator
;
19259 -- Start of processing for Provide_Shift_Operators
19263 Check_Arg_Count
(1);
19264 Check_Arg_Is_Local_Name
(Arg1
);
19266 Arg1
:= Get_Pragma_Arg
(Arg1
);
19268 -- We must have an entity name
19270 if not Is_Entity_Name
(Arg1
) then
19272 ("pragma % must apply to integer first subtype", Arg1
);
19275 -- If no Entity, means there was a prior error so ignore
19277 if Present
(Entity
(Arg1
)) then
19278 Ent
:= Entity
(Arg1
);
19280 -- Apply error checks
19282 if not Is_First_Subtype
(Ent
) then
19284 ("cannot apply pragma %",
19285 "\& is not a first subtype",
19288 elsif not Is_Integer_Type
(Ent
) then
19290 ("cannot apply pragma %",
19291 "\& is not an integer type",
19294 elsif Has_Shift_Operator
(Ent
) then
19296 ("cannot apply pragma %",
19297 "\& already has declared shift operators",
19300 elsif Is_Frozen
(Ent
) then
19302 ("pragma % appears too late",
19303 "\& is already frozen",
19307 -- Now declare the operators. We do this during analysis rather
19308 -- than expansion, since we want the operators available if we
19309 -- are operating in -gnatc or ASIS mode.
19311 Declare_Shift_Operator
(Name_Rotate_Left
);
19312 Declare_Shift_Operator
(Name_Rotate_Right
);
19313 Declare_Shift_Operator
(Name_Shift_Left
);
19314 Declare_Shift_Operator
(Name_Shift_Right
);
19315 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
19317 end Provide_Shift_Operators
;
19323 -- pragma Psect_Object (
19324 -- [Internal =>] LOCAL_NAME,
19325 -- [, [External =>] EXTERNAL_SYMBOL]
19326 -- [, [Size =>] EXTERNAL_SYMBOL]);
19328 when Pragma_Psect_Object | Pragma_Common_Object
=>
19329 Psect_Object
: declare
19330 Args
: Args_List
(1 .. 3);
19331 Names
: constant Name_List
(1 .. 3) := (
19336 Internal
: Node_Id
renames Args
(1);
19337 External
: Node_Id
renames Args
(2);
19338 Size
: Node_Id
renames Args
(3);
19340 Def_Id
: Entity_Id
;
19342 procedure Check_Arg
(Arg
: Node_Id
);
19343 -- Checks that argument is either a string literal or an
19344 -- identifier, and posts error message if not.
19350 procedure Check_Arg
(Arg
: Node_Id
) is
19352 if not Nkind_In
(Original_Node
(Arg
),
19357 ("inappropriate argument for pragma %", Arg
);
19361 -- Start of processing for Common_Object/Psect_Object
19365 Gather_Associations
(Names
, Args
);
19366 Process_Extended_Import_Export_Internal_Arg
(Internal
);
19368 Def_Id
:= Entity
(Internal
);
19370 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
19372 ("pragma% must designate an object", Internal
);
19375 Check_Arg
(Internal
);
19377 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
19379 ("cannot use pragma% for imported/exported object",
19383 if Is_Concurrent_Type
(Etype
(Internal
)) then
19385 ("cannot specify pragma % for task/protected object",
19389 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
19391 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
19393 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
19396 if Ekind
(Def_Id
) = E_Constant
then
19398 ("cannot specify pragma % for a constant", Internal
);
19401 if Is_Record_Type
(Etype
(Internal
)) then
19407 Ent
:= First_Entity
(Etype
(Internal
));
19408 while Present
(Ent
) loop
19409 Decl
:= Declaration_Node
(Ent
);
19411 if Ekind
(Ent
) = E_Component
19412 and then Nkind
(Decl
) = N_Component_Declaration
19413 and then Present
(Expression
(Decl
))
19414 and then Warn_On_Export_Import
19417 ("?x?object for pragma % has defaults", Internal
);
19427 if Present
(Size
) then
19431 if Present
(External
) then
19432 Check_Arg_Is_External_Name
(External
);
19435 -- If all error tests pass, link pragma on to the rep item chain
19437 Record_Rep_Item
(Def_Id
, N
);
19444 -- pragma Pure [(library_unit_NAME)];
19446 when Pragma_Pure
=> Pure
: declare
19450 Check_Ada_83_Warning
;
19452 -- If the pragma comes from a subprogram instantiation, nothing to
19453 -- check, this can happen at any level of nesting.
19455 if Is_Wrapper_Package
(Current_Scope
) then
19458 Check_Valid_Library_Unit_Pragma
;
19461 if Nkind
(N
) = N_Null_Statement
then
19465 Ent
:= Find_Lib_Unit_Name
;
19467 -- A pragma that applies to a Ghost entity becomes Ghost for the
19468 -- purposes of legality checks and removal of ignored Ghost code.
19470 Mark_Pragma_As_Ghost
(N
, Ent
);
19472 if not Debug_Flag_U
then
19474 Set_Has_Pragma_Pure
(Ent
);
19475 Set_Suppress_Elaboration_Warnings
(Ent
);
19479 -------------------
19480 -- Pure_Function --
19481 -------------------
19483 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19485 when Pragma_Pure_Function
=> Pure_Function
: declare
19486 Def_Id
: Entity_Id
;
19489 Effective
: Boolean := False;
19493 Check_Arg_Count
(1);
19494 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19495 Check_Arg_Is_Local_Name
(Arg1
);
19496 E_Id
:= Get_Pragma_Arg
(Arg1
);
19498 if Error_Posted
(E_Id
) then
19502 -- Loop through homonyms (overloadings) of referenced entity
19504 E
:= Entity
(E_Id
);
19506 -- A pragma that applies to a Ghost entity becomes Ghost for the
19507 -- purposes of legality checks and removal of ignored Ghost code.
19509 Mark_Pragma_As_Ghost
(N
, E
);
19511 if Present
(E
) then
19513 Def_Id
:= Get_Base_Subprogram
(E
);
19515 if not Ekind_In
(Def_Id
, E_Function
,
19516 E_Generic_Function
,
19520 ("pragma% requires a function name", Arg1
);
19523 Set_Is_Pure
(Def_Id
);
19525 if not Has_Pragma_Pure_Function
(Def_Id
) then
19526 Set_Has_Pragma_Pure_Function
(Def_Id
);
19530 exit when From_Aspect_Specification
(N
);
19532 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
19536 and then Warn_On_Redundant_Constructs
19539 ("pragma Pure_Function on& is redundant?r?",
19545 --------------------
19546 -- Queuing_Policy --
19547 --------------------
19549 -- pragma Queuing_Policy (policy_IDENTIFIER);
19551 when Pragma_Queuing_Policy
=> declare
19555 Check_Ada_83_Warning
;
19556 Check_Arg_Count
(1);
19557 Check_No_Identifiers
;
19558 Check_Arg_Is_Queuing_Policy
(Arg1
);
19559 Check_Valid_Configuration_Pragma
;
19560 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19561 QP
:= Fold_Upper
(Name_Buffer
(1));
19563 if Queuing_Policy
/= ' '
19564 and then Queuing_Policy
/= QP
19566 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
19567 Error_Pragma
("queuing policy incompatible with policy#");
19569 -- Set new policy, but always preserve System_Location since we
19570 -- like the error message with the run time name.
19573 Queuing_Policy
:= QP
;
19575 if Queuing_Policy_Sloc
/= System_Location
then
19576 Queuing_Policy_Sloc
:= Loc
;
19585 -- pragma Rational, for compatibility with foreign compiler
19587 when Pragma_Rational
=>
19588 Set_Rational_Profile
;
19590 ---------------------
19591 -- Refined_Depends --
19592 ---------------------
19594 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19596 -- DEPENDENCY_RELATION ::=
19598 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19600 -- DEPENDENCY_CLAUSE ::=
19601 -- OUTPUT_LIST =>[+] INPUT_LIST
19602 -- | NULL_DEPENDENCY_CLAUSE
19604 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19606 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19608 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19610 -- OUTPUT ::= NAME | FUNCTION_RESULT
19613 -- where FUNCTION_RESULT is a function Result attribute_reference
19615 -- Characteristics:
19617 -- * Analysis - The annotation undergoes initial checks to verify
19618 -- the legal placement and context. Secondary checks fully analyze
19619 -- the dependency clauses/global list in:
19621 -- Analyze_Refined_Depends_In_Decl_Part
19623 -- * Expansion - None.
19625 -- * Template - The annotation utilizes the generic template of the
19626 -- related subprogram body.
19628 -- * Globals - Capture of global references must occur after full
19631 -- * Instance - The annotation is instantiated automatically when
19632 -- the related generic subprogram body is instantiated.
19634 when Pragma_Refined_Depends
=> Refined_Depends
: declare
19635 Body_Id
: Entity_Id
;
19637 Spec_Id
: Entity_Id
;
19640 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19644 -- Chain the pragma on the contract for further processing by
19645 -- Analyze_Refined_Depends_In_Decl_Part.
19647 Add_Contract_Item
(N
, Body_Id
);
19649 -- The legality checks of pragmas Refined_Depends and
19650 -- Refined_Global are affected by the SPARK mode in effect and
19651 -- the volatility of the context. In addition these two pragmas
19652 -- are subject to an inherent order:
19654 -- 1) Refined_Global
19655 -- 2) Refined_Depends
19657 -- Analyze all these pragmas in the order outlined above
19659 Analyze_If_Present
(Pragma_SPARK_Mode
);
19660 Analyze_If_Present
(Pragma_Volatile_Function
);
19661 Analyze_If_Present
(Pragma_Refined_Global
);
19662 Analyze_Refined_Depends_In_Decl_Part
(N
);
19664 end Refined_Depends
;
19666 --------------------
19667 -- Refined_Global --
19668 --------------------
19670 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
19672 -- GLOBAL_SPECIFICATION ::=
19675 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
19677 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
19679 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
19680 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
19681 -- GLOBAL_ITEM ::= NAME
19683 -- Characteristics:
19685 -- * Analysis - The annotation undergoes initial checks to verify
19686 -- the legal placement and context. Secondary checks fully analyze
19687 -- the dependency clauses/global list in:
19689 -- Analyze_Refined_Global_In_Decl_Part
19691 -- * Expansion - None.
19693 -- * Template - The annotation utilizes the generic template of the
19694 -- related subprogram body.
19696 -- * Globals - Capture of global references must occur after full
19699 -- * Instance - The annotation is instantiated automatically when
19700 -- the related generic subprogram body is instantiated.
19702 when Pragma_Refined_Global
=> Refined_Global
: declare
19703 Body_Id
: Entity_Id
;
19705 Spec_Id
: Entity_Id
;
19708 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19712 -- Chain the pragma on the contract for further processing by
19713 -- Analyze_Refined_Global_In_Decl_Part.
19715 Add_Contract_Item
(N
, Body_Id
);
19717 -- The legality checks of pragmas Refined_Depends and
19718 -- Refined_Global are affected by the SPARK mode in effect and
19719 -- the volatility of the context. In addition these two pragmas
19720 -- are subject to an inherent order:
19722 -- 1) Refined_Global
19723 -- 2) Refined_Depends
19725 -- Analyze all these pragmas in the order outlined above
19727 Analyze_If_Present
(Pragma_SPARK_Mode
);
19728 Analyze_If_Present
(Pragma_Volatile_Function
);
19729 Analyze_Refined_Global_In_Decl_Part
(N
);
19730 Analyze_If_Present
(Pragma_Refined_Depends
);
19732 end Refined_Global
;
19738 -- pragma Refined_Post (boolean_EXPRESSION);
19740 -- Characteristics:
19742 -- * Analysis - The annotation is fully analyzed immediately upon
19743 -- elaboration as it cannot forward reference entities.
19745 -- * Expansion - The annotation is expanded during the expansion of
19746 -- the related subprogram body contract as performed in:
19748 -- Expand_Subprogram_Contract
19750 -- * Template - The annotation utilizes the generic template of the
19751 -- related subprogram body.
19753 -- * Globals - Capture of global references must occur after full
19756 -- * Instance - The annotation is instantiated automatically when
19757 -- the related generic subprogram body is instantiated.
19759 when Pragma_Refined_Post
=> Refined_Post
: declare
19760 Body_Id
: Entity_Id
;
19762 Spec_Id
: Entity_Id
;
19765 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19767 -- Fully analyze the pragma when it appears inside a subprogram
19768 -- body because it cannot benefit from forward references.
19772 -- Chain the pragma on the contract for completeness
19774 Add_Contract_Item
(N
, Body_Id
);
19776 -- The legality checks of pragma Refined_Post are affected by
19777 -- the SPARK mode in effect and the volatility of the context.
19778 -- Analyze all pragmas in a specific order.
19780 Analyze_If_Present
(Pragma_SPARK_Mode
);
19781 Analyze_If_Present
(Pragma_Volatile_Function
);
19782 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
19784 -- Currently it is not possible to inline pre/postconditions on
19785 -- a subprogram subject to pragma Inline_Always.
19787 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
19791 -------------------
19792 -- Refined_State --
19793 -------------------
19795 -- pragma Refined_State (REFINEMENT_LIST);
19797 -- REFINEMENT_LIST ::=
19798 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
19800 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
19802 -- CONSTITUENT_LIST ::=
19805 -- | (CONSTITUENT {, CONSTITUENT})
19807 -- CONSTITUENT ::= object_NAME | state_NAME
19809 -- Characteristics:
19811 -- * Analysis - The annotation undergoes initial checks to verify
19812 -- the legal placement and context. Secondary checks preanalyze the
19813 -- refinement clauses in:
19815 -- Analyze_Refined_State_In_Decl_Part
19817 -- * Expansion - None.
19819 -- * Template - The annotation utilizes the template of the related
19822 -- * Globals - Capture of global references must occur after full
19825 -- * Instance - The annotation is instantiated automatically when
19826 -- the related generic package body is instantiated.
19828 when Pragma_Refined_State
=> Refined_State
: declare
19829 Pack_Decl
: Node_Id
;
19830 Spec_Id
: Entity_Id
;
19834 Check_No_Identifiers
;
19835 Check_Arg_Count
(1);
19837 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
19839 -- Ensure the proper placement of the pragma. Refined states must
19840 -- be associated with a package body.
19842 if Nkind
(Pack_Decl
) = N_Package_Body
then
19845 -- Otherwise the pragma is associated with an illegal construct
19852 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
19854 -- Chain the pragma on the contract for further processing by
19855 -- Analyze_Refined_State_In_Decl_Part.
19857 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
19859 -- The legality checks of pragma Refined_State are affected by the
19860 -- SPARK mode in effect. Analyze all pragmas in a specific order.
19862 Analyze_If_Present
(Pragma_SPARK_Mode
);
19864 -- A pragma that applies to a Ghost entity becomes Ghost for the
19865 -- purposes of legality checks and removal of ignored Ghost code.
19867 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
19869 -- State refinement is allowed only when the corresponding package
19870 -- declaration has non-null pragma Abstract_State. Refinement not
19871 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
19873 if SPARK_Mode
/= Off
19875 (No
(Abstract_States
(Spec_Id
))
19876 or else Has_Null_Abstract_State
(Spec_Id
))
19879 ("useless refinement, package & does not define abstract "
19880 & "states", N
, Spec_Id
);
19885 -----------------------
19886 -- Relative_Deadline --
19887 -----------------------
19889 -- pragma Relative_Deadline (time_span_EXPRESSION);
19891 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
19892 P
: constant Node_Id
:= Parent
(N
);
19897 Check_No_Identifiers
;
19898 Check_Arg_Count
(1);
19900 Arg
:= Get_Pragma_Arg
(Arg1
);
19902 -- The expression must be analyzed in the special manner described
19903 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
19905 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
19909 if Nkind
(P
) = N_Subprogram_Body
then
19910 Check_In_Main_Program
;
19912 -- Only Task and subprogram cases allowed
19914 elsif Nkind
(P
) /= N_Task_Definition
then
19918 -- Check duplicate pragma before we set the corresponding flag
19920 if Has_Relative_Deadline_Pragma
(P
) then
19921 Error_Pragma
("duplicate pragma% not allowed");
19924 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
19925 -- Relative_Deadline pragma node cannot be inserted in the Rep
19926 -- Item chain of Ent since it is rewritten by the expander as a
19927 -- procedure call statement that will break the chain.
19929 Set_Has_Relative_Deadline_Pragma
(P
);
19930 end Relative_Deadline
;
19932 ------------------------
19933 -- Remote_Access_Type --
19934 ------------------------
19936 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
19938 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
19943 Check_Arg_Count
(1);
19944 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19945 Check_Arg_Is_Local_Name
(Arg1
);
19947 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
19949 -- A pragma that applies to a Ghost entity becomes Ghost for the
19950 -- purposes of legality checks and removal of ignored Ghost code.
19952 Mark_Pragma_As_Ghost
(N
, E
);
19954 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
19955 and then Ekind
(E
) = E_General_Access_Type
19956 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
19957 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
19959 and then Is_Valid_Remote_Object_Type
19960 (Root_Type
(Directly_Designated_Type
(E
)))
19962 Set_Is_Remote_Types
(E
);
19966 ("pragma% applies only to formal access to classwide types",
19969 end Remote_Access_Type
;
19971 ---------------------------
19972 -- Remote_Call_Interface --
19973 ---------------------------
19975 -- pragma Remote_Call_Interface [(library_unit_NAME)];
19977 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
19978 Cunit_Node
: Node_Id
;
19979 Cunit_Ent
: Entity_Id
;
19983 Check_Ada_83_Warning
;
19984 Check_Valid_Library_Unit_Pragma
;
19986 if Nkind
(N
) = N_Null_Statement
then
19990 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
19991 K
:= Nkind
(Unit
(Cunit_Node
));
19992 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
19994 -- A pragma that applies to a Ghost entity becomes Ghost for the
19995 -- purposes of legality checks and removal of ignored Ghost code.
19997 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
19999 if K
= N_Package_Declaration
20000 or else K
= N_Generic_Package_Declaration
20001 or else K
= N_Subprogram_Declaration
20002 or else K
= N_Generic_Subprogram_Declaration
20003 or else (K
= N_Subprogram_Body
20004 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
20009 "pragma% must apply to package or subprogram declaration");
20012 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
20013 end Remote_Call_Interface
;
20019 -- pragma Remote_Types [(library_unit_NAME)];
20021 when Pragma_Remote_Types
=> Remote_Types
: declare
20022 Cunit_Node
: Node_Id
;
20023 Cunit_Ent
: Entity_Id
;
20026 Check_Ada_83_Warning
;
20027 Check_Valid_Library_Unit_Pragma
;
20029 if Nkind
(N
) = N_Null_Statement
then
20033 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20034 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20036 -- A pragma that applies to a Ghost entity becomes Ghost for the
20037 -- purposes of legality checks and removal of ignored Ghost code.
20039 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
20041 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20042 N_Generic_Package_Declaration
)
20045 ("pragma% can only apply to a package declaration");
20048 Set_Is_Remote_Types
(Cunit_Ent
);
20055 -- pragma Ravenscar;
20057 when Pragma_Ravenscar
=>
20059 Check_Arg_Count
(0);
20060 Check_Valid_Configuration_Pragma
;
20061 Set_Ravenscar_Profile
(Ravenscar
, N
);
20063 if Warn_On_Obsolescent_Feature
then
20065 ("pragma Ravenscar is an obsolescent feature?j?", N
);
20067 ("|use pragma Profile (Ravenscar) instead?j?", N
);
20070 -------------------------
20071 -- Restricted_Run_Time --
20072 -------------------------
20074 -- pragma Restricted_Run_Time;
20076 when Pragma_Restricted_Run_Time
=>
20078 Check_Arg_Count
(0);
20079 Check_Valid_Configuration_Pragma
;
20080 Set_Profile_Restrictions
20081 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
20083 if Warn_On_Obsolescent_Feature
then
20085 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20088 ("|use pragma Profile (Restricted) instead?j?", N
);
20095 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20098 -- restriction_IDENTIFIER
20099 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20101 when Pragma_Restrictions
=>
20102 Process_Restrictions_Or_Restriction_Warnings
20103 (Warn
=> Treat_Restrictions_As_Warnings
);
20105 --------------------------
20106 -- Restriction_Warnings --
20107 --------------------------
20109 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20112 -- restriction_IDENTIFIER
20113 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20115 when Pragma_Restriction_Warnings
=>
20117 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
20123 -- pragma Reviewable;
20125 when Pragma_Reviewable
=>
20126 Check_Ada_83_Warning
;
20127 Check_Arg_Count
(0);
20129 -- Call dummy debugging function rv. This is done to assist front
20130 -- end debugging. By placing a Reviewable pragma in the source
20131 -- program, a breakpoint on rv catches this place in the source,
20132 -- allowing convenient stepping to the point of interest.
20136 --------------------------
20137 -- Short_Circuit_And_Or --
20138 --------------------------
20140 -- pragma Short_Circuit_And_Or;
20142 when Pragma_Short_Circuit_And_Or
=>
20144 Check_Arg_Count
(0);
20145 Check_Valid_Configuration_Pragma
;
20146 Short_Circuit_And_Or
:= True;
20148 -------------------
20149 -- Share_Generic --
20150 -------------------
20152 -- pragma Share_Generic (GNAME {, GNAME});
20154 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20156 when Pragma_Share_Generic
=>
20158 Process_Generic_List
;
20164 -- pragma Shared (LOCAL_NAME);
20166 when Pragma_Shared
=>
20168 Process_Atomic_Independent_Shared_Volatile
;
20170 --------------------
20171 -- Shared_Passive --
20172 --------------------
20174 -- pragma Shared_Passive [(library_unit_NAME)];
20176 -- Set the flag Is_Shared_Passive of program unit name entity
20178 when Pragma_Shared_Passive
=> Shared_Passive
: declare
20179 Cunit_Node
: Node_Id
;
20180 Cunit_Ent
: Entity_Id
;
20183 Check_Ada_83_Warning
;
20184 Check_Valid_Library_Unit_Pragma
;
20186 if Nkind
(N
) = N_Null_Statement
then
20190 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20191 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20193 -- A pragma that applies to a Ghost entity becomes Ghost for the
20194 -- purposes of legality checks and removal of ignored Ghost code.
20196 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
20198 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20199 N_Generic_Package_Declaration
)
20202 ("pragma% can only apply to a package declaration");
20205 Set_Is_Shared_Passive
(Cunit_Ent
);
20206 end Shared_Passive
;
20208 -----------------------
20209 -- Short_Descriptors --
20210 -----------------------
20212 -- pragma Short_Descriptors;
20214 -- Recognize and validate, but otherwise ignore
20216 when Pragma_Short_Descriptors
=>
20218 Check_Arg_Count
(0);
20219 Check_Valid_Configuration_Pragma
;
20221 ------------------------------
20222 -- Simple_Storage_Pool_Type --
20223 ------------------------------
20225 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20227 when Pragma_Simple_Storage_Pool_Type
=>
20228 Simple_Storage_Pool_Type
: declare
20234 Check_Arg_Count
(1);
20235 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20237 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20238 Find_Type
(Type_Id
);
20239 Typ
:= Entity
(Type_Id
);
20241 if Typ
= Any_Type
then
20245 -- A pragma that applies to a Ghost entity becomes Ghost for the
20246 -- purposes of legality checks and removal of ignored Ghost code.
20248 Mark_Pragma_As_Ghost
(N
, Typ
);
20250 -- We require the pragma to apply to a type declared in a package
20251 -- declaration, but not (immediately) within a package body.
20253 if Ekind
(Current_Scope
) /= E_Package
20254 or else In_Package_Body
(Current_Scope
)
20257 ("pragma% can only apply to type declared immediately "
20258 & "within a package declaration");
20261 -- A simple storage pool type must be an immutably limited record
20262 -- or private type. If the pragma is given for a private type,
20263 -- the full type is similarly restricted (which is checked later
20264 -- in Freeze_Entity).
20266 if Is_Record_Type
(Typ
)
20267 and then not Is_Limited_View
(Typ
)
20270 ("pragma% can only apply to explicitly limited record type");
20272 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
20274 ("pragma% can only apply to a private type that is limited");
20276 elsif not Is_Record_Type
(Typ
)
20277 and then not Is_Private_Type
(Typ
)
20280 ("pragma% can only apply to limited record or private type");
20283 Record_Rep_Item
(Typ
, N
);
20284 end Simple_Storage_Pool_Type
;
20286 ----------------------
20287 -- Source_File_Name --
20288 ----------------------
20290 -- There are five forms for this pragma:
20292 -- pragma Source_File_Name (
20293 -- [UNIT_NAME =>] unit_NAME,
20294 -- BODY_FILE_NAME => STRING_LITERAL
20295 -- [, [INDEX =>] INTEGER_LITERAL]);
20297 -- pragma Source_File_Name (
20298 -- [UNIT_NAME =>] unit_NAME,
20299 -- SPEC_FILE_NAME => STRING_LITERAL
20300 -- [, [INDEX =>] INTEGER_LITERAL]);
20302 -- pragma Source_File_Name (
20303 -- BODY_FILE_NAME => STRING_LITERAL
20304 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20305 -- [, CASING => CASING_SPEC]);
20307 -- pragma Source_File_Name (
20308 -- SPEC_FILE_NAME => STRING_LITERAL
20309 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20310 -- [, CASING => CASING_SPEC]);
20312 -- pragma Source_File_Name (
20313 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20314 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20315 -- [, CASING => CASING_SPEC]);
20317 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20319 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20320 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20321 -- only be used when no project file is used, while SFNP can only be
20322 -- used when a project file is used.
20324 -- No processing here. Processing was completed during parsing, since
20325 -- we need to have file names set as early as possible. Units are
20326 -- loaded well before semantic processing starts.
20328 -- The only processing we defer to this point is the check for
20329 -- correct placement.
20331 when Pragma_Source_File_Name
=>
20333 Check_Valid_Configuration_Pragma
;
20335 ------------------------------
20336 -- Source_File_Name_Project --
20337 ------------------------------
20339 -- See Source_File_Name for syntax
20341 -- No processing here. Processing was completed during parsing, since
20342 -- we need to have file names set as early as possible. Units are
20343 -- loaded well before semantic processing starts.
20345 -- The only processing we defer to this point is the check for
20346 -- correct placement.
20348 when Pragma_Source_File_Name_Project
=>
20350 Check_Valid_Configuration_Pragma
;
20352 -- Check that a pragma Source_File_Name_Project is used only in a
20353 -- configuration pragmas file.
20355 -- Pragmas Source_File_Name_Project should only be generated by
20356 -- the Project Manager in configuration pragmas files.
20358 -- This is really an ugly test. It seems to depend on some
20359 -- accidental and undocumented property. At the very least it
20360 -- needs to be documented, but it would be better to have a
20361 -- clean way of testing if we are in a configuration file???
20363 if Present
(Parent
(N
)) then
20365 ("pragma% can only appear in a configuration pragmas file");
20368 ----------------------
20369 -- Source_Reference --
20370 ----------------------
20372 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20374 -- Nothing to do, all processing completed in Par.Prag, since we need
20375 -- the information for possible parser messages that are output.
20377 when Pragma_Source_Reference
=>
20384 -- pragma SPARK_Mode [(On | Off)];
20386 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
20387 Mode_Id
: SPARK_Mode_Type
;
20389 procedure Check_Pragma_Conformance
20390 (Context_Pragma
: Node_Id
;
20391 Entity
: Entity_Id
;
20392 Entity_Pragma
: Node_Id
);
20393 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20394 -- conformance of pragma N depending the following scenarios:
20396 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20397 -- compatible with the pragma Context_Pragma that was inherited
20398 -- from the context:
20399 -- * If the mode of Context_Pragma is ON, then the new mode can
20401 -- * If the mode of Context_Pragma is OFF, then the only allowed
20402 -- new mode is also OFF. Emit error if this is not the case.
20404 -- If Entity is not Empty, verify that pragma N is compatible with
20405 -- pragma Entity_Pragma that belongs to Entity.
20406 -- * If Entity_Pragma is Empty, always issue an error as this
20407 -- corresponds to the case where a previous section of Entity
20408 -- has no SPARK_Mode set.
20409 -- * If the mode of Entity_Pragma is ON, then the new mode can
20411 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20412 -- new mode is also OFF. Emit error if this is not the case.
20414 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
20415 -- Subsidiary to routines Process_xxx. Verify that the related
20416 -- entity E subject to pragma SPARK_Mode is library-level.
20418 procedure Process_Body
(Decl
: Node_Id
);
20419 -- Verify the legality of pragma SPARK_Mode when it appears as the
20420 -- top of the body declarations of entry, package, protected unit,
20421 -- subprogram or task unit body denoted by Decl.
20423 procedure Process_Overloadable
(Decl
: Node_Id
);
20424 -- Verify the legality of pragma SPARK_Mode when it applies to an
20425 -- entry or [generic] subprogram declaration denoted by Decl.
20427 procedure Process_Private_Part
(Decl
: Node_Id
);
20428 -- Verify the legality of pragma SPARK_Mode when it appears at the
20429 -- top of the private declarations of a package spec, protected or
20430 -- task unit declaration denoted by Decl.
20432 procedure Process_Statement_Part
(Decl
: Node_Id
);
20433 -- Verify the legality of pragma SPARK_Mode when it appears at the
20434 -- top of the statement sequence of a package body denoted by node
20437 procedure Process_Visible_Part
(Decl
: Node_Id
);
20438 -- Verify the legality of pragma SPARK_Mode when it appears at the
20439 -- top of the visible declarations of a package spec, protected or
20440 -- task unit declaration denoted by Decl. The routine is also used
20441 -- on protected or task units declared without a definition.
20443 procedure Set_SPARK_Context
;
20444 -- Subsidiary to routines Process_xxx. Set the global variables
20445 -- which represent the mode of the context from pragma N. Ensure
20446 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20448 ------------------------------
20449 -- Check_Pragma_Conformance --
20450 ------------------------------
20452 procedure Check_Pragma_Conformance
20453 (Context_Pragma
: Node_Id
;
20454 Entity
: Entity_Id
;
20455 Entity_Pragma
: Node_Id
)
20457 Err_Id
: Entity_Id
;
20461 -- The current pragma may appear without an argument. If this
20462 -- is the case, associate all error messages with the pragma
20465 if Present
(Arg1
) then
20471 -- The mode of the current pragma is compared against that of
20472 -- an enclosing context.
20474 if Present
(Context_Pragma
) then
20475 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
20477 -- Issue an error if the new mode is less restrictive than
20478 -- that of the context.
20480 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
20481 and then Get_SPARK_Mode_From_Annotation
(N
) = On
20484 ("cannot change SPARK_Mode from Off to On", Err_N
);
20485 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20486 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
20491 -- The mode of the current pragma is compared against that of
20492 -- an initial package, protected type, subprogram or task type
20495 if Present
(Entity
) then
20497 -- A simple protected or task type is transformed into an
20498 -- anonymous type whose name cannot be used to issue error
20499 -- messages. Recover the original entity of the type.
20501 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
20504 (Original_Node
(Unit_Declaration_Node
(Entity
)));
20509 -- Both the initial declaration and the completion carry
20510 -- SPARK_Mode pragmas.
20512 if Present
(Entity_Pragma
) then
20513 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
20515 -- Issue an error if the new mode is less restrictive
20516 -- than that of the initial declaration.
20518 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
20519 and then Get_SPARK_Mode_From_Annotation
(N
) = On
20521 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20522 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
20524 ("\value Off was set for SPARK_Mode on&#",
20529 -- Otherwise the initial declaration lacks a SPARK_Mode
20530 -- pragma in which case the current pragma is illegal as
20531 -- it cannot "complete".
20534 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20535 Error_Msg_Sloc
:= Sloc
(Err_Id
);
20537 ("\no value was set for SPARK_Mode on&#",
20542 end Check_Pragma_Conformance
;
20544 --------------------------------
20545 -- Check_Library_Level_Entity --
20546 --------------------------------
20548 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
20549 procedure Add_Entity_To_Name_Buffer
;
20550 -- Add the E_Kind of entity E to the name buffer
20552 -------------------------------
20553 -- Add_Entity_To_Name_Buffer --
20554 -------------------------------
20556 procedure Add_Entity_To_Name_Buffer
is
20558 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
20559 Add_Str_To_Name_Buffer
("entry");
20561 elsif Ekind_In
(E
, E_Generic_Package
,
20565 Add_Str_To_Name_Buffer
("package");
20567 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
20568 Add_Str_To_Name_Buffer
("protected type");
20570 elsif Ekind_In
(E
, E_Function
,
20571 E_Generic_Function
,
20572 E_Generic_Procedure
,
20576 Add_Str_To_Name_Buffer
("subprogram");
20579 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
20580 Add_Str_To_Name_Buffer
("task type");
20582 end Add_Entity_To_Name_Buffer
;
20586 Msg_1
: constant String := "incorrect placement of pragma%";
20589 -- Start of processing for Check_Library_Level_Entity
20592 if not Is_Library_Level_Entity
(E
) then
20593 Error_Msg_Name_1
:= Pname
;
20594 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
20597 Add_Str_To_Name_Buffer
("\& is not a library-level ");
20598 Add_Entity_To_Name_Buffer
;
20600 Msg_2
:= Name_Find
;
20601 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
20605 end Check_Library_Level_Entity
;
20611 procedure Process_Body
(Decl
: Node_Id
) is
20612 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20613 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
20616 -- Ignore pragma when applied to the special body created for
20617 -- inlining, recognized by its internal name _Parent.
20619 if Chars
(Body_Id
) = Name_uParent
then
20623 Check_Library_Level_Entity
(Body_Id
);
20625 -- For entry bodies, verify the legality against:
20626 -- * The mode of the context
20627 -- * The mode of the spec (if any)
20629 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
20631 -- A stand alone subprogram body
20633 if Body_Id
= Spec_Id
then
20634 Check_Pragma_Conformance
20635 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20637 Entity_Pragma
=> Empty
);
20639 -- An entry or subprogram body that completes a previous
20643 Check_Pragma_Conformance
20644 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20646 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
20650 Set_SPARK_Pragma
(Body_Id
, N
);
20651 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20653 -- For package bodies, verify the legality against:
20654 -- * The mode of the context
20655 -- * The mode of the private part
20657 -- This case is separated from protected and task bodies
20658 -- because the statement part of the package body inherits
20659 -- the mode of the body declarations.
20661 elsif Nkind
(Decl
) = N_Package_Body
then
20662 Check_Pragma_Conformance
20663 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20665 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
20668 Set_SPARK_Pragma
(Body_Id
, N
);
20669 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20670 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20671 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
20673 -- For protected and task bodies, verify the legality against:
20674 -- * The mode of the context
20675 -- * The mode of the private part
20679 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
20681 Check_Pragma_Conformance
20682 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20684 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
20687 Set_SPARK_Pragma
(Body_Id
, N
);
20688 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
20692 --------------------------
20693 -- Process_Overloadable --
20694 --------------------------
20696 procedure Process_Overloadable
(Decl
: Node_Id
) is
20697 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20698 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
20701 Check_Library_Level_Entity
(Spec_Id
);
20703 -- Verify the legality against:
20704 -- * The mode of the context
20706 Check_Pragma_Conformance
20707 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
20709 Entity_Pragma
=> Empty
);
20711 Set_SPARK_Pragma
(Spec_Id
, N
);
20712 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
20714 -- When the pragma applies to the anonymous object created for
20715 -- a single task type, decorate the type as well. This scenario
20716 -- arises when the single task type lacks a task definition,
20717 -- therefore there is no issue with respect to a potential
20718 -- pragma SPARK_Mode in the private part.
20720 -- task type Anon_Task_Typ;
20721 -- Obj : Anon_Task_Typ;
20722 -- pragma SPARK_Mode ...;
20724 if Is_Single_Task_Object
(Spec_Id
) then
20725 Set_SPARK_Pragma
(Spec_Typ
, N
);
20726 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
20727 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
20728 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
20730 end Process_Overloadable
;
20732 --------------------------
20733 -- Process_Private_Part --
20734 --------------------------
20736 procedure Process_Private_Part
(Decl
: Node_Id
) is
20737 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20740 Check_Library_Level_Entity
(Spec_Id
);
20742 -- Verify the legality against:
20743 -- * The mode of the visible declarations
20745 Check_Pragma_Conformance
20746 (Context_Pragma
=> Empty
,
20748 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
20751 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
20752 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
20753 end Process_Private_Part
;
20755 ----------------------------
20756 -- Process_Statement_Part --
20757 ----------------------------
20759 procedure Process_Statement_Part
(Decl
: Node_Id
) is
20760 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20763 Check_Library_Level_Entity
(Body_Id
);
20765 -- Verify the legality against:
20766 -- * The mode of the body declarations
20768 Check_Pragma_Conformance
20769 (Context_Pragma
=> Empty
,
20771 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
20774 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
20775 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
20776 end Process_Statement_Part
;
20778 --------------------------
20779 -- Process_Visible_Part --
20780 --------------------------
20782 procedure Process_Visible_Part
(Decl
: Node_Id
) is
20783 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20784 Obj_Id
: Entity_Id
;
20787 Check_Library_Level_Entity
(Spec_Id
);
20789 -- Verify the legality against:
20790 -- * The mode of the context
20792 Check_Pragma_Conformance
20793 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
20795 Entity_Pragma
=> Empty
);
20797 -- A task unit declared without a definition does not set the
20798 -- SPARK_Mode of the context because the task does not have any
20799 -- entries that could inherit the mode.
20801 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
20802 N_Task_Type_Declaration
)
20807 Set_SPARK_Pragma
(Spec_Id
, N
);
20808 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
20809 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
20810 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
20812 -- When the pragma applies to a single protected or task type,
20813 -- decorate the corresponding anonymous object as well.
20815 -- protected Anon_Prot_Typ is
20816 -- pragma SPARK_Mode ...;
20818 -- end Anon_Prot_Typ;
20820 -- Obj : Anon_Prot_Typ;
20822 if Is_Single_Concurrent_Type
(Spec_Id
) then
20823 Obj_Id
:= Anonymous_Object
(Spec_Id
);
20825 Set_SPARK_Pragma
(Obj_Id
, N
);
20826 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
20828 end Process_Visible_Part
;
20830 -----------------------
20831 -- Set_SPARK_Context --
20832 -----------------------
20834 procedure Set_SPARK_Context
is
20836 SPARK_Mode
:= Mode_Id
;
20837 SPARK_Mode_Pragma
:= N
;
20839 if SPARK_Mode
= On
then
20840 Dynamic_Elaboration_Checks
:= False;
20842 end Set_SPARK_Context
;
20850 -- Start of processing for Do_SPARK_Mode
20853 -- When a SPARK_Mode pragma appears inside an instantiation whose
20854 -- enclosing context has SPARK_Mode set to "off", the pragma has
20855 -- no semantic effect.
20857 if Ignore_Pragma_SPARK_Mode
then
20858 Rewrite
(N
, Make_Null_Statement
(Loc
));
20864 Check_No_Identifiers
;
20865 Check_At_Most_N_Arguments
(1);
20867 -- Check the legality of the mode (no argument = ON)
20869 if Arg_Count
= 1 then
20870 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
20871 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
20876 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
20877 Context
:= Parent
(N
);
20879 -- The pragma appears in a configuration pragmas file
20881 if No
(Context
) then
20882 Check_Valid_Configuration_Pragma
;
20884 if Present
(SPARK_Mode_Pragma
) then
20885 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20886 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
20892 -- The pragma acts as a configuration pragma in a compilation unit
20894 -- pragma SPARK_Mode ...;
20895 -- package Pack is ...;
20897 elsif Nkind
(Context
) = N_Compilation_Unit
20898 and then List_Containing
(N
) = Context_Items
(Context
)
20900 Check_Valid_Configuration_Pragma
;
20903 -- Otherwise the placement of the pragma within the tree dictates
20904 -- its associated construct. Inspect the declarative list where
20905 -- the pragma resides to find a potential construct.
20909 while Present
(Stmt
) loop
20911 -- Skip prior pragmas, but check for duplicates. Note that
20912 -- this also takes care of pragmas generated for aspects.
20914 if Nkind
(Stmt
) = N_Pragma
then
20915 if Pragma_Name
(Stmt
) = Pname
then
20916 Error_Msg_Name_1
:= Pname
;
20917 Error_Msg_Sloc
:= Sloc
(Stmt
);
20918 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
20922 -- The pragma applies to an expression function that has
20923 -- already been rewritten into a subprogram declaration.
20925 -- function Expr_Func return ... is (...);
20926 -- pragma SPARK_Mode ...;
20928 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
20929 and then Nkind
(Original_Node
(Stmt
)) =
20930 N_Expression_Function
20932 Process_Overloadable
(Stmt
);
20935 -- The pragma applies to the anonymous object created for a
20936 -- single concurrent type.
20938 -- protected type Anon_Prot_Typ ...;
20939 -- Obj : Anon_Prot_Typ;
20940 -- pragma SPARK_Mode ...;
20942 elsif Nkind
(Stmt
) = N_Object_Declaration
20943 and then Is_Single_Concurrent_Object
20944 (Defining_Entity
(Stmt
))
20946 Process_Overloadable
(Stmt
);
20949 -- Skip internally generated code
20951 elsif not Comes_From_Source
(Stmt
) then
20954 -- The pragma applies to an entry or [generic] subprogram
20958 -- pragma SPARK_Mode ...;
20961 -- procedure Proc ...;
20962 -- pragma SPARK_Mode ...;
20964 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
20965 N_Subprogram_Declaration
)
20966 or else (Nkind
(Stmt
) = N_Entry_Declaration
20967 and then Is_Protected_Type
20968 (Scope
(Defining_Entity
(Stmt
))))
20970 Process_Overloadable
(Stmt
);
20973 -- Otherwise the pragma does not apply to a legal construct
20974 -- or it does not appear at the top of a declarative or a
20975 -- statement list. Issue an error and stop the analysis.
20985 -- The pragma applies to a package or a subprogram that acts as
20986 -- a compilation unit.
20988 -- procedure Proc ...;
20989 -- pragma SPARK_Mode ...;
20991 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
20992 Context
:= Unit
(Parent
(Context
));
20995 -- The pragma appears at the top of entry, package, protected
20996 -- unit, subprogram or task unit body declarations.
20998 -- entry Ent when ... is
20999 -- pragma SPARK_Mode ...;
21001 -- package body Pack is
21002 -- pragma SPARK_Mode ...;
21004 -- procedure Proc ... is
21005 -- pragma SPARK_Mode;
21007 -- protected body Prot is
21008 -- pragma SPARK_Mode ...;
21010 if Nkind_In
(Context
, N_Entry_Body
,
21016 Process_Body
(Context
);
21018 -- The pragma appears at the top of the visible or private
21019 -- declaration of a package spec, protected or task unit.
21022 -- pragma SPARK_Mode ...;
21024 -- pragma SPARK_Mode ...;
21026 -- protected [type] Prot is
21027 -- pragma SPARK_Mode ...;
21029 -- pragma SPARK_Mode ...;
21031 elsif Nkind_In
(Context
, N_Package_Specification
,
21032 N_Protected_Definition
,
21035 if List_Containing
(N
) = Visible_Declarations
(Context
) then
21036 Process_Visible_Part
(Parent
(Context
));
21038 Process_Private_Part
(Parent
(Context
));
21041 -- The pragma appears at the top of package body statements
21043 -- package body Pack is
21045 -- pragma SPARK_Mode;
21047 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
21048 and then Nkind
(Parent
(Context
)) = N_Package_Body
21050 Process_Statement_Part
(Parent
(Context
));
21052 -- The pragma appeared as an aspect of a [generic] subprogram
21053 -- declaration that acts as a compilation unit.
21056 -- procedure Proc ...;
21057 -- pragma SPARK_Mode ...;
21059 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
21060 N_Subprogram_Declaration
)
21062 Process_Overloadable
(Context
);
21064 -- The pragma does not apply to a legal construct, issue error
21072 --------------------------------
21073 -- Static_Elaboration_Desired --
21074 --------------------------------
21076 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21078 when Pragma_Static_Elaboration_Desired
=>
21080 Check_At_Most_N_Arguments
(1);
21082 if Is_Compilation_Unit
(Current_Scope
)
21083 and then Ekind
(Current_Scope
) = E_Package
21085 Set_Static_Elaboration_Desired
(Current_Scope
, True);
21087 Error_Pragma
("pragma% must apply to a library-level package");
21094 -- pragma Storage_Size (EXPRESSION);
21096 when Pragma_Storage_Size
=> Storage_Size
: declare
21097 P
: constant Node_Id
:= Parent
(N
);
21101 Check_No_Identifiers
;
21102 Check_Arg_Count
(1);
21104 -- The expression must be analyzed in the special manner described
21105 -- in "Handling of Default Expressions" in sem.ads.
21107 Arg
:= Get_Pragma_Arg
(Arg1
);
21108 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21110 if not Is_OK_Static_Expression
(Arg
) then
21111 Check_Restriction
(Static_Storage_Size
, Arg
);
21114 if Nkind
(P
) /= N_Task_Definition
then
21119 if Has_Storage_Size_Pragma
(P
) then
21120 Error_Pragma
("duplicate pragma% not allowed");
21122 Set_Has_Storage_Size_Pragma
(P
, True);
21125 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
21133 -- pragma Storage_Unit (NUMERIC_LITERAL);
21135 -- Only permitted argument is System'Storage_Unit value
21137 when Pragma_Storage_Unit
=>
21138 Check_No_Identifiers
;
21139 Check_Arg_Count
(1);
21140 Check_Arg_Is_Integer_Literal
(Arg1
);
21142 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
21143 UI_From_Int
(Ttypes
.System_Storage_Unit
)
21145 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
21147 ("the only allowed argument for pragma% is ^", Arg1
);
21150 --------------------
21151 -- Stream_Convert --
21152 --------------------
21154 -- pragma Stream_Convert (
21155 -- [Entity =>] type_LOCAL_NAME,
21156 -- [Read =>] function_NAME,
21157 -- [Write =>] function NAME);
21159 when Pragma_Stream_Convert
=> Stream_Convert
: declare
21161 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
21162 -- Check that the given argument is the name of a local function
21163 -- of one argument that is not overloaded earlier in the current
21164 -- local scope. A check is also made that the argument is a
21165 -- function with one parameter.
21167 --------------------------------------
21168 -- Check_OK_Stream_Convert_Function --
21169 --------------------------------------
21171 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
21175 Check_Arg_Is_Local_Name
(Arg
);
21176 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
21178 if Has_Homonym
(Ent
) then
21180 ("argument for pragma% may not be overloaded", Arg
);
21183 if Ekind
(Ent
) /= E_Function
21184 or else No
(First_Formal
(Ent
))
21185 or else Present
(Next_Formal
(First_Formal
(Ent
)))
21188 ("argument for pragma% must be function of one argument",
21191 end Check_OK_Stream_Convert_Function
;
21193 -- Start of processing for Stream_Convert
21197 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
21198 Check_Arg_Count
(3);
21199 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21200 Check_Optional_Identifier
(Arg2
, Name_Read
);
21201 Check_Optional_Identifier
(Arg3
, Name_Write
);
21202 Check_Arg_Is_Local_Name
(Arg1
);
21203 Check_OK_Stream_Convert_Function
(Arg2
);
21204 Check_OK_Stream_Convert_Function
(Arg3
);
21207 Typ
: constant Entity_Id
:=
21208 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
21209 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
21210 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
21213 Check_First_Subtype
(Arg1
);
21215 -- Check for too early or too late. Note that we don't enforce
21216 -- the rule about primitive operations in this case, since, as
21217 -- is the case for explicit stream attributes themselves, these
21218 -- restrictions are not appropriate. Note that the chaining of
21219 -- the pragma by Rep_Item_Too_Late is actually the critical
21220 -- processing done for this pragma.
21222 if Rep_Item_Too_Early
(Typ
, N
)
21224 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
21229 -- Return if previous error
21231 if Etype
(Typ
) = Any_Type
21233 Etype
(Read
) = Any_Type
21235 Etype
(Write
) = Any_Type
21242 if Underlying_Type
(Etype
(Read
)) /= Typ
then
21244 ("incorrect return type for function&", Arg2
);
21247 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
21249 ("incorrect parameter type for function&", Arg3
);
21252 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
21253 Underlying_Type
(Etype
(Write
))
21256 ("result type of & does not match Read parameter type",
21260 end Stream_Convert
;
21266 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21268 -- This is processed by the parser since some of the style checks
21269 -- take place during source scanning and parsing. This means that
21270 -- we don't need to issue error messages here.
21272 when Pragma_Style_Checks
=> Style_Checks
: declare
21273 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21279 Check_No_Identifiers
;
21281 -- Two argument form
21283 if Arg_Count
= 2 then
21284 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21291 E_Id
:= Get_Pragma_Arg
(Arg2
);
21294 if not Is_Entity_Name
(E_Id
) then
21296 ("second argument of pragma% must be entity name",
21300 E
:= Entity
(E_Id
);
21302 if not Ignore_Style_Checks_Pragmas
then
21307 Set_Suppress_Style_Checks
21308 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
21309 exit when No
(Homonym
(E
));
21316 -- One argument form
21319 Check_Arg_Count
(1);
21321 if Nkind
(A
) = N_String_Literal
then
21325 Slen
: constant Natural := Natural (String_Length
(S
));
21326 Options
: String (1 .. Slen
);
21332 C
:= Get_String_Char
(S
, Pos
(J
));
21333 exit when not In_Character_Range
(C
);
21334 Options
(J
) := Get_Character
(C
);
21336 -- If at end of string, set options. As per discussion
21337 -- above, no need to check for errors, since we issued
21338 -- them in the parser.
21341 if not Ignore_Style_Checks_Pragmas
then
21342 Set_Style_Check_Options
(Options
);
21352 elsif Nkind
(A
) = N_Identifier
then
21353 if Chars
(A
) = Name_All_Checks
then
21354 if not Ignore_Style_Checks_Pragmas
then
21356 Set_GNAT_Style_Check_Options
;
21358 Set_Default_Style_Check_Options
;
21362 elsif Chars
(A
) = Name_On
then
21363 if not Ignore_Style_Checks_Pragmas
then
21364 Style_Check
:= True;
21367 elsif Chars
(A
) = Name_Off
then
21368 if not Ignore_Style_Checks_Pragmas
then
21369 Style_Check
:= False;
21380 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21382 when Pragma_Subtitle
=>
21384 Check_Arg_Count
(1);
21385 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
21386 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21393 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21395 when Pragma_Suppress
=>
21396 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
21402 -- pragma Suppress_All;
21404 -- The only check made here is that the pragma has no arguments.
21405 -- There are no placement rules, and the processing required (setting
21406 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21407 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21408 -- then creates and inserts a pragma Suppress (All_Checks).
21410 when Pragma_Suppress_All
=>
21412 Check_Arg_Count
(0);
21414 -------------------------
21415 -- Suppress_Debug_Info --
21416 -------------------------
21418 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21420 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
21421 Nam_Id
: Entity_Id
;
21425 Check_Arg_Count
(1);
21426 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21427 Check_Arg_Is_Local_Name
(Arg1
);
21429 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21431 -- A pragma that applies to a Ghost entity becomes Ghost for the
21432 -- purposes of legality checks and removal of ignored Ghost code.
21434 Mark_Pragma_As_Ghost
(N
, Nam_Id
);
21435 Set_Debug_Info_Off
(Nam_Id
);
21436 end Suppress_Debug_Info
;
21438 ----------------------------------
21439 -- Suppress_Exception_Locations --
21440 ----------------------------------
21442 -- pragma Suppress_Exception_Locations;
21444 when Pragma_Suppress_Exception_Locations
=>
21446 Check_Arg_Count
(0);
21447 Check_Valid_Configuration_Pragma
;
21448 Exception_Locations_Suppressed
:= True;
21450 -----------------------------
21451 -- Suppress_Initialization --
21452 -----------------------------
21454 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21456 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
21462 Check_Arg_Count
(1);
21463 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21464 Check_Arg_Is_Local_Name
(Arg1
);
21466 E_Id
:= Get_Pragma_Arg
(Arg1
);
21468 if Etype
(E_Id
) = Any_Type
then
21472 E
:= Entity
(E_Id
);
21474 -- A pragma that applies to a Ghost entity becomes Ghost for the
21475 -- purposes of legality checks and removal of ignored Ghost code.
21477 Mark_Pragma_As_Ghost
(N
, E
);
21479 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
21481 ("pragma% requires variable, type or subtype", Arg1
);
21484 if Rep_Item_Too_Early
(E
, N
)
21486 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
21491 -- For incomplete/private type, set flag on full view
21493 if Is_Incomplete_Or_Private_Type
(E
) then
21494 if No
(Full_View
(Base_Type
(E
))) then
21496 ("argument of pragma% cannot be an incomplete type", Arg1
);
21498 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
21501 -- For first subtype, set flag on base type
21503 elsif Is_First_Subtype
(E
) then
21504 Set_Suppress_Initialization
(Base_Type
(E
));
21506 -- For other than first subtype, set flag on subtype or variable
21509 Set_Suppress_Initialization
(E
);
21517 -- pragma System_Name (DIRECT_NAME);
21519 -- Syntax check: one argument, which must be the identifier GNAT or
21520 -- the identifier GCC, no other identifiers are acceptable.
21522 when Pragma_System_Name
=>
21524 Check_No_Identifiers
;
21525 Check_Arg_Count
(1);
21526 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
21528 -----------------------------
21529 -- Task_Dispatching_Policy --
21530 -----------------------------
21532 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21534 when Pragma_Task_Dispatching_Policy
=> declare
21538 Check_Ada_83_Warning
;
21539 Check_Arg_Count
(1);
21540 Check_No_Identifiers
;
21541 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21542 Check_Valid_Configuration_Pragma
;
21543 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21544 DP
:= Fold_Upper
(Name_Buffer
(1));
21546 if Task_Dispatching_Policy
/= ' '
21547 and then Task_Dispatching_Policy
/= DP
21549 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21551 ("task dispatching policy incompatible with policy#");
21553 -- Set new policy, but always preserve System_Location since we
21554 -- like the error message with the run time name.
21557 Task_Dispatching_Policy
:= DP
;
21559 if Task_Dispatching_Policy_Sloc
/= System_Location
then
21560 Task_Dispatching_Policy_Sloc
:= Loc
;
21569 -- pragma Task_Info (EXPRESSION);
21571 when Pragma_Task_Info
=> Task_Info
: declare
21572 P
: constant Node_Id
:= Parent
(N
);
21578 if Warn_On_Obsolescent_Feature
then
21580 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21581 & "instead?j?", N
);
21584 if Nkind
(P
) /= N_Task_Definition
then
21585 Error_Pragma
("pragma% must appear in task definition");
21588 Check_No_Identifiers
;
21589 Check_Arg_Count
(1);
21591 Analyze_And_Resolve
21592 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
21594 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
21598 Ent
:= Defining_Identifier
(Parent
(P
));
21600 -- Check duplicate pragma before we chain the pragma in the Rep
21601 -- Item chain of Ent.
21604 (Ent
, Name_Task_Info
, Check_Parents
=> False)
21606 Error_Pragma
("duplicate pragma% not allowed");
21609 Record_Rep_Item
(Ent
, N
);
21616 -- pragma Task_Name (string_EXPRESSION);
21618 when Pragma_Task_Name
=> Task_Name
: declare
21619 P
: constant Node_Id
:= Parent
(N
);
21624 Check_No_Identifiers
;
21625 Check_Arg_Count
(1);
21627 Arg
:= Get_Pragma_Arg
(Arg1
);
21629 -- The expression is used in the call to Create_Task, and must be
21630 -- expanded there, not in the context of the current spec. It must
21631 -- however be analyzed to capture global references, in case it
21632 -- appears in a generic context.
21634 Preanalyze_And_Resolve
(Arg
, Standard_String
);
21636 if Nkind
(P
) /= N_Task_Definition
then
21640 Ent
:= Defining_Identifier
(Parent
(P
));
21642 -- Check duplicate pragma before we chain the pragma in the Rep
21643 -- Item chain of Ent.
21646 (Ent
, Name_Task_Name
, Check_Parents
=> False)
21648 Error_Pragma
("duplicate pragma% not allowed");
21651 Record_Rep_Item
(Ent
, N
);
21658 -- pragma Task_Storage (
21659 -- [Task_Type =>] LOCAL_NAME,
21660 -- [Top_Guard =>] static_integer_EXPRESSION);
21662 when Pragma_Task_Storage
=> Task_Storage
: declare
21663 Args
: Args_List
(1 .. 2);
21664 Names
: constant Name_List
(1 .. 2) := (
21668 Task_Type
: Node_Id
renames Args
(1);
21669 Top_Guard
: Node_Id
renames Args
(2);
21675 Gather_Associations
(Names
, Args
);
21677 if No
(Task_Type
) then
21679 ("missing task_type argument for pragma%");
21682 Check_Arg_Is_Local_Name
(Task_Type
);
21684 Ent
:= Entity
(Task_Type
);
21686 if not Is_Task_Type
(Ent
) then
21688 ("argument for pragma% must be task type", Task_Type
);
21691 if No
(Top_Guard
) then
21693 ("pragma% takes two arguments", Task_Type
);
21695 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
21698 Check_First_Subtype
(Task_Type
);
21700 if Rep_Item_Too_Late
(Ent
, N
) then
21709 -- pragma Test_Case
21710 -- ([Name =>] Static_String_EXPRESSION
21711 -- ,[Mode =>] MODE_TYPE
21712 -- [, Requires => Boolean_EXPRESSION]
21713 -- [, Ensures => Boolean_EXPRESSION]);
21715 -- MODE_TYPE ::= Nominal | Robustness
21717 -- Characteristics:
21719 -- * Analysis - The annotation undergoes initial checks to verify
21720 -- the legal placement and context. Secondary checks preanalyze the
21723 -- Analyze_Test_Case_In_Decl_Part
21725 -- * Expansion - None.
21727 -- * Template - The annotation utilizes the generic template of the
21728 -- related subprogram when it is:
21730 -- aspect on subprogram declaration
21732 -- The annotation must prepare its own template when it is:
21734 -- pragma on subprogram declaration
21736 -- * Globals - Capture of global references must occur after full
21739 -- * Instance - The annotation is instantiated automatically when
21740 -- the related generic subprogram is instantiated except for the
21741 -- "pragma on subprogram declaration" case. In that scenario the
21742 -- annotation must instantiate itself.
21744 when Pragma_Test_Case
=> Test_Case
: declare
21745 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
21746 -- Ensure that the contract of subprogram Subp_Id does not contain
21747 -- another Test_Case pragma with the same Name as the current one.
21749 -------------------------
21750 -- Check_Distinct_Name --
21751 -------------------------
21753 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
21754 Items
: constant Node_Id
:= Contract
(Subp_Id
);
21755 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
21759 -- Inspect all Test_Case pragma of the related subprogram
21760 -- looking for one with a duplicate "Name" argument.
21762 if Present
(Items
) then
21763 Prag
:= Contract_Test_Cases
(Items
);
21764 while Present
(Prag
) loop
21765 if Pragma_Name
(Prag
) = Name_Test_Case
21767 and then String_Equal
21768 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
21770 Error_Msg_Sloc
:= Sloc
(Prag
);
21771 Error_Pragma
("name for pragma % is already used #");
21774 Prag
:= Next_Pragma
(Prag
);
21777 end Check_Distinct_Name
;
21781 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
21784 Subp_Decl
: Node_Id
;
21785 Subp_Id
: Entity_Id
;
21787 -- Start of processing for Test_Case
21791 Check_At_Least_N_Arguments
(2);
21792 Check_At_Most_N_Arguments
(4);
21794 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
21798 Check_Optional_Identifier
(Arg1
, Name_Name
);
21799 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21803 Check_Optional_Identifier
(Arg2
, Name_Mode
);
21804 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
21806 -- Arguments "Requires" and "Ensures"
21808 if Present
(Arg3
) then
21809 if Present
(Arg4
) then
21810 Check_Identifier
(Arg3
, Name_Requires
);
21811 Check_Identifier
(Arg4
, Name_Ensures
);
21813 Check_Identifier_Is_One_Of
21814 (Arg3
, Name_Requires
, Name_Ensures
);
21818 -- Pragma Test_Case must be associated with a subprogram declared
21819 -- in a library-level package. First determine whether the current
21820 -- compilation unit is a legal context.
21822 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
21823 N_Generic_Package_Declaration
)
21827 -- Otherwise the placement is illegal
21831 ("pragma % must be specified within a package declaration");
21835 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
21837 -- Find the enclosing context
21839 Context
:= Parent
(Subp_Decl
);
21841 if Present
(Context
) then
21842 Context
:= Parent
(Context
);
21845 -- Verify the placement of the pragma
21847 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
21849 ("pragma % cannot be applied to abstract subprogram");
21852 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
21853 Error_Pragma
("pragma % cannot be applied to entry");
21856 -- The context is a [generic] subprogram declared at the top level
21857 -- of the [generic] package unit.
21859 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
21860 N_Subprogram_Declaration
)
21861 and then Present
(Context
)
21862 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
21863 N_Package_Declaration
)
21867 -- Otherwise the placement is illegal
21871 ("pragma % must be applied to a library-level subprogram "
21876 Subp_Id
:= Defining_Entity
(Subp_Decl
);
21878 -- Chain the pragma on the contract for further processing by
21879 -- Analyze_Test_Case_In_Decl_Part.
21881 Add_Contract_Item
(N
, Subp_Id
);
21883 -- A pragma that applies to a Ghost entity becomes Ghost for the
21884 -- purposes of legality checks and removal of ignored Ghost code.
21886 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
21888 -- Preanalyze the original aspect argument "Name" for ASIS or for
21889 -- a generic subprogram to properly capture global references.
21891 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
21892 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
21894 if Present
(Asp_Arg
) then
21896 -- The argument appears with an identifier in association
21899 if Nkind
(Asp_Arg
) = N_Component_Association
then
21900 Asp_Arg
:= Expression
(Asp_Arg
);
21903 Check_Expr_Is_OK_Static_Expression
21904 (Asp_Arg
, Standard_String
);
21908 -- Ensure that the all Test_Case pragmas of the related subprogram
21909 -- have distinct names.
21911 Check_Distinct_Name
(Subp_Id
);
21913 -- Fully analyze the pragma when it appears inside an entry
21914 -- or subprogram body because it cannot benefit from forward
21917 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
21919 N_Subprogram_Body_Stub
)
21921 -- The legality checks of pragma Test_Case are affected by the
21922 -- SPARK mode in effect and the volatility of the context.
21923 -- Analyze all pragmas in a specific order.
21925 Analyze_If_Present
(Pragma_SPARK_Mode
);
21926 Analyze_If_Present
(Pragma_Volatile_Function
);
21927 Analyze_Test_Case_In_Decl_Part
(N
);
21931 --------------------------
21932 -- Thread_Local_Storage --
21933 --------------------------
21935 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
21937 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
21943 Check_Arg_Count
(1);
21944 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21945 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21947 Id
:= Get_Pragma_Arg
(Arg1
);
21950 if not Is_Entity_Name
(Id
)
21951 or else Ekind
(Entity
(Id
)) /= E_Variable
21953 Error_Pragma_Arg
("local variable name required", Arg1
);
21958 -- A pragma that applies to a Ghost entity becomes Ghost for the
21959 -- purposes of legality checks and removal of ignored Ghost code.
21961 Mark_Pragma_As_Ghost
(N
, E
);
21963 if Rep_Item_Too_Early
(E
, N
)
21965 Rep_Item_Too_Late
(E
, N
)
21970 Set_Has_Pragma_Thread_Local_Storage
(E
);
21971 Set_Has_Gigi_Rep_Item
(E
);
21972 end Thread_Local_Storage
;
21978 -- pragma Time_Slice (static_duration_EXPRESSION);
21980 when Pragma_Time_Slice
=> Time_Slice
: declare
21986 Check_Arg_Count
(1);
21987 Check_No_Identifiers
;
21988 Check_In_Main_Program
;
21989 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
21991 if not Error_Posted
(Arg1
) then
21993 while Present
(Nod
) loop
21994 if Nkind
(Nod
) = N_Pragma
21995 and then Pragma_Name
(Nod
) = Name_Time_Slice
21997 Error_Msg_Name_1
:= Pname
;
21998 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
22005 -- Process only if in main unit
22007 if Get_Source_Unit
(Loc
) = Main_Unit
then
22008 Opt
.Time_Slice_Set
:= True;
22009 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
22011 if Val
<= Ureal_0
then
22012 Opt
.Time_Slice_Value
:= 0;
22014 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
22015 Opt
.Time_Slice_Value
:= 1_000_000_000
;
22018 Opt
.Time_Slice_Value
:=
22019 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
22028 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22030 -- TITLING_OPTION ::=
22031 -- [Title =>] STRING_LITERAL
22032 -- | [Subtitle =>] STRING_LITERAL
22034 when Pragma_Title
=> Title
: declare
22035 Args
: Args_List
(1 .. 2);
22036 Names
: constant Name_List
(1 .. 2) := (
22042 Gather_Associations
(Names
, Args
);
22045 for J
in 1 .. 2 loop
22046 if Present
(Args
(J
)) then
22047 Check_Arg_Is_OK_Static_Expression
22048 (Args
(J
), Standard_String
);
22053 ----------------------------
22054 -- Type_Invariant[_Class] --
22055 ----------------------------
22057 -- pragma Type_Invariant[_Class]
22058 -- ([Entity =>] type_LOCAL_NAME,
22059 -- [Check =>] EXPRESSION);
22061 when Pragma_Type_Invariant |
22062 Pragma_Type_Invariant_Class
=>
22063 Type_Invariant
: declare
22064 I_Pragma
: Node_Id
;
22067 Check_Arg_Count
(2);
22069 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22070 -- setting Class_Present for the Type_Invariant_Class case.
22072 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
22073 I_Pragma
:= New_Copy
(N
);
22074 Set_Pragma_Identifier
22075 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
22076 Rewrite
(N
, I_Pragma
);
22077 Set_Analyzed
(N
, False);
22079 end Type_Invariant
;
22081 ---------------------
22082 -- Unchecked_Union --
22083 ---------------------
22085 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22087 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
22088 Assoc
: constant Node_Id
:= Arg1
;
22089 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
22099 Check_No_Identifiers
;
22100 Check_Arg_Count
(1);
22101 Check_Arg_Is_Local_Name
(Arg1
);
22103 Find_Type
(Type_Id
);
22105 Typ
:= Entity
(Type_Id
);
22107 -- A pragma that applies to a Ghost entity becomes Ghost for the
22108 -- purposes of legality checks and removal of ignored Ghost code.
22110 Mark_Pragma_As_Ghost
(N
, Typ
);
22113 or else Rep_Item_Too_Early
(Typ
, N
)
22117 Typ
:= Underlying_Type
(Typ
);
22120 if Rep_Item_Too_Late
(Typ
, N
) then
22124 Check_First_Subtype
(Arg1
);
22126 -- Note remaining cases are references to a type in the current
22127 -- declarative part. If we find an error, we post the error on
22128 -- the relevant type declaration at an appropriate point.
22130 if not Is_Record_Type
(Typ
) then
22131 Error_Msg_N
("unchecked union must be record type", Typ
);
22134 elsif Is_Tagged_Type
(Typ
) then
22135 Error_Msg_N
("unchecked union must not be tagged", Typ
);
22138 elsif not Has_Discriminants
(Typ
) then
22140 ("unchecked union must have one discriminant", Typ
);
22143 -- Note: in previous versions of GNAT we used to check for limited
22144 -- types and give an error, but in fact the standard does allow
22145 -- Unchecked_Union on limited types, so this check was removed.
22147 -- Similarly, GNAT used to require that all discriminants have
22148 -- default values, but this is not mandated by the RM.
22150 -- Proceed with basic error checks completed
22153 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
22154 Clist
:= Component_List
(Tdef
);
22156 -- Check presence of component list and variant part
22158 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
22160 ("unchecked union must have variant part", Tdef
);
22164 -- Check components
22166 Comp
:= First
(Component_Items
(Clist
));
22167 while Present
(Comp
) loop
22168 Check_Component
(Comp
, Typ
);
22172 -- Check variant part
22174 Vpart
:= Variant_Part
(Clist
);
22176 Variant
:= First
(Variants
(Vpart
));
22177 while Present
(Variant
) loop
22178 Check_Variant
(Variant
, Typ
);
22183 Set_Is_Unchecked_Union
(Typ
);
22184 Set_Convention
(Typ
, Convention_C
);
22185 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
22186 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
22187 end Unchecked_Union
;
22189 ------------------------
22190 -- Unimplemented_Unit --
22191 ------------------------
22193 -- pragma Unimplemented_Unit;
22195 -- Note: this only gives an error if we are generating code, or if
22196 -- we are in a generic library unit (where the pragma appears in the
22197 -- body, not in the spec).
22199 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
22200 Cunitent
: constant Entity_Id
:=
22201 Cunit_Entity
(Get_Source_Unit
(Loc
));
22202 Ent_Kind
: constant Entity_Kind
:=
22207 Check_Arg_Count
(0);
22209 if Operating_Mode
= Generate_Code
22210 or else Ent_Kind
= E_Generic_Function
22211 or else Ent_Kind
= E_Generic_Procedure
22212 or else Ent_Kind
= E_Generic_Package
22214 Get_Name_String
(Chars
(Cunitent
));
22215 Set_Casing
(Mixed_Case
);
22216 Write_Str
(Name_Buffer
(1 .. Name_Len
));
22217 Write_Str
(" is not supported in this configuration");
22219 raise Unrecoverable_Error
;
22221 end Unimplemented_Unit
;
22223 ------------------------
22224 -- Universal_Aliasing --
22225 ------------------------
22227 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22229 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
22234 Check_Arg_Count
(1);
22235 Check_Optional_Identifier
(Arg2
, Name_Entity
);
22236 Check_Arg_Is_Local_Name
(Arg1
);
22237 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22239 if E_Id
= Any_Type
then
22241 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
22242 Error_Pragma_Arg
("pragma% requires type", Arg1
);
22245 -- A pragma that applies to a Ghost entity becomes Ghost for the
22246 -- purposes of legality checks and removal of ignored Ghost code.
22248 Mark_Pragma_As_Ghost
(N
, E_Id
);
22249 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
22250 Record_Rep_Item
(E_Id
, N
);
22251 end Universal_Alias
;
22253 --------------------
22254 -- Universal_Data --
22255 --------------------
22257 -- pragma Universal_Data [(library_unit_NAME)];
22259 when Pragma_Universal_Data
=>
22262 -- If this is a configuration pragma, then set the universal
22263 -- addressing option, otherwise confirm that the pragma satisfies
22264 -- the requirements of library unit pragma placement and leave it
22265 -- to the GNAAMP back end to detect the pragma (avoids transitive
22266 -- setting of the option due to withed units).
22268 if Is_Configuration_Pragma
then
22269 Universal_Addressing_On_AAMP
:= True;
22271 Check_Valid_Library_Unit_Pragma
;
22274 if not AAMP_On_Target
then
22275 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
22282 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22284 when Pragma_Unmodified
=> Unmodified
: declare
22286 Arg_Expr
: Node_Id
;
22287 Arg_Id
: Entity_Id
;
22289 Ghost_Error_Posted
: Boolean := False;
22290 -- Flag set when an error concerning the illegal mix of Ghost and
22291 -- non-Ghost variables is emitted.
22293 Ghost_Id
: Entity_Id
:= Empty
;
22294 -- The entity of the first Ghost variable encountered while
22295 -- processing the arguments of the pragma.
22299 Check_At_Least_N_Arguments
(1);
22301 -- Loop through arguments
22304 while Present
(Arg
) loop
22305 Check_No_Identifier
(Arg
);
22307 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
22308 -- in fact generate reference, so that the entity will have a
22309 -- reference, which will inhibit any warnings about it not
22310 -- being referenced, and also properly show up in the ali file
22311 -- as a reference. But this reference is recorded before the
22312 -- Has_Pragma_Unreferenced flag is set, so that no warning is
22313 -- generated for this reference.
22315 Check_Arg_Is_Local_Name
(Arg
);
22316 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22318 if Is_Entity_Name
(Arg_Expr
) then
22319 Arg_Id
:= Entity
(Arg_Expr
);
22321 if Is_Assignable
(Arg_Id
) then
22322 Set_Has_Pragma_Unmodified
(Arg_Id
);
22324 -- A pragma that applies to a Ghost entity becomes Ghost
22325 -- for the purposes of legality checks and removal of
22326 -- ignored Ghost code.
22328 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22330 -- Capture the entity of the first Ghost variable being
22331 -- processed for error detection purposes.
22333 if Is_Ghost_Entity
(Arg_Id
) then
22334 if No
(Ghost_Id
) then
22335 Ghost_Id
:= Arg_Id
;
22338 -- Otherwise the variable is non-Ghost. It is illegal
22339 -- to mix references to Ghost and non-Ghost entities
22342 elsif Present
(Ghost_Id
)
22343 and then not Ghost_Error_Posted
22345 Ghost_Error_Posted
:= True;
22347 Error_Msg_Name_1
:= Pname
;
22349 ("pragma % cannot mention ghost and non-ghost "
22352 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22353 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22355 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22356 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22359 -- Otherwise the pragma referenced an illegal entity
22363 ("pragma% can only be applied to a variable", Arg_Expr
);
22375 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22377 -- or when used in a context clause:
22379 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22381 when Pragma_Unreferenced
=> Unreferenced
: declare
22383 Arg_Expr
: Node_Id
;
22384 Arg_Id
: Entity_Id
;
22387 Ghost_Error_Posted
: Boolean := False;
22388 -- Flag set when an error concerning the illegal mix of Ghost and
22389 -- non-Ghost names is emitted.
22391 Ghost_Id
: Entity_Id
:= Empty
;
22392 -- The entity of the first Ghost name encountered while processing
22393 -- the arguments of the pragma.
22397 Check_At_Least_N_Arguments
(1);
22399 -- Check case of appearing within context clause
22401 if Is_In_Context_Clause
then
22403 -- The arguments must all be units mentioned in a with clause
22404 -- in the same context clause. Note we already checked (in
22405 -- Par.Prag) that the arguments are either identifiers or
22406 -- selected components.
22409 while Present
(Arg
) loop
22410 Citem
:= First
(List_Containing
(N
));
22411 while Citem
/= N
loop
22412 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22414 if Nkind
(Citem
) = N_With_Clause
22415 and then Same_Name
(Name
(Citem
), Arg_Expr
)
22417 Set_Has_Pragma_Unreferenced
22420 (Library_Unit
(Citem
))));
22421 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
22430 ("argument of pragma% is not withed unit", Arg
);
22436 -- Case of not in list of context items
22440 while Present
(Arg
) loop
22441 Check_No_Identifier
(Arg
);
22443 -- Note: the analyze call done by Check_Arg_Is_Local_Name
22444 -- will in fact generate reference, so that the entity will
22445 -- have a reference, which will inhibit any warnings about
22446 -- it not being referenced, and also properly show up in the
22447 -- ali file as a reference. But this reference is recorded
22448 -- before the Has_Pragma_Unreferenced flag is set, so that
22449 -- no warning is generated for this reference.
22451 Check_Arg_Is_Local_Name
(Arg
);
22452 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22454 if Is_Entity_Name
(Arg_Expr
) then
22455 Arg_Id
:= Entity
(Arg_Expr
);
22457 -- If the entity is overloaded, the pragma applies to the
22458 -- most recent overloading, as documented. In this case,
22459 -- name resolution does not generate a reference, so it
22460 -- must be done here explicitly.
22462 if Is_Overloaded
(Arg_Expr
) then
22463 Generate_Reference
(Arg_Id
, N
);
22466 Set_Has_Pragma_Unreferenced
(Arg_Id
);
22468 -- A pragma that applies to a Ghost entity becomes Ghost
22469 -- for the purposes of legality checks and removal of
22470 -- ignored Ghost code.
22472 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22474 -- Capture the entity of the first Ghost name being
22475 -- processed for error detection purposes.
22477 if Is_Ghost_Entity
(Arg_Id
) then
22478 if No
(Ghost_Id
) then
22479 Ghost_Id
:= Arg_Id
;
22482 -- Otherwise the name is non-Ghost. It is illegal to mix
22483 -- references to Ghost and non-Ghost entities
22486 elsif Present
(Ghost_Id
)
22487 and then not Ghost_Error_Posted
22489 Ghost_Error_Posted
:= True;
22491 Error_Msg_Name_1
:= Pname
;
22493 ("pragma % cannot mention ghost and non-ghost names",
22496 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22497 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22499 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22500 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22509 --------------------------
22510 -- Unreferenced_Objects --
22511 --------------------------
22513 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22515 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
22517 Arg_Expr
: Node_Id
;
22518 Arg_Id
: Entity_Id
;
22520 Ghost_Error_Posted
: Boolean := False;
22521 -- Flag set when an error concerning the illegal mix of Ghost and
22522 -- non-Ghost types is emitted.
22524 Ghost_Id
: Entity_Id
:= Empty
;
22525 -- The entity of the first Ghost type encountered while processing
22526 -- the arguments of the pragma.
22530 Check_At_Least_N_Arguments
(1);
22533 while Present
(Arg
) loop
22534 Check_No_Identifier
(Arg
);
22535 Check_Arg_Is_Local_Name
(Arg
);
22536 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22538 if Is_Entity_Name
(Arg_Expr
) then
22539 Arg_Id
:= Entity
(Arg_Expr
);
22541 if Is_Type
(Arg_Id
) then
22542 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
22544 -- A pragma that applies to a Ghost entity becomes Ghost
22545 -- for the purposes of legality checks and removal of
22546 -- ignored Ghost code.
22548 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22550 -- Capture the entity of the first Ghost type being
22551 -- processed for error detection purposes.
22553 if Is_Ghost_Entity
(Arg_Id
) then
22554 if No
(Ghost_Id
) then
22555 Ghost_Id
:= Arg_Id
;
22558 -- Otherwise the type is non-Ghost. It is illegal to mix
22559 -- references to Ghost and non-Ghost entities
22562 elsif Present
(Ghost_Id
)
22563 and then not Ghost_Error_Posted
22565 Ghost_Error_Posted
:= True;
22567 Error_Msg_Name_1
:= Pname
;
22569 ("pragma % cannot mention ghost and non-ghost types",
22572 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22573 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22575 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22576 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22580 ("argument for pragma% must be type or subtype", Arg
);
22584 ("argument for pragma% must be type or subtype", Arg
);
22589 end Unreferenced_Objects
;
22591 ------------------------------
22592 -- Unreserve_All_Interrupts --
22593 ------------------------------
22595 -- pragma Unreserve_All_Interrupts;
22597 when Pragma_Unreserve_All_Interrupts
=>
22599 Check_Arg_Count
(0);
22601 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
22602 Unreserve_All_Interrupts
:= True;
22609 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22611 when Pragma_Unsuppress
=>
22613 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
22615 ----------------------------
22616 -- Unevaluated_Use_Of_Old --
22617 ----------------------------
22619 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22621 when Pragma_Unevaluated_Use_Of_Old
=>
22623 Check_Arg_Count
(1);
22624 Check_No_Identifiers
;
22625 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
22627 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22628 -- a declarative part or a package spec.
22630 if not Is_Configuration_Pragma
then
22631 Check_Is_In_Decl_Part_Or_Package_Spec
;
22634 -- Store proper setting of Uneval_Old
22636 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22637 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
22639 -------------------
22640 -- Use_VADS_Size --
22641 -------------------
22643 -- pragma Use_VADS_Size;
22645 when Pragma_Use_VADS_Size
=>
22647 Check_Arg_Count
(0);
22648 Check_Valid_Configuration_Pragma
;
22649 Use_VADS_Size
:= True;
22651 ---------------------
22652 -- Validity_Checks --
22653 ---------------------
22655 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22657 when Pragma_Validity_Checks
=> Validity_Checks
: declare
22658 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22664 Check_Arg_Count
(1);
22665 Check_No_Identifiers
;
22667 -- Pragma always active unless in CodePeer or GNATprove modes,
22668 -- which use a fixed configuration of validity checks.
22670 if not (CodePeer_Mode
or GNATprove_Mode
) then
22671 if Nkind
(A
) = N_String_Literal
then
22675 Slen
: constant Natural := Natural (String_Length
(S
));
22676 Options
: String (1 .. Slen
);
22680 -- Couldn't we use a for loop here over Options'Range???
22684 C
:= Get_String_Char
(S
, Pos
(J
));
22686 -- This is a weird test, it skips setting validity
22687 -- checks entirely if any element of S is out of
22688 -- range of Character, what is that about ???
22690 exit when not In_Character_Range
(C
);
22691 Options
(J
) := Get_Character
(C
);
22694 Set_Validity_Check_Options
(Options
);
22702 elsif Nkind
(A
) = N_Identifier
then
22703 if Chars
(A
) = Name_All_Checks
then
22704 Set_Validity_Check_Options
("a");
22705 elsif Chars
(A
) = Name_On
then
22706 Validity_Checks_On
:= True;
22707 elsif Chars
(A
) = Name_Off
then
22708 Validity_Checks_On
:= False;
22712 end Validity_Checks
;
22718 -- pragma Volatile (LOCAL_NAME);
22720 when Pragma_Volatile
=>
22721 Process_Atomic_Independent_Shared_Volatile
;
22723 -------------------------
22724 -- Volatile_Components --
22725 -------------------------
22727 -- pragma Volatile_Components (array_LOCAL_NAME);
22729 -- Volatile is handled by the same circuit as Atomic_Components
22731 --------------------------
22732 -- Volatile_Full_Access --
22733 --------------------------
22735 -- pragma Volatile_Full_Access (LOCAL_NAME);
22737 when Pragma_Volatile_Full_Access
=>
22739 Process_Atomic_Independent_Shared_Volatile
;
22741 -----------------------
22742 -- Volatile_Function --
22743 -----------------------
22745 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22747 when Pragma_Volatile_Function
=> Volatile_Function
: declare
22748 Over_Id
: Entity_Id
;
22749 Spec_Id
: Entity_Id
;
22750 Subp_Decl
: Node_Id
;
22754 Check_No_Identifiers
;
22755 Check_At_Most_N_Arguments
(1);
22758 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
22760 -- Generic subprogram
22762 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
22765 -- Body acts as spec
22767 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
22768 and then No
(Corresponding_Spec
(Subp_Decl
))
22772 -- Body stub acts as spec
22774 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
22775 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
22781 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
22789 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
22791 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
22796 -- Chain the pragma on the contract for completeness
22798 Add_Contract_Item
(N
, Spec_Id
);
22800 -- The legality checks of pragma Volatile_Function are affected by
22801 -- the SPARK mode in effect. Analyze all pragmas in a specific
22804 Analyze_If_Present
(Pragma_SPARK_Mode
);
22806 -- A pragma that applies to a Ghost entity becomes Ghost for the
22807 -- purposes of legality checks and removal of ignored Ghost code.
22809 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
22811 -- A volatile function cannot override a non-volatile function
22812 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22813 -- in New_Overloaded_Entity, however at that point the pragma has
22814 -- not been processed yet.
22816 Over_Id
:= Overridden_Operation
(Spec_Id
);
22818 if Present
(Over_Id
)
22819 and then not Is_Volatile_Function
(Over_Id
)
22822 ("incompatible volatile function values in effect", Spec_Id
);
22824 Error_Msg_Sloc
:= Sloc
(Over_Id
);
22826 ("\& declared # with Volatile_Function value `False`",
22829 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
22831 ("\overridden # with Volatile_Function value `True`",
22835 -- Analyze the Boolean expression (if any)
22837 if Present
(Arg1
) then
22838 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
22840 end Volatile_Function
;
22842 ----------------------
22843 -- Warning_As_Error --
22844 ----------------------
22846 -- pragma Warning_As_Error (static_string_EXPRESSION);
22848 when Pragma_Warning_As_Error
=>
22850 Check_Arg_Count
(1);
22851 Check_No_Identifiers
;
22852 Check_Valid_Configuration_Pragma
;
22854 if not Is_Static_String_Expression
(Arg1
) then
22856 ("argument of pragma% must be static string expression",
22859 -- OK static string expression
22862 Acquire_Warning_Match_String
(Arg1
);
22863 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
22864 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
22865 new String'(Name_Buffer (1 .. Name_Len));
22872 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
22874 -- DETAILS ::= On | Off
22875 -- DETAILS ::= On | Off, local_NAME
22876 -- DETAILS ::= static_string_EXPRESSION
22877 -- DETAILS ::= On | Off, static_string_EXPRESSION
22879 -- TOOL_NAME ::= GNAT | GNATProve
22881 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
22883 -- Note: If the first argument matches an allowed tool name, it is
22884 -- always considered to be a tool name, even if there is a string
22885 -- variable of that name.
22887 -- Note if the second argument of DETAILS is a local_NAME then the
22888 -- second form is always understood. If the intention is to use
22889 -- the fourth form, then you can write NAME & "" to force the
22890 -- intepretation as a static_string_EXPRESSION.
22892 when Pragma_Warnings => Warnings : declare
22893 Reason : String_Id;
22897 Check_At_Least_N_Arguments (1);
22899 -- See if last argument is labeled Reason. If so, make sure we
22900 -- have a string literal or a concatenation of string literals,
22901 -- and acquire the REASON string. Then remove the REASON argument
22902 -- by decreasing Num_Args by one; Remaining processing looks only
22903 -- at first Num_Args arguments).
22906 Last_Arg : constant Node_Id :=
22907 Last (Pragma_Argument_Associations (N));
22910 if Nkind (Last_Arg) = N_Pragma_Argument_Association
22911 and then Chars (Last_Arg) = Name_Reason
22914 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
22915 Reason := End_String;
22916 Arg_Count := Arg_Count - 1;
22918 -- Not allowed in compiler units (bootstrap issues)
22920 Check_Compiler_Unit ("Reason for pragma Warnings", N);
22922 -- No REASON string, set null string as reason
22925 Reason := Null_String_Id;
22929 -- Now proceed with REASON taken care of and eliminated
22931 Check_No_Identifiers;
22933 -- If debug flag -gnatd.i is set, pragma is ignored
22935 if Debug_Flag_Dot_I then
22939 -- Process various forms of the pragma
22942 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
22943 Shifted_Args : List_Id;
22946 -- See if first argument is a tool name, currently either
22947 -- GNAT or GNATprove. If so, either ignore the pragma if the
22948 -- tool used does not match, or continue as if no tool name
22949 -- was given otherwise, by shifting the arguments.
22951 if Nkind (Argx) = N_Identifier
22952 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
22954 if Chars (Argx) = Name_Gnat then
22955 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
22956 Rewrite (N, Make_Null_Statement (Loc));
22961 elsif Chars (Argx) = Name_Gnatprove then
22962 if not GNATprove_Mode then
22963 Rewrite (N, Make_Null_Statement (Loc));
22969 raise Program_Error;
22972 -- At this point, the pragma Warnings applies to the tool,
22973 -- so continue with shifted arguments.
22975 Arg_Count := Arg_Count - 1;
22977 if Arg_Count = 1 then
22978 Shifted_Args := New_List (New_Copy (Arg2));
22979 elsif Arg_Count = 2 then
22980 Shifted_Args := New_List (New_Copy (Arg2),
22982 elsif Arg_Count = 3 then
22983 Shifted_Args := New_List (New_Copy (Arg2),
22987 raise Program_Error;
22992 Chars => Name_Warnings,
22993 Pragma_Argument_Associations => Shifted_Args));
22998 -- One argument case
23000 if Arg_Count = 1 then
23002 -- On/Off one argument case was processed by parser
23004 if Nkind (Argx) = N_Identifier
23005 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23009 -- One argument case must be ON/OFF or static string expr
23011 elsif not Is_Static_String_Expression (Arg1) then
23013 ("argument of pragma% must be On/Off or static string "
23014 & "expression", Arg1);
23016 -- One argument string expression case
23020 Lit : constant Node_Id := Expr_Value_S (Argx);
23021 Str : constant String_Id := Strval (Lit);
23022 Len : constant Nat := String_Length (Str);
23030 while J <= Len loop
23031 C := Get_String_Char (Str, J);
23032 OK := In_Character_Range (C);
23035 Chr := Get_Character (C);
23037 -- Dash case: only -Wxxx is accepted
23044 C := Get_String_Char (Str, J);
23045 Chr := Get_Character (C);
23046 exit when Chr = 'W
';
23051 elsif J < Len and then Chr = '.' then
23053 C := Get_String_Char (Str, J);
23054 Chr := Get_Character (C);
23056 if not Set_Dot_Warning_Switch (Chr) then
23058 ("invalid warning switch character "
23059 & '.' & Chr, Arg1);
23065 OK := Set_Warning_Switch (Chr);
23071 ("invalid warning switch character " & Chr,
23080 -- Two or more arguments (must be two)
23083 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23084 Check_Arg_Count (2);
23092 E_Id := Get_Pragma_Arg (Arg2);
23095 -- In the expansion of an inlined body, a reference to
23096 -- the formal may be wrapped in a conversion if the
23097 -- actual is a conversion. Retrieve the real entity name.
23099 if (In_Instance_Body or In_Inlined_Body)
23100 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23102 E_Id := Expression (E_Id);
23105 -- Entity name case
23107 if Is_Entity_Name (E_Id) then
23108 E := Entity (E_Id);
23115 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23118 -- For OFF case, make entry in warnings off
23119 -- pragma table for later processing. But we do
23120 -- not do that within an instance, since these
23121 -- warnings are about what is needed in the
23122 -- template, not an instance of it.
23124 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23125 and then Warn_On_Warnings_Off
23126 and then not In_Instance
23128 Warnings_Off_Pragmas.Append ((N, E, Reason));
23131 if Is_Enumeration_Type (E) then
23135 Lit := First_Literal (E);
23136 while Present (Lit) loop
23137 Set_Warnings_Off (Lit);
23138 Next_Literal (Lit);
23143 exit when No (Homonym (E));
23148 -- Error if not entity or static string expression case
23150 elsif not Is_Static_String_Expression (Arg2) then
23152 ("second argument of pragma% must be entity name "
23153 & "or static string expression", Arg2);
23155 -- Static string expression case
23158 Acquire_Warning_Match_String (Arg2);
23160 -- Note on configuration pragma case: If this is a
23161 -- configuration pragma, then for an OFF pragma, we
23162 -- just set Config True in the call, which is all
23163 -- that needs to be done. For the case of ON, this
23164 -- is normally an error, unless it is canceling the
23165 -- effect of a previous OFF pragma in the same file.
23166 -- In any other case, an error will be signalled (ON
23167 -- with no matching OFF).
23169 -- Note: We set Used if we are inside a generic to
23170 -- disable the test that the non-config case actually
23171 -- cancels a warning. That's because we can't be sure
23172 -- there isn't an instantiation in some other unit
23173 -- where a warning is suppressed.
23175 -- We could do a little better here by checking if the
23176 -- generic unit we are inside is public, but for now
23177 -- we don't bother with that refinement.
23179 if Chars (Argx) = Name_Off then
23180 Set_Specific_Warning_Off
23181 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23182 Config => Is_Configuration_Pragma,
23183 Used => Inside_A_Generic or else In_Instance);
23185 elsif Chars (Argx) = Name_On then
23186 Set_Specific_Warning_On
23187 (Loc, Name_Buffer (1 .. Name_Len), Err);
23191 ("??pragma Warnings On with no matching "
23192 & "Warnings Off", Loc);
23201 -------------------
23202 -- Weak_External --
23203 -------------------
23205 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23207 when Pragma_Weak_External => Weak_External : declare
23212 Check_Arg_Count (1);
23213 Check_Optional_Identifier (Arg1, Name_Entity);
23214 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23215 Ent := Entity (Get_Pragma_Arg (Arg1));
23217 if Rep_Item_Too_Early (Ent, N) then
23220 Ent := Underlying_Type (Ent);
23223 -- The only processing required is to link this item on to the
23224 -- list of rep items for the given entity. This is accomplished
23225 -- by the call to Rep_Item_Too_Late (when no error is detected
23226 -- and False is returned).
23228 if Rep_Item_Too_Late (Ent, N) then
23231 Set_Has_Gigi_Rep_Item (Ent);
23235 -----------------------------
23236 -- Wide_Character_Encoding --
23237 -----------------------------
23239 -- pragma Wide_Character_Encoding (IDENTIFIER);
23241 when Pragma_Wide_Character_Encoding =>
23244 -- Nothing to do, handled in parser. Note that we do not enforce
23245 -- configuration pragma placement, this pragma can appear at any
23246 -- place in the source, allowing mixed encodings within a single
23251 --------------------
23252 -- Unknown_Pragma --
23253 --------------------
23255 -- Should be impossible, since the case of an unknown pragma is
23256 -- separately processed before the case statement is entered.
23258 when Unknown_Pragma =>
23259 raise Program_Error;
23262 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23263 -- until AI is formally approved.
23265 -- Check_Order_Dependence;
23268 when Pragma_Exit => null;
23269 end Analyze_Pragma;
23271 ---------------------------------------------
23272 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23273 ---------------------------------------------
23275 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23277 Freeze_Id : Entity_Id := Empty)
23281 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23282 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23283 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23285 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23288 Disp_Typ : Entity_Id;
23289 Restore_Scope : Boolean := False;
23291 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23294 -- Do not analyze the pragma multiple times
23296 if Is_Analyzed_Pragma (N) then
23300 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23301 -- analysis of the pragma, the Ghost mode at point of declaration and
23302 -- point of analysis may not necessarely be the same. Use the mode in
23303 -- effect at the point of declaration.
23305 Set_Ghost_Mode (N);
23307 -- Ensure that the subprogram and its formals are visible when analyzing
23308 -- the expression of the pragma.
23310 if not In_Open_Scopes (Spec_Id) then
23311 Restore_Scope := True;
23312 Push_Scope (Spec_Id);
23314 if Is_Generic_Subprogram (Spec_Id) then
23315 Install_Generic_Formals (Spec_Id);
23317 Install_Formals (Spec_Id);
23321 Errors := Serious_Errors_Detected;
23322 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23324 -- Emit a clarification message when the expression contains at least
23325 -- one undefined reference, possibly due to contract "freezing".
23327 if Errors /= Serious_Errors_Detected
23328 and then Present (Freeze_Id)
23329 and then Has_Undefined_Reference (Expr)
23331 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23334 if Class_Present (N) then
23336 -- Verify that a class-wide condition is legal, i.e. the operation is
23337 -- a primitive of a tagged type. Note that a generic subprogram is
23338 -- not a primitive operation.
23340 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23342 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23343 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23345 if From_Aspect_Specification (N) then
23347 ("aspect % can only be specified for a primitive operation "
23348 & "of a tagged type", Corresponding_Aspect (N));
23350 -- The pragma is a source construct
23354 ("pragma % can only be specified for a primitive operation "
23355 & "of a tagged type", N);
23360 if Restore_Scope then
23364 -- Currently it is not possible to inline pre/postconditions on a
23365 -- subprogram subject to pragma Inline_Always.
23367 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23368 Ghost_Mode := Save_Ghost_Mode;
23370 Set_Is_Analyzed_Pragma (N);
23371 end Analyze_Pre_Post_Condition_In_Decl_Part;
23373 ------------------------------------------
23374 -- Analyze_Refined_Depends_In_Decl_Part --
23375 ------------------------------------------
23377 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23378 Body_Inputs : Elist_Id := No_Elist;
23379 Body_Outputs : Elist_Id := No_Elist;
23380 -- The inputs and outputs of the subprogram body synthesized from pragma
23381 -- Refined_Depends.
23383 Dependencies : List_Id := No_List;
23385 -- The corresponding Depends pragma along with its clauses
23387 Matched_Items : Elist_Id := No_Elist;
23388 -- A list containing the entities of all successfully matched items
23389 -- found in pragma Depends.
23391 Refinements : List_Id := No_List;
23392 -- The clauses of pragma Refined_Depends
23394 Spec_Id : Entity_Id;
23395 -- The entity of the subprogram subject to pragma Refined_Depends
23397 Spec_Inputs : Elist_Id := No_Elist;
23398 Spec_Outputs : Elist_Id := No_Elist;
23399 -- The inputs and outputs of the subprogram spec synthesized from pragma
23402 procedure Check_Dependency_Clause (Dep_Clause : Node_Id);
23403 -- Try to match a single dependency clause Dep_Clause against one or
23404 -- more refinement clauses found in list Refinements. Each successful
23405 -- match eliminates at least one refinement clause from Refinements.
23407 procedure Check_Output_States;
23408 -- Determine whether pragma Depends contains an output state with a
23409 -- visible refinement and if so, ensure that pragma Refined_Depends
23410 -- mentions all its constituents as outputs.
23412 procedure Normalize_Clauses (Clauses : List_Id);
23413 -- Given a list of dependence or refinement clauses Clauses, normalize
23414 -- each clause by creating multiple dependencies with exactly one input
23417 procedure Report_Extra_Clauses;
23418 -- Emit an error for each extra clause found in list Refinements
23420 -----------------------------
23421 -- Check_Dependency_Clause --
23422 -----------------------------
23424 procedure Check_Dependency_Clause (Dep_Clause : Node_Id) is
23425 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23426 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23428 function Is_In_Out_State_Clause return Boolean;
23429 -- Determine whether dependence clause Dep_Clause denotes an abstract
23430 -- state that depends on itself (State => State).
23432 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23433 -- Determine whether item Item denotes an abstract state with visible
23434 -- null refinement.
23436 procedure Match_Items
23437 (Dep_Item : Node_Id;
23438 Ref_Item : Node_Id;
23439 Matched : out Boolean);
23440 -- Try to match dependence item Dep_Item against refinement item
23441 -- Ref_Item. To match against a possible null refinement (see 2, 7),
23442 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23443 -- the following conformance scenarios is in effect:
23444 -- 1) Both items denote null
23445 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23446 -- 3) Both items denote attribute 'Result
23447 -- 4) Both items denote the same object
23448 -- 5) Both items denote the same formal parameter
23449 -- 6) Both items denote the same current instance of a type
23450 -- 7) Both items denote the same discriminant
23451 -- 8) Dep_Item is an abstract state with visible null refinement
23452 -- and Ref_Item denotes null.
23453 -- 9) Dep_Item is an abstract state with visible null refinement
23454 -- and Ref_Item is Empty (special case).
23455 -- 10) Dep_Item is an abstract state with visible non-null
23456 -- refinement and Ref_Item denotes one of its constituents.
23457 -- 11) Dep_Item is an abstract state without a visible refinement
23458 -- and Ref_Item denotes the same state.
23459 -- When scenario 10 is in effect, the entity of the abstract state
23460 -- denoted by Dep_Item is added to list Refined_States.
23462 procedure Record_Item
(Item_Id
: Entity_Id
);
23463 -- Store the entity of an item denoted by Item_Id in Matched_Items
23465 ----------------------------
23466 -- Is_In_Out_State_Clause --
23467 ----------------------------
23469 function Is_In_Out_State_Clause
return Boolean is
23470 Dep_Input_Id
: Entity_Id
;
23471 Dep_Output_Id
: Entity_Id
;
23474 -- Detect the following clause:
23477 if Is_Entity_Name
(Dep_Input
)
23478 and then Is_Entity_Name
(Dep_Output
)
23480 -- Handle abstract views generated for limited with clauses
23482 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
23483 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
23486 Ekind
(Dep_Input_Id
) = E_Abstract_State
23487 and then Dep_Input_Id
= Dep_Output_Id
;
23491 end Is_In_Out_State_Clause
;
23493 ---------------------------
23494 -- Is_Null_Refined_State --
23495 ---------------------------
23497 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
23498 Item_Id
: Entity_Id
;
23501 if Is_Entity_Name
(Item
) then
23503 -- Handle abstract views generated for limited with clauses
23505 Item_Id
:= Available_View
(Entity_Of
(Item
));
23508 Ekind
(Item_Id
) = E_Abstract_State
23509 and then Has_Null_Visible_Refinement
(Item_Id
);
23513 end Is_Null_Refined_State
;
23519 procedure Match_Items
23520 (Dep_Item
: Node_Id
;
23521 Ref_Item
: Node_Id
;
23522 Matched
: out Boolean)
23524 Dep_Item_Id
: Entity_Id
;
23525 Ref_Item_Id
: Entity_Id
;
23528 -- Assume that the two items do not match
23532 -- A null matches null or Empty (special case)
23534 if Nkind
(Dep_Item
) = N_Null
23535 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23539 -- Attribute 'Result matches attribute 'Result
23541 elsif Is_Attribute_Result
(Dep_Item
)
23542 and then Is_Attribute_Result
(Dep_Item
)
23546 -- Abstract states, current instances of concurrent types,
23547 -- discriminants, formal parameters and objects.
23549 elsif Is_Entity_Name
(Dep_Item
) then
23551 -- Handle abstract views generated for limited with clauses
23553 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
23555 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
23557 -- An abstract state with visible null refinement matches
23558 -- null or Empty (special case).
23560 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
23561 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23563 Record_Item
(Dep_Item_Id
);
23566 -- An abstract state with visible non-null refinement
23567 -- matches one of its constituents.
23569 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
23570 if Is_Entity_Name
(Ref_Item
) then
23571 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
23573 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
23576 and then Present
(Encapsulating_State
(Ref_Item_Id
))
23577 and then Encapsulating_State
(Ref_Item_Id
) =
23580 Record_Item
(Dep_Item_Id
);
23585 -- An abstract state without a visible refinement matches
23588 elsif Is_Entity_Name
(Ref_Item
)
23589 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23591 Record_Item
(Dep_Item_Id
);
23595 -- A current instance of a concurrent type, discriminant,
23596 -- formal parameter or an object matches itself.
23598 elsif Is_Entity_Name
(Ref_Item
)
23599 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23601 Record_Item
(Dep_Item_Id
);
23611 procedure Record_Item
(Item_Id
: Entity_Id
) is
23613 if not Contains
(Matched_Items
, Item_Id
) then
23614 Append_New_Elmt
(Item_Id
, Matched_Items
);
23620 Clause_Matched
: Boolean := False;
23621 Dummy
: Boolean := False;
23622 Inputs_Match
: Boolean;
23623 Next_Ref_Clause
: Node_Id
;
23624 Outputs_Match
: Boolean;
23625 Ref_Clause
: Node_Id
;
23626 Ref_Input
: Node_Id
;
23627 Ref_Output
: Node_Id
;
23629 -- Start of processing for Check_Dependency_Clause
23632 -- Do not perform this check in an instance because it was already
23633 -- performed successfully in the generic template.
23635 if Is_Generic_Instance
(Spec_Id
) then
23639 -- Examine all refinement clauses and compare them against the
23640 -- dependence clause.
23642 Ref_Clause
:= First
(Refinements
);
23643 while Present
(Ref_Clause
) loop
23644 Next_Ref_Clause
:= Next
(Ref_Clause
);
23646 -- Obtain the attributes of the current refinement clause
23648 Ref_Input
:= Expression
(Ref_Clause
);
23649 Ref_Output
:= First
(Choices
(Ref_Clause
));
23651 -- The current refinement clause matches the dependence clause
23652 -- when both outputs match and both inputs match. See routine
23653 -- Match_Items for all possible conformance scenarios.
23655 -- Depends Dep_Output => Dep_Input
23659 -- Refined_Depends Ref_Output => Ref_Input
23662 (Dep_Item
=> Dep_Input
,
23663 Ref_Item
=> Ref_Input
,
23664 Matched
=> Inputs_Match
);
23667 (Dep_Item
=> Dep_Output
,
23668 Ref_Item
=> Ref_Output
,
23669 Matched
=> Outputs_Match
);
23671 -- An In_Out state clause may be matched against a refinement with
23672 -- a null input or null output as long as the non-null side of the
23673 -- relation contains a valid constituent of the In_Out_State.
23675 if Is_In_Out_State_Clause
then
23677 -- Depends => (State => State)
23678 -- Refined_Depends => (null => Constit) -- OK
23681 and then not Outputs_Match
23682 and then Nkind
(Ref_Output
) = N_Null
23684 Outputs_Match
:= True;
23687 -- Depends => (State => State)
23688 -- Refined_Depends => (Constit => null) -- OK
23690 if not Inputs_Match
23691 and then Outputs_Match
23692 and then Nkind
(Ref_Input
) = N_Null
23694 Inputs_Match
:= True;
23698 -- The current refinement clause is legally constructed following
23699 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23700 -- the pool of candidates. The seach continues because a single
23701 -- dependence clause may have multiple matching refinements.
23703 if Inputs_Match
and Outputs_Match
then
23704 Clause_Matched
:= True;
23705 Remove
(Ref_Clause
);
23708 Ref_Clause
:= Next_Ref_Clause
;
23711 -- Depending on the order or composition of refinement clauses, an
23712 -- In_Out state clause may not be directly refinable.
23714 -- Depends => ((Output, State) => (Input, State))
23715 -- Refined_State => (State => (Constit_1, Constit_2))
23716 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23718 -- Matching normalized clause (State => State) fails because there is
23719 -- no direct refinement capable of satisfying this relation. Another
23720 -- similar case arises when clauses (Constit_1 => Input) and (Output
23721 -- => Constit_2) are matched first, leaving no candidates for clause
23722 -- (State => State). Both scenarios are legal as long as one of the
23723 -- previous clauses mentioned a valid constituent of State.
23725 if not Clause_Matched
23726 and then Is_In_Out_State_Clause
23728 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23730 Clause_Matched
:= True;
23733 -- A clause where the input is an abstract state with visible null
23734 -- refinement is implicitly matched when the output has already been
23735 -- matched in a previous clause.
23737 -- Depends => (Output => State) -- implicitly OK
23738 -- Refined_State => (State => null)
23739 -- Refined_Depends => (Output => ...)
23741 if not Clause_Matched
23742 and then Is_Null_Refined_State
(Dep_Input
)
23743 and then Is_Entity_Name
(Dep_Output
)
23745 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
23747 Clause_Matched
:= True;
23750 -- A clause where the output is an abstract state with visible null
23751 -- refinement is implicitly matched when the input has already been
23752 -- matched in a previous clause.
23754 -- Depends => (State => Input) -- implicitly OK
23755 -- Refined_State => (State => null)
23756 -- Refined_Depends => (... => Input)
23758 if not Clause_Matched
23759 and then Is_Null_Refined_State
(Dep_Output
)
23760 and then Is_Entity_Name
(Dep_Input
)
23762 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23764 Clause_Matched
:= True;
23767 -- At this point either all refinement clauses have been examined or
23768 -- pragma Refined_Depends contains a solitary null. Only an abstract
23769 -- state with null refinement can possibly match these cases.
23771 -- Depends => (State => null)
23772 -- Refined_State => (State => null)
23773 -- Refined_Depends => null -- OK
23775 if not Clause_Matched
then
23777 (Dep_Item
=> Dep_Input
,
23779 Matched
=> Inputs_Match
);
23782 (Dep_Item
=> Dep_Output
,
23784 Matched
=> Outputs_Match
);
23786 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
23789 -- If the contents of Refined_Depends are legal, then the current
23790 -- dependence clause should be satisfied either by an explicit match
23791 -- or by one of the special cases.
23793 if not Clause_Matched
then
23795 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
23796 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
23798 end Check_Dependency_Clause
;
23800 -------------------------
23801 -- Check_Output_States --
23802 -------------------------
23804 procedure Check_Output_States
is
23805 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
23806 -- Determine whether all constituents of state State_Id with visible
23807 -- refinement are used as outputs in pragma Refined_Depends. Emit an
23808 -- error if this is not the case.
23810 -----------------------------
23811 -- Check_Constituent_Usage --
23812 -----------------------------
23814 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
23815 Constits
: constant Elist_Id
:=
23816 Refinement_Constituents
(State_Id
);
23817 Constit_Elmt
: Elmt_Id
;
23818 Constit_Id
: Entity_Id
;
23819 Posted
: Boolean := False;
23822 if Present
(Constits
) then
23823 Constit_Elmt
:= First_Elmt
(Constits
);
23824 while Present
(Constit_Elmt
) loop
23825 Constit_Id
:= Node
(Constit_Elmt
);
23827 -- The constituent acts as an input (SPARK RM 7.2.5(3))
23829 if Present
(Body_Inputs
)
23830 and then Appears_In
(Body_Inputs
, Constit_Id
)
23832 Error_Msg_Name_1
:= Chars
(State_Id
);
23834 ("constituent & of state % must act as output in "
23835 & "dependence refinement", N
, Constit_Id
);
23837 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
23839 elsif No
(Body_Outputs
)
23840 or else not Appears_In
(Body_Outputs
, Constit_Id
)
23845 ("output state & must be replaced by all its "
23846 & "constituents in dependence refinement",
23851 ("\constituent & is missing in output list",
23855 Next_Elmt
(Constit_Elmt
);
23858 end Check_Constituent_Usage
;
23863 Item_Elmt
: Elmt_Id
;
23864 Item_Id
: Entity_Id
;
23866 -- Start of processing for Check_Output_States
23869 -- Do not perform this check in an instance because it was already
23870 -- performed successfully in the generic template.
23872 if Is_Generic_Instance
(Spec_Id
) then
23875 -- Inspect the outputs of pragma Depends looking for a state with a
23876 -- visible refinement.
23878 elsif Present
(Spec_Outputs
) then
23879 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
23880 while Present
(Item_Elmt
) loop
23881 Item
:= Node
(Item_Elmt
);
23883 -- Deal with the mixed nature of the input and output lists
23885 if Nkind
(Item
) = N_Defining_Identifier
then
23888 Item_Id
:= Available_View
(Entity_Of
(Item
));
23891 if Ekind
(Item_Id
) = E_Abstract_State
then
23893 -- The state acts as an input-output, skip it
23895 if Present
(Spec_Inputs
)
23896 and then Appears_In
(Spec_Inputs
, Item_Id
)
23900 -- Ensure that all of the constituents are utilized as
23901 -- outputs in pragma Refined_Depends.
23903 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
23904 Check_Constituent_Usage
(Item_Id
);
23908 Next_Elmt
(Item_Elmt
);
23911 end Check_Output_States
;
23913 -----------------------
23914 -- Normalize_Clauses --
23915 -----------------------
23917 procedure Normalize_Clauses
(Clauses
: List_Id
) is
23918 procedure Normalize_Inputs
(Clause
: Node_Id
);
23919 -- Normalize clause Clause by creating multiple clauses for each
23920 -- input item of Clause. It is assumed that Clause has exactly one
23921 -- output. The transformation is as follows:
23923 -- Output => (Input_1, Input_2) -- original
23925 -- Output => Input_1 -- normalizations
23926 -- Output => Input_2
23928 procedure Normalize_Outputs
(Clause
: Node_Id
);
23929 -- Normalize clause Clause by creating multiple clause for each
23930 -- output item of Clause. The transformation is as follows:
23932 -- (Output_1, Output_2) => Input -- original
23934 -- Output_1 => Input -- normalization
23935 -- Output_2 => Input
23937 ----------------------
23938 -- Normalize_Inputs --
23939 ----------------------
23941 procedure Normalize_Inputs
(Clause
: Node_Id
) is
23942 Inputs
: constant Node_Id
:= Expression
(Clause
);
23943 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
23944 Output
: constant List_Id
:= Choices
(Clause
);
23945 Last_Input
: Node_Id
;
23947 New_Clause
: Node_Id
;
23948 Next_Input
: Node_Id
;
23951 -- Normalization is performed only when the original clause has
23952 -- more than one input. Multiple inputs appear as an aggregate.
23954 if Nkind
(Inputs
) = N_Aggregate
then
23955 Last_Input
:= Last
(Expressions
(Inputs
));
23957 -- Create a new clause for each input
23959 Input
:= First
(Expressions
(Inputs
));
23960 while Present
(Input
) loop
23961 Next_Input
:= Next
(Input
);
23963 -- Unhook the current input from the original input list
23964 -- because it will be relocated to a new clause.
23968 -- Special processing for the last input. At this point the
23969 -- original aggregate has been stripped down to one element.
23970 -- Replace the aggregate by the element itself.
23972 if Input
= Last_Input
then
23973 Rewrite
(Inputs
, Input
);
23975 -- Generate a clause of the form:
23980 Make_Component_Association
(Loc
,
23981 Choices
=> New_Copy_List_Tree
(Output
),
23982 Expression
=> Input
);
23984 -- The new clause contains replicated content that has
23985 -- already been analyzed, mark the clause as analyzed.
23987 Set_Analyzed
(New_Clause
);
23988 Insert_After
(Clause
, New_Clause
);
23991 Input
:= Next_Input
;
23994 end Normalize_Inputs
;
23996 -----------------------
23997 -- Normalize_Outputs --
23998 -----------------------
24000 procedure Normalize_Outputs
(Clause
: Node_Id
) is
24001 Inputs
: constant Node_Id
:= Expression
(Clause
);
24002 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24003 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
24004 Last_Output
: Node_Id
;
24005 New_Clause
: Node_Id
;
24006 Next_Output
: Node_Id
;
24010 -- Multiple outputs appear as an aggregate. Nothing to do when
24011 -- the clause has exactly one output.
24013 if Nkind
(Outputs
) = N_Aggregate
then
24014 Last_Output
:= Last
(Expressions
(Outputs
));
24016 -- Create a clause for each output. Note that each time a new
24017 -- clause is created, the original output list slowly shrinks
24018 -- until there is one item left.
24020 Output
:= First
(Expressions
(Outputs
));
24021 while Present
(Output
) loop
24022 Next_Output
:= Next
(Output
);
24024 -- Unhook the output from the original output list as it
24025 -- will be relocated to a new clause.
24029 -- Special processing for the last output. At this point
24030 -- the original aggregate has been stripped down to one
24031 -- element. Replace the aggregate by the element itself.
24033 if Output
= Last_Output
then
24034 Rewrite
(Outputs
, Output
);
24037 -- Generate a clause of the form:
24038 -- (Output => Inputs)
24041 Make_Component_Association
(Loc
,
24042 Choices
=> New_List
(Output
),
24043 Expression
=> New_Copy_Tree
(Inputs
));
24045 -- The new clause contains replicated content that has
24046 -- already been analyzed. There is not need to reanalyze
24049 Set_Analyzed
(New_Clause
);
24050 Insert_After
(Clause
, New_Clause
);
24053 Output
:= Next_Output
;
24056 end Normalize_Outputs
;
24062 -- Start of processing for Normalize_Clauses
24065 Clause
:= First
(Clauses
);
24066 while Present
(Clause
) loop
24067 Normalize_Outputs
(Clause
);
24071 Clause
:= First
(Clauses
);
24072 while Present
(Clause
) loop
24073 Normalize_Inputs
(Clause
);
24076 end Normalize_Clauses
;
24078 --------------------------
24079 -- Report_Extra_Clauses --
24080 --------------------------
24082 procedure Report_Extra_Clauses
is
24086 -- Do not perform this check in an instance because it was already
24087 -- performed successfully in the generic template.
24089 if Is_Generic_Instance
(Spec_Id
) then
24092 elsif Present
(Refinements
) then
24093 Clause
:= First
(Refinements
);
24094 while Present
(Clause
) loop
24096 -- Do not complain about a null input refinement, since a null
24097 -- input legitimately matches anything.
24099 if Nkind
(Clause
) = N_Component_Association
24100 and then Nkind
(Expression
(Clause
)) = N_Null
24106 ("unmatched or extra clause in dependence refinement",
24113 end Report_Extra_Clauses
;
24117 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
24118 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
24119 Errors
: constant Nat
:= Serious_Errors_Detected
;
24125 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24128 -- Do not analyze the pragma multiple times
24130 if Is_Analyzed_Pragma
(N
) then
24134 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
24136 -- Use the anonymous object as the proper spec when Refined_Depends
24137 -- applies to the body of a single task type. The object carries the
24138 -- proper Chars as well as all non-refined versions of pragmas.
24140 if Is_Single_Concurrent_Type
(Spec_Id
) then
24141 Spec_Id
:= Anonymous_Object
(Spec_Id
);
24144 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
24146 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24147 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24149 if No
(Depends
) then
24151 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
24152 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
24156 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
24158 -- A null dependency relation renders the refinement useless because it
24159 -- cannot possibly mention abstract states with visible refinement. Note
24160 -- that the inverse is not true as states may be refined to null
24161 -- (SPARK RM 7.2.5(2)).
24163 if Nkind
(Deps
) = N_Null
then
24165 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
24166 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
24170 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24171 -- This ensures that the categorization of all refined dependency items
24172 -- is consistent with their role.
24174 Analyze_Depends_In_Decl_Part
(N
);
24176 -- Do not match dependencies against refinements if Refined_Depends is
24177 -- illegal to avoid emitting misleading error.
24179 if Serious_Errors_Detected
= Errors
then
24181 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24182 -- the inputs and outputs of the subprogram spec and body to verify
24183 -- the use of states with visible refinement and their constituents.
24185 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
24186 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
24188 Collect_Subprogram_Inputs_Outputs
24189 (Subp_Id
=> Spec_Id
,
24190 Synthesize
=> True,
24191 Subp_Inputs
=> Spec_Inputs
,
24192 Subp_Outputs
=> Spec_Outputs
,
24193 Global_Seen
=> Dummy
);
24195 Collect_Subprogram_Inputs_Outputs
24196 (Subp_Id
=> Body_Id
,
24197 Synthesize
=> True,
24198 Subp_Inputs
=> Body_Inputs
,
24199 Subp_Outputs
=> Body_Outputs
,
24200 Global_Seen
=> Dummy
);
24202 -- For an output state with a visible refinement, ensure that all
24203 -- constituents appear as outputs in the dependency refinement.
24205 Check_Output_States
;
24208 -- Matching is disabled in ASIS because clauses are not normalized as
24209 -- this is a tree altering activity similar to expansion.
24215 -- Multiple dependency clauses appear as component associations of an
24216 -- aggregate. Note that the clauses are copied because the algorithm
24217 -- modifies them and this should not be visible in Depends.
24219 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
24220 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
24221 Normalize_Clauses
(Dependencies
);
24223 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
24225 if Nkind
(Refs
) = N_Null
then
24226 Refinements
:= No_List
;
24228 -- Multiple dependency clauses appear as component associations of an
24229 -- aggregate. Note that the clauses are copied because the algorithm
24230 -- modifies them and this should not be visible in Refined_Depends.
24232 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
24233 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
24234 Normalize_Clauses
(Refinements
);
24237 -- At this point the clauses of pragmas Depends and Refined_Depends
24238 -- have been normalized into simple dependencies between one output
24239 -- and one input. Examine all clauses of pragma Depends looking for
24240 -- matching clauses in pragma Refined_Depends.
24242 Clause
:= First
(Dependencies
);
24243 while Present
(Clause
) loop
24244 Check_Dependency_Clause
(Clause
);
24248 if Serious_Errors_Detected
= Errors
then
24249 Report_Extra_Clauses
;
24254 Set_Is_Analyzed_Pragma
(N
);
24255 end Analyze_Refined_Depends_In_Decl_Part
;
24257 -----------------------------------------
24258 -- Analyze_Refined_Global_In_Decl_Part --
24259 -----------------------------------------
24261 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
24263 -- The corresponding Global pragma
24265 Has_In_State
: Boolean := False;
24266 Has_In_Out_State
: Boolean := False;
24267 Has_Out_State
: Boolean := False;
24268 Has_Proof_In_State
: Boolean := False;
24269 -- These flags are set when the corresponding Global pragma has a state
24270 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24273 Has_Null_State
: Boolean := False;
24274 -- This flag is set when the corresponding Global pragma has at least
24275 -- one state with a null refinement.
24277 In_Constits
: Elist_Id
:= No_Elist
;
24278 In_Out_Constits
: Elist_Id
:= No_Elist
;
24279 Out_Constits
: Elist_Id
:= No_Elist
;
24280 Proof_In_Constits
: Elist_Id
:= No_Elist
;
24281 -- These lists contain the entities of all Input, In_Out, Output and
24282 -- Proof_In constituents that appear in Refined_Global and participate
24283 -- in state refinement.
24285 In_Items
: Elist_Id
:= No_Elist
;
24286 In_Out_Items
: Elist_Id
:= No_Elist
;
24287 Out_Items
: Elist_Id
:= No_Elist
;
24288 Proof_In_Items
: Elist_Id
:= No_Elist
;
24289 -- These list contain the entities of all Input, In_Out, Output and
24290 -- Proof_In items defined in the corresponding Global pragma.
24292 Spec_Id
: Entity_Id
;
24293 -- The entity of the subprogram subject to pragma Refined_Global
24295 States
: Elist_Id
:= No_Elist
;
24296 -- A list of all states with visible refinement found in pragma Global
24298 procedure Check_In_Out_States
;
24299 -- Determine whether the corresponding Global pragma mentions In_Out
24300 -- states with visible refinement and if so, ensure that one of the
24301 -- following completions apply to the constituents of the state:
24302 -- 1) there is at least one constituent of mode In_Out
24303 -- 2) there is at least one Input and one Output constituent
24304 -- 3) not all constituents are present and one of them is of mode
24306 -- This routine may remove elements from In_Constits, In_Out_Constits,
24307 -- Out_Constits and Proof_In_Constits.
24309 procedure Check_Input_States
;
24310 -- Determine whether the corresponding Global pragma mentions Input
24311 -- states with visible refinement and if so, ensure that at least one of
24312 -- its constituents appears as an Input item in Refined_Global.
24313 -- This routine may remove elements from In_Constits, In_Out_Constits,
24314 -- Out_Constits and Proof_In_Constits.
24316 procedure Check_Output_States
;
24317 -- Determine whether the corresponding Global pragma mentions Output
24318 -- states with visible refinement and if so, ensure that all of its
24319 -- constituents appear as Output items in Refined_Global.
24320 -- This routine may remove elements from In_Constits, In_Out_Constits,
24321 -- Out_Constits and Proof_In_Constits.
24323 procedure Check_Proof_In_States
;
24324 -- Determine whether the corresponding Global pragma mentions Proof_In
24325 -- states with visible refinement and if so, ensure that at least one of
24326 -- its constituents appears as a Proof_In item in Refined_Global.
24327 -- This routine may remove elements from In_Constits, In_Out_Constits,
24328 -- Out_Constits and Proof_In_Constits.
24330 procedure Check_Refined_Global_List
24332 Global_Mode
: Name_Id
:= Name_Input
);
24333 -- Verify the legality of a single global list declaration. Global_Mode
24334 -- denotes the current mode in effect.
24336 procedure Collect_Global_Items
24338 Mode
: Name_Id
:= Name_Input
);
24339 -- Gather all input, in out, output and Proof_In items from node List
24340 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24341 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24342 -- and Has_Proof_In_State are set when there is at least one abstract
24343 -- state with visible refinement available in the corresponding mode.
24344 -- Flag Has_Null_State is set when at least state has a null refinement.
24345 -- Mode enotes the current global mode in effect.
24347 function Present_Then_Remove
24349 Item
: Entity_Id
) return Boolean;
24350 -- Search List for a particular entity Item. If Item has been found,
24351 -- remove it from List. This routine is used to strip lists In_Constits,
24352 -- In_Out_Constits and Out_Constits of valid constituents.
24354 procedure Report_Extra_Constituents
;
24355 -- Emit an error for each constituent found in lists In_Constits,
24356 -- In_Out_Constits and Out_Constits.
24358 -------------------------
24359 -- Check_In_Out_States --
24360 -------------------------
24362 procedure Check_In_Out_States
is
24363 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24364 -- Determine whether one of the following coverage scenarios is in
24366 -- 1) there is at least one constituent of mode In_Out or Output
24367 -- 2) there is at least one pair of constituents with modes Input
24368 -- and Output, or Proof_In and Output.
24369 -- 3) there is at least one constituent of mode Output and not all
24370 -- constituents are present.
24371 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24373 -----------------------------
24374 -- Check_Constituent_Usage --
24375 -----------------------------
24377 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24378 Constits
: constant Elist_Id
:=
24379 Refinement_Constituents
(State_Id
);
24380 Constit_Elmt
: Elmt_Id
;
24381 Constit_Id
: Entity_Id
;
24382 Has_Missing
: Boolean := False;
24383 In_Out_Seen
: Boolean := False;
24384 Input_Seen
: Boolean := False;
24385 Output_Seen
: Boolean := False;
24386 Proof_In_Seen
: Boolean := False;
24389 -- Process all the constituents of the state and note their modes
24390 -- within the global refinement.
24392 if Present
(Constits
) then
24393 Constit_Elmt
:= First_Elmt
(Constits
);
24394 while Present
(Constit_Elmt
) loop
24395 Constit_Id
:= Node
(Constit_Elmt
);
24397 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24398 Input_Seen
:= True;
24400 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
24401 In_Out_Seen
:= True;
24403 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24404 Output_Seen
:= True;
24406 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24408 Proof_In_Seen
:= True;
24411 Has_Missing
:= True;
24414 Next_Elmt
(Constit_Elmt
);
24418 -- An In_Out constituent is a valid completion
24420 if In_Out_Seen
then
24423 -- A pair of one Input/Proof_In and one Output constituent is a
24424 -- valid completion.
24426 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
24429 elsif Output_Seen
then
24431 -- A single Output constituent is a valid completion only when
24432 -- some of the other constituents are missing.
24434 if Has_Missing
then
24437 -- Otherwise all constituents are of mode Output
24441 ("global refinement of state & must include at least one "
24442 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24446 -- The state lacks a completion
24448 elsif not Input_Seen
24449 and not In_Out_Seen
24450 and not Output_Seen
24451 and not Proof_In_Seen
24454 ("missing global refinement of state &", N
, State_Id
);
24456 -- Otherwise the state has a malformed completion where at least
24457 -- one of the constituents has a different mode.
24461 ("global refinement of state & redefines the mode of its "
24462 & "constituents", N
, State_Id
);
24464 end Check_Constituent_Usage
;
24468 Item_Elmt
: Elmt_Id
;
24469 Item_Id
: Entity_Id
;
24471 -- Start of processing for Check_In_Out_States
24474 -- Do not perform this check in an instance because it was already
24475 -- performed successfully in the generic template.
24477 if Is_Generic_Instance
(Spec_Id
) then
24480 -- Inspect the In_Out items of the corresponding Global pragma
24481 -- looking for a state with a visible refinement.
24483 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
24484 Item_Elmt
:= First_Elmt
(In_Out_Items
);
24485 while Present
(Item_Elmt
) loop
24486 Item_Id
:= Node
(Item_Elmt
);
24488 -- Ensure that one of the three coverage variants is satisfied
24490 if Ekind
(Item_Id
) = E_Abstract_State
24491 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24493 Check_Constituent_Usage
(Item_Id
);
24496 Next_Elmt
(Item_Elmt
);
24499 end Check_In_Out_States
;
24501 ------------------------
24502 -- Check_Input_States --
24503 ------------------------
24505 procedure Check_Input_States
is
24506 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24507 -- Determine whether at least one constituent of state State_Id with
24508 -- visible refinement is used and has mode Input. Ensure that the
24509 -- remaining constituents do not have In_Out or Output modes. Emit an
24510 -- error if this is not the case (SPARK RM 7.2.4(5)).
24512 -----------------------------
24513 -- Check_Constituent_Usage --
24514 -----------------------------
24516 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24517 Constits
: constant Elist_Id
:=
24518 Refinement_Constituents
(State_Id
);
24519 Constit_Elmt
: Elmt_Id
;
24520 Constit_Id
: Entity_Id
;
24521 In_Seen
: Boolean := False;
24524 if Present
(Constits
) then
24525 Constit_Elmt
:= First_Elmt
(Constits
);
24526 while Present
(Constit_Elmt
) loop
24527 Constit_Id
:= Node
(Constit_Elmt
);
24529 -- At least one of the constituents appears as an Input
24531 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24534 -- A Proof_In constituent can refine an Input state as long
24535 -- as there is at least one Input constituent present.
24537 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24541 -- The constituent appears in the global refinement, but has
24542 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24544 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24545 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24547 Error_Msg_Name_1
:= Chars
(State_Id
);
24549 ("constituent & of state % must have mode `Input` in "
24550 & "global refinement", N
, Constit_Id
);
24553 Next_Elmt
(Constit_Elmt
);
24557 -- Not one of the constituents appeared as Input
24559 if not In_Seen
then
24561 ("global refinement of state & must include at least one "
24562 & "constituent of mode `Input`", N
, State_Id
);
24564 end Check_Constituent_Usage
;
24568 Item_Elmt
: Elmt_Id
;
24569 Item_Id
: Entity_Id
;
24571 -- Start of processing for Check_Input_States
24574 -- Do not perform this check in an instance because it was already
24575 -- performed successfully in the generic template.
24577 if Is_Generic_Instance
(Spec_Id
) then
24580 -- Inspect the Input items of the corresponding Global pragma looking
24581 -- for a state with a visible refinement.
24583 elsif Has_In_State
and then Present
(In_Items
) then
24584 Item_Elmt
:= First_Elmt
(In_Items
);
24585 while Present
(Item_Elmt
) loop
24586 Item_Id
:= Node
(Item_Elmt
);
24588 -- Ensure that at least one of the constituents is utilized and
24589 -- is of mode Input.
24591 if Ekind
(Item_Id
) = E_Abstract_State
24592 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24594 Check_Constituent_Usage
(Item_Id
);
24597 Next_Elmt
(Item_Elmt
);
24600 end Check_Input_States
;
24602 -------------------------
24603 -- Check_Output_States --
24604 -------------------------
24606 procedure Check_Output_States
is
24607 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24608 -- Determine whether all constituents of state State_Id with visible
24609 -- refinement are used and have mode Output. Emit an error if this is
24610 -- not the case (SPARK RM 7.2.4(5)).
24612 -----------------------------
24613 -- Check_Constituent_Usage --
24614 -----------------------------
24616 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24617 Constits
: constant Elist_Id
:=
24618 Refinement_Constituents
(State_Id
);
24619 Constit_Elmt
: Elmt_Id
;
24620 Constit_Id
: Entity_Id
;
24621 Posted
: Boolean := False;
24624 if Present
(Constits
) then
24625 Constit_Elmt
:= First_Elmt
(Constits
);
24626 while Present
(Constit_Elmt
) loop
24627 Constit_Id
:= Node
(Constit_Elmt
);
24629 if Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24632 -- The constituent appears in the global refinement, but has
24633 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
24635 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
24636 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24637 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24639 Error_Msg_Name_1
:= Chars
(State_Id
);
24641 ("constituent & of state % must have mode `Output` in "
24642 & "global refinement", N
, Constit_Id
);
24644 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24650 ("`Output` state & must be replaced by all its "
24651 & "constituents in global refinement", N
, State_Id
);
24655 ("\constituent & is missing in output list",
24659 Next_Elmt
(Constit_Elmt
);
24662 end Check_Constituent_Usage
;
24666 Item_Elmt
: Elmt_Id
;
24667 Item_Id
: Entity_Id
;
24669 -- Start of processing for Check_Output_States
24672 -- Do not perform this check in an instance because it was already
24673 -- performed successfully in the generic template.
24675 if Is_Generic_Instance
(Spec_Id
) then
24678 -- Inspect the Output items of the corresponding Global pragma
24679 -- looking for a state with a visible refinement.
24681 elsif Has_Out_State
and then Present
(Out_Items
) then
24682 Item_Elmt
:= First_Elmt
(Out_Items
);
24683 while Present
(Item_Elmt
) loop
24684 Item_Id
:= Node
(Item_Elmt
);
24686 -- Ensure that all of the constituents are utilized and they
24687 -- have mode Output.
24689 if Ekind
(Item_Id
) = E_Abstract_State
24690 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24692 Check_Constituent_Usage
(Item_Id
);
24695 Next_Elmt
(Item_Elmt
);
24698 end Check_Output_States
;
24700 ---------------------------
24701 -- Check_Proof_In_States --
24702 ---------------------------
24704 procedure Check_Proof_In_States
is
24705 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24706 -- Determine whether at least one constituent of state State_Id with
24707 -- visible refinement is used and has mode Proof_In. Ensure that the
24708 -- remaining constituents do not have Input, In_Out or Output modes.
24709 -- Emit an error of this is not the case (SPARK RM 7.2.4(5)).
24711 -----------------------------
24712 -- Check_Constituent_Usage --
24713 -----------------------------
24715 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24716 Constits
: constant Elist_Id
:=
24717 Refinement_Constituents
(State_Id
);
24718 Constit_Elmt
: Elmt_Id
;
24719 Constit_Id
: Entity_Id
;
24720 Proof_In_Seen
: Boolean := False;
24723 if Present
(Constits
) then
24724 Constit_Elmt
:= First_Elmt
(Constits
);
24725 while Present
(Constit_Elmt
) loop
24726 Constit_Id
:= Node
(Constit_Elmt
);
24728 -- At least one of the constituents appears as Proof_In
24730 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
24731 Proof_In_Seen
:= True;
24733 -- The constituent appears in the global refinement, but has
24734 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
24736 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
24737 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24738 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24740 Error_Msg_Name_1
:= Chars
(State_Id
);
24742 ("constituent & of state % must have mode `Proof_In` "
24743 & "in global refinement", N
, Constit_Id
);
24746 Next_Elmt
(Constit_Elmt
);
24750 -- Not one of the constituents appeared as Proof_In
24752 if not Proof_In_Seen
then
24754 ("global refinement of state & must include at least one "
24755 & "constituent of mode `Proof_In`", N
, State_Id
);
24757 end Check_Constituent_Usage
;
24761 Item_Elmt
: Elmt_Id
;
24762 Item_Id
: Entity_Id
;
24764 -- Start of processing for Check_Proof_In_States
24767 -- Do not perform this check in an instance because it was already
24768 -- performed successfully in the generic template.
24770 if Is_Generic_Instance
(Spec_Id
) then
24773 -- Inspect the Proof_In items of the corresponding Global pragma
24774 -- looking for a state with a visible refinement.
24776 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
24777 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
24778 while Present
(Item_Elmt
) loop
24779 Item_Id
:= Node
(Item_Elmt
);
24781 -- Ensure that at least one of the constituents is utilized and
24782 -- is of mode Proof_In
24784 if Ekind
(Item_Id
) = E_Abstract_State
24785 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24787 Check_Constituent_Usage
(Item_Id
);
24790 Next_Elmt
(Item_Elmt
);
24793 end Check_Proof_In_States
;
24795 -------------------------------
24796 -- Check_Refined_Global_List --
24797 -------------------------------
24799 procedure Check_Refined_Global_List
24801 Global_Mode
: Name_Id
:= Name_Input
)
24803 procedure Check_Refined_Global_Item
24805 Global_Mode
: Name_Id
);
24806 -- Verify the legality of a single global item declaration. Parameter
24807 -- Global_Mode denotes the current mode in effect.
24809 -------------------------------
24810 -- Check_Refined_Global_Item --
24811 -------------------------------
24813 procedure Check_Refined_Global_Item
24815 Global_Mode
: Name_Id
)
24817 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
24819 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
24820 -- Issue a common error message for all mode mismatches. Expect
24821 -- denotes the expected mode.
24823 -----------------------------
24824 -- Inconsistent_Mode_Error --
24825 -----------------------------
24827 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
24830 ("global item & has inconsistent modes", Item
, Item_Id
);
24832 Error_Msg_Name_1
:= Global_Mode
;
24833 Error_Msg_Name_2
:= Expect
;
24834 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
24835 end Inconsistent_Mode_Error
;
24837 -- Start of processing for Check_Refined_Global_Item
24840 -- When the state or object acts as a constituent of another
24841 -- state with a visible refinement, collect it for the state
24842 -- completeness checks performed later on. Note that the item
24843 -- acts as a constituent only when the encapsulating state is
24844 -- present in pragma Global.
24846 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
24847 and then Present
(Encapsulating_State
(Item_Id
))
24848 and then Has_Visible_Refinement
(Encapsulating_State
(Item_Id
))
24849 and then Contains
(States
, Encapsulating_State
(Item_Id
))
24851 if Global_Mode
= Name_Input
then
24852 Append_New_Elmt
(Item_Id
, In_Constits
);
24854 elsif Global_Mode
= Name_In_Out
then
24855 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
24857 elsif Global_Mode
= Name_Output
then
24858 Append_New_Elmt
(Item_Id
, Out_Constits
);
24860 elsif Global_Mode
= Name_Proof_In
then
24861 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
24864 -- When not a constituent, ensure that both occurrences of the
24865 -- item in pragmas Global and Refined_Global match.
24867 elsif Contains
(In_Items
, Item_Id
) then
24868 if Global_Mode
/= Name_Input
then
24869 Inconsistent_Mode_Error
(Name_Input
);
24872 elsif Contains
(In_Out_Items
, Item_Id
) then
24873 if Global_Mode
/= Name_In_Out
then
24874 Inconsistent_Mode_Error
(Name_In_Out
);
24877 elsif Contains
(Out_Items
, Item_Id
) then
24878 if Global_Mode
/= Name_Output
then
24879 Inconsistent_Mode_Error
(Name_Output
);
24882 elsif Contains
(Proof_In_Items
, Item_Id
) then
24885 -- The item does not appear in the corresponding Global pragma,
24886 -- it must be an extra (SPARK RM 7.2.4(3)).
24889 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
24891 end Check_Refined_Global_Item
;
24897 -- Start of processing for Check_Refined_Global_List
24900 -- Do not perform this check in an instance because it was already
24901 -- performed successfully in the generic template.
24903 if Is_Generic_Instance
(Spec_Id
) then
24906 elsif Nkind
(List
) = N_Null
then
24909 -- Single global item declaration
24911 elsif Nkind_In
(List
, N_Expanded_Name
,
24913 N_Selected_Component
)
24915 Check_Refined_Global_Item
(List
, Global_Mode
);
24917 -- Simple global list or moded global list declaration
24919 elsif Nkind
(List
) = N_Aggregate
then
24921 -- The declaration of a simple global list appear as a collection
24924 if Present
(Expressions
(List
)) then
24925 Item
:= First
(Expressions
(List
));
24926 while Present
(Item
) loop
24927 Check_Refined_Global_Item
(Item
, Global_Mode
);
24931 -- The declaration of a moded global list appears as a collection
24932 -- of component associations where individual choices denote
24935 elsif Present
(Component_Associations
(List
)) then
24936 Item
:= First
(Component_Associations
(List
));
24937 while Present
(Item
) loop
24938 Check_Refined_Global_List
24939 (List
=> Expression
(Item
),
24940 Global_Mode
=> Chars
(First
(Choices
(Item
))));
24948 raise Program_Error
;
24954 raise Program_Error
;
24956 end Check_Refined_Global_List
;
24958 --------------------------
24959 -- Collect_Global_Items --
24960 --------------------------
24962 procedure Collect_Global_Items
24964 Mode
: Name_Id
:= Name_Input
)
24966 procedure Collect_Global_Item
24968 Item_Mode
: Name_Id
);
24969 -- Add a single item to the appropriate list. Item_Mode denotes the
24970 -- current mode in effect.
24972 -------------------------
24973 -- Collect_Global_Item --
24974 -------------------------
24976 procedure Collect_Global_Item
24978 Item_Mode
: Name_Id
)
24980 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
24981 -- The above handles abstract views of variables and states built
24982 -- for limited with clauses.
24985 -- Signal that the global list contains at least one abstract
24986 -- state with a visible refinement. Note that the refinement may
24987 -- be null in which case there are no constituents.
24989 if Ekind
(Item_Id
) = E_Abstract_State
then
24990 if Has_Null_Visible_Refinement
(Item_Id
) then
24991 Has_Null_State
:= True;
24993 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
24994 Append_New_Elmt
(Item_Id
, States
);
24996 if Item_Mode
= Name_Input
then
24997 Has_In_State
:= True;
24998 elsif Item_Mode
= Name_In_Out
then
24999 Has_In_Out_State
:= True;
25000 elsif Item_Mode
= Name_Output
then
25001 Has_Out_State
:= True;
25002 elsif Item_Mode
= Name_Proof_In
then
25003 Has_Proof_In_State
:= True;
25008 -- Add the item to the proper list
25010 if Item_Mode
= Name_Input
then
25011 Append_New_Elmt
(Item_Id
, In_Items
);
25012 elsif Item_Mode
= Name_In_Out
then
25013 Append_New_Elmt
(Item_Id
, In_Out_Items
);
25014 elsif Item_Mode
= Name_Output
then
25015 Append_New_Elmt
(Item_Id
, Out_Items
);
25016 elsif Item_Mode
= Name_Proof_In
then
25017 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
25019 end Collect_Global_Item
;
25025 -- Start of processing for Collect_Global_Items
25028 if Nkind
(List
) = N_Null
then
25031 -- Single global item declaration
25033 elsif Nkind_In
(List
, N_Expanded_Name
,
25035 N_Selected_Component
)
25037 Collect_Global_Item
(List
, Mode
);
25039 -- Single global list or moded global list declaration
25041 elsif Nkind
(List
) = N_Aggregate
then
25043 -- The declaration of a simple global list appear as a collection
25046 if Present
(Expressions
(List
)) then
25047 Item
:= First
(Expressions
(List
));
25048 while Present
(Item
) loop
25049 Collect_Global_Item
(Item
, Mode
);
25053 -- The declaration of a moded global list appears as a collection
25054 -- of component associations where individual choices denote mode.
25056 elsif Present
(Component_Associations
(List
)) then
25057 Item
:= First
(Component_Associations
(List
));
25058 while Present
(Item
) loop
25059 Collect_Global_Items
25060 (List
=> Expression
(Item
),
25061 Mode
=> Chars
(First
(Choices
(Item
))));
25069 raise Program_Error
;
25072 -- To accomodate partial decoration of disabled SPARK features, this
25073 -- routine may be called with illegal input. If this is the case, do
25074 -- not raise Program_Error.
25079 end Collect_Global_Items
;
25081 -------------------------
25082 -- Present_Then_Remove --
25083 -------------------------
25085 function Present_Then_Remove
25087 Item
: Entity_Id
) return Boolean
25092 if Present
(List
) then
25093 Elmt
:= First_Elmt
(List
);
25094 while Present
(Elmt
) loop
25095 if Node
(Elmt
) = Item
then
25096 Remove_Elmt
(List
, Elmt
);
25105 end Present_Then_Remove
;
25107 -------------------------------
25108 -- Report_Extra_Constituents --
25109 -------------------------------
25111 procedure Report_Extra_Constituents
is
25112 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
25113 -- Emit an error for every element of List
25115 ---------------------------------------
25116 -- Report_Extra_Constituents_In_List --
25117 ---------------------------------------
25119 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
25120 Constit_Elmt
: Elmt_Id
;
25123 if Present
(List
) then
25124 Constit_Elmt
:= First_Elmt
(List
);
25125 while Present
(Constit_Elmt
) loop
25126 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
25127 Next_Elmt
(Constit_Elmt
);
25130 end Report_Extra_Constituents_In_List
;
25132 -- Start of processing for Report_Extra_Constituents
25135 -- Do not perform this check in an instance because it was already
25136 -- performed successfully in the generic template.
25138 if Is_Generic_Instance
(Spec_Id
) then
25142 Report_Extra_Constituents_In_List
(In_Constits
);
25143 Report_Extra_Constituents_In_List
(In_Out_Constits
);
25144 Report_Extra_Constituents_In_List
(Out_Constits
);
25145 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
25147 end Report_Extra_Constituents
;
25151 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25152 Errors
: constant Nat
:= Serious_Errors_Detected
;
25155 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25158 -- Do not analyze the pragma multiple times
25160 if Is_Analyzed_Pragma
(N
) then
25164 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25166 -- Use the anonymous object as the proper spec when Refined_Global
25167 -- applies to the body of a single task type. The object carries the
25168 -- proper Chars as well as all non-refined versions of pragmas.
25170 if Is_Single_Concurrent_Type
(Spec_Id
) then
25171 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25174 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25175 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
25177 -- The subprogram declaration lacks pragma Global. This renders
25178 -- Refined_Global useless as there is nothing to refine.
25180 if No
(Global
) then
25182 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25183 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
25187 -- Extract all relevant items from the corresponding Global pragma
25189 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
25191 -- Package and subprogram bodies are instantiated individually in
25192 -- a separate compiler pass. Due to this mode of instantiation, the
25193 -- refinement of a state may no longer be visible when a subprogram
25194 -- body contract is instantiated. Since the generic template is legal,
25195 -- do not perform this check in the instance to circumvent this oddity.
25197 if Is_Generic_Instance
(Spec_Id
) then
25200 -- Non-instance case
25203 -- The corresponding Global pragma must mention at least one state
25204 -- witha visible refinement at the point Refined_Global is processed.
25205 -- States with null refinements need Refined_Global pragma
25206 -- (SPARK RM 7.2.4(2)).
25208 if not Has_In_State
25209 and then not Has_In_Out_State
25210 and then not Has_Out_State
25211 and then not Has_Proof_In_State
25212 and then not Has_Null_State
25215 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25216 & "depend on abstract state with visible refinement"),
25220 -- The global refinement of inputs and outputs cannot be null when
25221 -- the corresponding Global pragma contains at least one item except
25222 -- in the case where we have states with null refinements.
25224 elsif Nkind
(Items
) = N_Null
25226 (Present
(In_Items
)
25227 or else Present
(In_Out_Items
)
25228 or else Present
(Out_Items
)
25229 or else Present
(Proof_In_Items
))
25230 and then not Has_Null_State
25233 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
25234 & "global items"), N
, Spec_Id
);
25239 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25240 -- This ensures that the categorization of all refined global items is
25241 -- consistent with their role.
25243 Analyze_Global_In_Decl_Part
(N
);
25245 -- Perform all refinement checks with respect to completeness and mode
25248 if Serious_Errors_Detected
= Errors
then
25249 Check_Refined_Global_List
(Items
);
25252 -- For Input states with visible refinement, at least one constituent
25253 -- must be used as an Input in the global refinement.
25255 if Serious_Errors_Detected
= Errors
then
25256 Check_Input_States
;
25259 -- Verify all possible completion variants for In_Out states with
25260 -- visible refinement.
25262 if Serious_Errors_Detected
= Errors
then
25263 Check_In_Out_States
;
25266 -- For Output states with visible refinement, all constituents must be
25267 -- used as Outputs in the global refinement.
25269 if Serious_Errors_Detected
= Errors
then
25270 Check_Output_States
;
25273 -- For Proof_In states with visible refinement, at least one constituent
25274 -- must be used as Proof_In in the global refinement.
25276 if Serious_Errors_Detected
= Errors
then
25277 Check_Proof_In_States
;
25280 -- Emit errors for all constituents that belong to other states with
25281 -- visible refinement that do not appear in Global.
25283 if Serious_Errors_Detected
= Errors
then
25284 Report_Extra_Constituents
;
25288 Set_Is_Analyzed_Pragma
(N
);
25289 end Analyze_Refined_Global_In_Decl_Part
;
25291 ----------------------------------------
25292 -- Analyze_Refined_State_In_Decl_Part --
25293 ----------------------------------------
25295 procedure Analyze_Refined_State_In_Decl_Part
25297 Freeze_Id
: Entity_Id
:= Empty
)
25299 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
25300 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25301 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
25303 Available_States
: Elist_Id
:= No_Elist
;
25304 -- A list of all abstract states defined in the package declaration that
25305 -- are available for refinement. The list is used to report unrefined
25308 Body_States
: Elist_Id
:= No_Elist
;
25309 -- A list of all hidden states that appear in the body of the related
25310 -- package. The list is used to report unused hidden states.
25312 Constituents_Seen
: Elist_Id
:= No_Elist
;
25313 -- A list that contains all constituents processed so far. The list is
25314 -- used to detect multiple uses of the same constituent.
25316 Freeze_Posted
: Boolean := False;
25317 -- A flag that controls the output of a freezing-related error (see use
25320 Refined_States_Seen
: Elist_Id
:= No_Elist
;
25321 -- A list that contains all refined states processed so far. The list is
25322 -- used to detect duplicate refinements.
25324 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
25325 -- Perform full analysis of a single refinement clause
25327 procedure Report_Unrefined_States
(States
: Elist_Id
);
25328 -- Emit errors for all unrefined abstract states found in list States
25330 -------------------------------
25331 -- Analyze_Refinement_Clause --
25332 -------------------------------
25334 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
25335 AR_Constit
: Entity_Id
:= Empty
;
25336 AW_Constit
: Entity_Id
:= Empty
;
25337 ER_Constit
: Entity_Id
:= Empty
;
25338 EW_Constit
: Entity_Id
:= Empty
;
25339 -- The entities of external constituents that contain one of the
25340 -- following enabled properties: Async_Readers, Async_Writers,
25341 -- Effective_Reads and Effective_Writes.
25343 External_Constit_Seen
: Boolean := False;
25344 -- Flag used to mark when at least one external constituent is part
25345 -- of the state refinement.
25347 Non_Null_Seen
: Boolean := False;
25348 Null_Seen
: Boolean := False;
25349 -- Flags used to detect multiple uses of null in a single clause or a
25350 -- mixture of null and non-null constituents.
25352 Part_Of_Constits
: Elist_Id
:= No_Elist
;
25353 -- A list of all candidate constituents subject to indicator Part_Of
25354 -- where the encapsulating state is the current state.
25357 State_Id
: Entity_Id
;
25358 -- The current state being refined
25360 procedure Analyze_Constituent
(Constit
: Node_Id
);
25361 -- Perform full analysis of a single constituent
25363 procedure Check_External_Property
25364 (Prop_Nam
: Name_Id
;
25366 Constit
: Entity_Id
);
25367 -- Determine whether a property denoted by name Prop_Nam is present
25368 -- in the refined state. Emit an error if this is not the case. Flag
25369 -- Enabled should be set when the property applies to the refined
25370 -- state. Constit denotes the constituent (if any) which introduces
25371 -- the property in the refinement.
25373 procedure Match_State
;
25374 -- Determine whether the state being refined appears in list
25375 -- Available_States. Emit an error when attempting to re-refine the
25376 -- state or when the state is not defined in the package declaration,
25377 -- otherwise remove the state from Available_States.
25379 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
25380 -- Emit errors for all unused Part_Of constituents in list Constits
25382 -------------------------
25383 -- Analyze_Constituent --
25384 -------------------------
25386 procedure Analyze_Constituent
(Constit
: Node_Id
) is
25387 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
25388 -- Determine whether constituent Constit denoted by its entity
25389 -- Constit_Id appears in Body_States. Emit an error when the
25390 -- constituent is not a valid hidden state of the related package
25391 -- or when it is used more than once. Otherwise remove the
25392 -- constituent from Body_States.
25394 -----------------------
25395 -- Match_Constituent --
25396 -----------------------
25398 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
25399 procedure Collect_Constituent
;
25400 -- Verify the legality of constituent Constit_Id and add it to
25401 -- the refinements of State_Id.
25403 -------------------------
25404 -- Collect_Constituent --
25405 -------------------------
25407 procedure Collect_Constituent
is
25408 Constits
: Elist_Id
;
25411 -- The Ghost policy in effect at the point of abstract state
25412 -- declaration and constituent must match (SPARK RM 6.9(15))
25414 Check_Ghost_Refinement
25415 (State
, State_Id
, Constit
, Constit_Id
);
25417 -- A synchronized state must be refined by a synchronized
25418 -- object or another synchronized state (SPARK RM 9.6).
25420 if Is_Synchronized_State
(State_Id
)
25421 and then not Is_Synchronized_Object
(Constit_Id
)
25422 and then not Is_Synchronized_State
(Constit_Id
)
25425 ("constituent of synchronized state & must be "
25426 & "synchronized", Constit
, State_Id
);
25429 -- Add the constituent to the list of processed items to aid
25430 -- with the detection of duplicates.
25432 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
25434 -- Collect the constituent in the list of refinement items
25435 -- and establish a relation between the refined state and
25438 Constits
:= Refinement_Constituents
(State_Id
);
25440 if No
(Constits
) then
25441 Constits
:= New_Elmt_List
;
25442 Set_Refinement_Constituents
(State_Id
, Constits
);
25445 Append_Elmt
(Constit_Id
, Constits
);
25446 Set_Encapsulating_State
(Constit_Id
, State_Id
);
25448 -- The state has at least one legal constituent, mark the
25449 -- start of the refinement region. The region ends when the
25450 -- body declarations end (see routine Analyze_Declarations).
25452 Set_Has_Visible_Refinement
(State_Id
);
25454 -- When the constituent is external, save its relevant
25455 -- property for further checks.
25457 if Async_Readers_Enabled
(Constit_Id
) then
25458 AR_Constit
:= Constit_Id
;
25459 External_Constit_Seen
:= True;
25462 if Async_Writers_Enabled
(Constit_Id
) then
25463 AW_Constit
:= Constit_Id
;
25464 External_Constit_Seen
:= True;
25467 if Effective_Reads_Enabled
(Constit_Id
) then
25468 ER_Constit
:= Constit_Id
;
25469 External_Constit_Seen
:= True;
25472 if Effective_Writes_Enabled
(Constit_Id
) then
25473 EW_Constit
:= Constit_Id
;
25474 External_Constit_Seen
:= True;
25476 end Collect_Constituent
;
25480 State_Elmt
: Elmt_Id
;
25482 -- Start of processing for Match_Constituent
25485 -- Detect a duplicate use of a constituent
25487 if Contains
(Constituents_Seen
, Constit_Id
) then
25489 ("duplicate use of constituent &", Constit
, Constit_Id
);
25493 -- The constituent is subject to a Part_Of indicator
25495 if Present
(Encapsulating_State
(Constit_Id
)) then
25496 if Encapsulating_State
(Constit_Id
) = State_Id
then
25497 Remove
(Part_Of_Constits
, Constit_Id
);
25498 Collect_Constituent
;
25500 -- The constituent is part of another state and is used
25501 -- incorrectly in the refinement of the current state.
25504 Error_Msg_Name_1
:= Chars
(State_Id
);
25506 ("& cannot act as constituent of state %",
25507 Constit
, Constit_Id
);
25509 ("\Part_Of indicator specifies encapsulator &",
25510 Constit
, Encapsulating_State
(Constit_Id
));
25513 -- The only other source of legal constituents is the body
25514 -- state space of the related package.
25517 if Present
(Body_States
) then
25518 State_Elmt
:= First_Elmt
(Body_States
);
25519 while Present
(State_Elmt
) loop
25521 -- Consume a valid constituent to signal that it has
25522 -- been encountered.
25524 if Node
(State_Elmt
) = Constit_Id
then
25525 Remove_Elmt
(Body_States
, State_Elmt
);
25526 Collect_Constituent
;
25530 Next_Elmt
(State_Elmt
);
25534 -- Constants are part of the hidden state of a package, but
25535 -- the compiler cannot determine whether they have variable
25536 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
25537 -- hidden state. Accept the constant quietly even if it is
25538 -- a visible state or lacks a Part_Of indicator.
25540 if Ekind
(Constit_Id
) = E_Constant
then
25541 Collect_Constituent
;
25543 -- If we get here, then the constituent is not a hidden
25544 -- state of the related package and may not be used in a
25545 -- refinement (SPARK RM 7.2.2(9)).
25548 Error_Msg_Name_1
:= Chars
(Spec_Id
);
25550 ("cannot use & in refinement, constituent is not a "
25551 & "hidden state of package %", Constit
, Constit_Id
);
25554 end Match_Constituent
;
25558 Constit_Id
: Entity_Id
;
25559 Constits
: Elist_Id
;
25561 -- Start of processing for Analyze_Constituent
25564 -- Detect multiple uses of null in a single refinement clause or a
25565 -- mixture of null and non-null constituents.
25567 if Nkind
(Constit
) = N_Null
then
25570 ("multiple null constituents not allowed", Constit
);
25572 elsif Non_Null_Seen
then
25574 ("cannot mix null and non-null constituents", Constit
);
25579 -- Collect the constituent in the list of refinement items
25581 Constits
:= Refinement_Constituents
(State_Id
);
25583 if No
(Constits
) then
25584 Constits
:= New_Elmt_List
;
25585 Set_Refinement_Constituents
(State_Id
, Constits
);
25588 Append_Elmt
(Constit
, Constits
);
25590 -- The state has at least one legal constituent, mark the
25591 -- start of the refinement region. The region ends when the
25592 -- body declarations end (see Analyze_Declarations).
25594 Set_Has_Visible_Refinement
(State_Id
);
25597 -- Non-null constituents
25600 Non_Null_Seen
:= True;
25604 ("cannot mix null and non-null constituents", Constit
);
25608 Resolve_State
(Constit
);
25610 -- Ensure that the constituent denotes a valid state or a
25611 -- whole object (SPARK RM 7.2.2(5)).
25613 if Is_Entity_Name
(Constit
) then
25614 Constit_Id
:= Entity_Of
(Constit
);
25616 -- When a constituent is declared after a subprogram body
25617 -- that caused "freezing" of the related contract where
25618 -- pragma Refined_State resides, the constituent appears
25619 -- undefined and carries Any_Id as its entity.
25621 -- package body Pack
25622 -- with Refined_State => (State => Constit)
25625 -- with Refined_Global => (Input => Constit)
25633 if Constit_Id
= Any_Id
then
25634 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
25636 -- Emit a specialized info message when the contract of
25637 -- the related package body was "frozen" by another body.
25638 -- Note that it is not possible to precisely identify why
25639 -- the constituent is undefined because it is not visible
25640 -- when pragma Refined_State is analyzed. This message is
25641 -- a reasonable approximation.
25643 if Present
(Freeze_Id
) and then not Freeze_Posted
then
25644 Freeze_Posted
:= True;
25646 Error_Msg_Name_1
:= Chars
(Body_Id
);
25647 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
25649 ("body & declared # freezes the contract of %",
25652 ("\all constituents must be declared before body #",
25655 -- A misplaced constituent is a critical error because
25656 -- pragma Refined_Depends or Refined_Global depends on
25657 -- the proper link between a state and a constituent.
25658 -- Stop the compilation, as this leads to a multitude
25659 -- of misleading cascaded errors.
25661 raise Program_Error
;
25664 -- The constituent is a valid state or object
25666 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
25670 Match_Constituent
(Constit_Id
);
25672 -- The variable may eventually become a constituent of a
25673 -- single protected/task type. Record the reference now
25674 -- and verify its legality when analyzing the contract of
25675 -- the variable (SPARK RM 9.3).
25677 if Ekind
(Constit_Id
) = E_Variable
then
25678 Record_Possible_Part_Of_Reference
25679 (Var_Id
=> Constit_Id
,
25683 -- Otherwise the constituent is illegal
25687 ("constituent & must denote object or state",
25688 Constit
, Constit_Id
);
25691 -- The constituent is illegal
25694 SPARK_Msg_N
("malformed constituent", Constit
);
25697 end Analyze_Constituent
;
25699 -----------------------------
25700 -- Check_External_Property --
25701 -----------------------------
25703 procedure Check_External_Property
25704 (Prop_Nam
: Name_Id
;
25706 Constit
: Entity_Id
)
25709 -- The property is missing in the declaration of the state, but
25710 -- a constituent is introducing it in the state refinement
25711 -- (SPARK RM 7.2.8(2)).
25713 if not Enabled
and then Present
(Constit
) then
25714 Error_Msg_Name_1
:= Prop_Nam
;
25715 Error_Msg_Name_2
:= Chars
(State_Id
);
25717 ("constituent & introduces external property % in refinement "
25718 & "of state %", State
, Constit
);
25720 Error_Msg_Sloc
:= Sloc
(State_Id
);
25722 ("\property is missing in abstract state declaration #",
25725 end Check_External_Property
;
25731 procedure Match_State
is
25732 State_Elmt
: Elmt_Id
;
25735 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
25737 if Contains
(Refined_States_Seen
, State_Id
) then
25739 ("duplicate refinement of state &", State
, State_Id
);
25743 -- Inspect the abstract states defined in the package declaration
25744 -- looking for a match.
25746 State_Elmt
:= First_Elmt
(Available_States
);
25747 while Present
(State_Elmt
) loop
25749 -- A valid abstract state is being refined in the body. Add
25750 -- the state to the list of processed refined states to aid
25751 -- with the detection of duplicate refinements. Remove the
25752 -- state from Available_States to signal that it has already
25755 if Node
(State_Elmt
) = State_Id
then
25756 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
25757 Remove_Elmt
(Available_States
, State_Elmt
);
25761 Next_Elmt
(State_Elmt
);
25764 -- If we get here, we are refining a state that is not defined in
25765 -- the package declaration.
25767 Error_Msg_Name_1
:= Chars
(Spec_Id
);
25769 ("cannot refine state, & is not defined in package %",
25773 --------------------------------
25774 -- Report_Unused_Constituents --
25775 --------------------------------
25777 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
25778 Constit_Elmt
: Elmt_Id
;
25779 Constit_Id
: Entity_Id
;
25780 Posted
: Boolean := False;
25783 if Present
(Constits
) then
25784 Constit_Elmt
:= First_Elmt
(Constits
);
25785 while Present
(Constit_Elmt
) loop
25786 Constit_Id
:= Node
(Constit_Elmt
);
25788 -- Generate an error message of the form:
25790 -- state ... has unused Part_Of constituents
25791 -- abstract state ... defined at ...
25792 -- constant ... defined at ...
25793 -- variable ... defined at ...
25798 ("state & has unused Part_Of constituents",
25802 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
25804 if Ekind
(Constit_Id
) = E_Abstract_State
then
25806 ("\abstract state & defined #", State
, Constit_Id
);
25808 elsif Ekind
(Constit_Id
) = E_Constant
then
25810 ("\constant & defined #", State
, Constit_Id
);
25813 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
25814 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
25817 Next_Elmt
(Constit_Elmt
);
25820 end Report_Unused_Constituents
;
25822 -- Local declarations
25824 Body_Ref
: Node_Id
;
25825 Body_Ref_Elmt
: Elmt_Id
;
25827 Extra_State
: Node_Id
;
25829 -- Start of processing for Analyze_Refinement_Clause
25832 -- A refinement clause appears as a component association where the
25833 -- sole choice is the state and the expressions are the constituents.
25834 -- This is a syntax error, always report.
25836 if Nkind
(Clause
) /= N_Component_Association
then
25837 Error_Msg_N
("malformed state refinement clause", Clause
);
25841 -- Analyze the state name of a refinement clause
25843 State
:= First
(Choices
(Clause
));
25846 Resolve_State
(State
);
25848 -- Ensure that the state name denotes a valid abstract state that is
25849 -- defined in the spec of the related package.
25851 if Is_Entity_Name
(State
) then
25852 State_Id
:= Entity_Of
(State
);
25854 -- When the abstract state is undefined, it appears as Any_Id. Do
25855 -- not continue with the analysis of the clause.
25857 if State_Id
= Any_Id
then
25860 -- Catch any attempts to re-refine a state or refine a state that
25861 -- is not defined in the package declaration.
25863 elsif Ekind
(State_Id
) = E_Abstract_State
then
25867 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
25871 -- References to a state with visible refinement are illegal.
25872 -- When nested packages are involved, detecting such references is
25873 -- tricky because pragma Refined_State is analyzed later than the
25874 -- offending pragma Depends or Global. References that occur in
25875 -- such nested context are stored in a list. Emit errors for all
25876 -- references found in Body_References (SPARK RM 6.1.4(8)).
25878 if Present
(Body_References
(State_Id
)) then
25879 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
25880 while Present
(Body_Ref_Elmt
) loop
25881 Body_Ref
:= Node
(Body_Ref_Elmt
);
25883 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
25884 Error_Msg_Sloc
:= Sloc
(State
);
25885 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
25887 Next_Elmt
(Body_Ref_Elmt
);
25891 -- The state name is illegal. This is a syntax error, always report.
25894 Error_Msg_N
("malformed state name in refinement clause", State
);
25898 -- A refinement clause may only refine one state at a time
25900 Extra_State
:= Next
(State
);
25902 if Present
(Extra_State
) then
25904 ("refinement clause cannot cover multiple states", Extra_State
);
25907 -- Replicate the Part_Of constituents of the refined state because
25908 -- the algorithm will consume items.
25910 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
25912 -- Analyze all constituents of the refinement. Multiple constituents
25913 -- appear as an aggregate.
25915 Constit
:= Expression
(Clause
);
25917 if Nkind
(Constit
) = N_Aggregate
then
25918 if Present
(Component_Associations
(Constit
)) then
25920 ("constituents of refinement clause must appear in "
25921 & "positional form", Constit
);
25923 else pragma Assert
(Present
(Expressions
(Constit
)));
25924 Constit
:= First
(Expressions
(Constit
));
25925 while Present
(Constit
) loop
25926 Analyze_Constituent
(Constit
);
25931 -- Various forms of a single constituent. Note that these may include
25932 -- malformed constituents.
25935 Analyze_Constituent
(Constit
);
25938 -- Verify that external constituents do not introduce new external
25939 -- property in the state refinement (SPARK RM 7.2.8(2)).
25941 if Is_External_State
(State_Id
) then
25942 Check_External_Property
25943 (Prop_Nam
=> Name_Async_Readers
,
25944 Enabled
=> Async_Readers_Enabled
(State_Id
),
25945 Constit
=> AR_Constit
);
25947 Check_External_Property
25948 (Prop_Nam
=> Name_Async_Writers
,
25949 Enabled
=> Async_Writers_Enabled
(State_Id
),
25950 Constit
=> AW_Constit
);
25952 Check_External_Property
25953 (Prop_Nam
=> Name_Effective_Reads
,
25954 Enabled
=> Effective_Reads_Enabled
(State_Id
),
25955 Constit
=> ER_Constit
);
25957 Check_External_Property
25958 (Prop_Nam
=> Name_Effective_Writes
,
25959 Enabled
=> Effective_Writes_Enabled
(State_Id
),
25960 Constit
=> EW_Constit
);
25962 -- When a refined state is not external, it should not have external
25963 -- constituents (SPARK RM 7.2.8(1)).
25965 elsif External_Constit_Seen
then
25967 ("non-external state & cannot contain external constituents in "
25968 & "refinement", State
, State_Id
);
25971 -- Ensure that all Part_Of candidate constituents have been mentioned
25972 -- in the refinement clause.
25974 Report_Unused_Constituents
(Part_Of_Constits
);
25975 end Analyze_Refinement_Clause
;
25977 -----------------------------
25978 -- Report_Unrefined_States --
25979 -----------------------------
25981 procedure Report_Unrefined_States
(States
: Elist_Id
) is
25982 State_Elmt
: Elmt_Id
;
25985 if Present
(States
) then
25986 State_Elmt
:= First_Elmt
(States
);
25987 while Present
(State_Elmt
) loop
25989 ("abstract state & must be refined", Node
(State_Elmt
));
25991 Next_Elmt
(State_Elmt
);
25994 end Report_Unrefined_States
;
25996 -- Local declarations
25998 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
26001 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26004 -- Do not analyze the pragma multiple times
26006 if Is_Analyzed_Pragma
(N
) then
26010 -- Replicate the abstract states declared by the package because the
26011 -- matching algorithm will consume states.
26013 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
26015 -- Gather all abstract states and objects declared in the visible
26016 -- state space of the package body. These items must be utilized as
26017 -- constituents in a state refinement.
26019 Body_States
:= Collect_Body_States
(Body_Id
);
26021 -- Multiple non-null state refinements appear as an aggregate
26023 if Nkind
(Clauses
) = N_Aggregate
then
26024 if Present
(Expressions
(Clauses
)) then
26026 ("state refinements must appear as component associations",
26029 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
26030 Clause
:= First
(Component_Associations
(Clauses
));
26031 while Present
(Clause
) loop
26032 Analyze_Refinement_Clause
(Clause
);
26037 -- Various forms of a single state refinement. Note that these may
26038 -- include malformed refinements.
26041 Analyze_Refinement_Clause
(Clauses
);
26044 -- List all abstract states that were left unrefined
26046 Report_Unrefined_States
(Available_States
);
26048 Set_Is_Analyzed_Pragma
(N
);
26049 end Analyze_Refined_State_In_Decl_Part
;
26051 ------------------------------------
26052 -- Analyze_Test_Case_In_Decl_Part --
26053 ------------------------------------
26055 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
26056 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26057 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26059 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
26060 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26061 -- denoted by Arg_Nam.
26063 ------------------------------
26064 -- Preanalyze_Test_Case_Arg --
26065 ------------------------------
26067 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
26071 -- Preanalyze the original aspect argument for ASIS or for a generic
26072 -- subprogram to properly capture global references.
26074 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
26078 Arg_Nam
=> Arg_Nam
,
26079 From_Aspect
=> True);
26081 if Present
(Arg
) then
26082 Preanalyze_Assert_Expression
26083 (Expression
(Arg
), Standard_Boolean
);
26087 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
26089 if Present
(Arg
) then
26090 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
26092 end Preanalyze_Test_Case_Arg
;
26096 Restore_Scope
: Boolean := False;
26098 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26101 -- Do not analyze the pragma multiple times
26103 if Is_Analyzed_Pragma
(N
) then
26107 -- Ensure that the formal parameters are visible when analyzing all
26108 -- clauses. This falls out of the general rule of aspects pertaining
26109 -- to subprogram declarations.
26111 if not In_Open_Scopes
(Spec_Id
) then
26112 Restore_Scope
:= True;
26113 Push_Scope
(Spec_Id
);
26115 if Is_Generic_Subprogram
(Spec_Id
) then
26116 Install_Generic_Formals
(Spec_Id
);
26118 Install_Formals
(Spec_Id
);
26122 Preanalyze_Test_Case_Arg
(Name_Requires
);
26123 Preanalyze_Test_Case_Arg
(Name_Ensures
);
26125 if Restore_Scope
then
26129 -- Currently it is not possible to inline pre/postconditions on a
26130 -- subprogram subject to pragma Inline_Always.
26132 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
26134 Set_Is_Analyzed_Pragma
(N
);
26135 end Analyze_Test_Case_In_Decl_Part
;
26141 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
26146 if Present
(List
) then
26147 Elmt
:= First_Elmt
(List
);
26148 while Present
(Elmt
) loop
26149 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
26152 Id
:= Entity_Of
(Node
(Elmt
));
26155 if Id
= Item_Id
then
26166 -----------------------------------
26167 -- Build_Pragma_Check_Equivalent --
26168 -----------------------------------
26170 function Build_Pragma_Check_Equivalent
26172 Subp_Id
: Entity_Id
:= Empty
;
26173 Inher_Id
: Entity_Id
:= Empty
) return Node_Id
26176 -- List containing the following mappings
26177 -- * Formal parameters of inherited subprogram Inher_Id and subprogram
26180 -- * The dispatching type of Inher_Id and the dispatching type of
26183 -- * Primitives of the dispatching type of Inher_Id and primitives of
26184 -- the dispatching type of Subp_Id.
26186 function Replace_Entity
(N
: Node_Id
) return Traverse_Result
;
26187 -- Replace reference to formal of inherited operation or to primitive
26188 -- operation of root type, with corresponding entity for derived type.
26190 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
26191 -- Detect whether node N references a formal parameter subject to
26192 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26193 -- to False to suppress the generation of a reference when analyzing
26196 --------------------
26197 -- Replace_Entity --
26198 --------------------
26200 function Replace_Entity
(N
: Node_Id
) return Traverse_Result
is
26205 if Nkind
(N
) = N_Identifier
26206 and then Present
(Entity
(N
))
26208 (Is_Formal
(Entity
(N
)) or else Is_Subprogram
(Entity
(N
)))
26210 (Nkind
(Parent
(N
)) /= N_Attribute_Reference
26211 or else Attribute_Name
(Parent
(N
)) /= Name_Class
)
26213 -- The replacement does not apply to dispatching calls within the
26214 -- condition, but only to calls whose static tag is that of the
26217 if Is_Subprogram
(Entity
(N
))
26218 and then Nkind
(Parent
(N
)) = N_Function_Call
26219 and then Present
(Controlling_Argument
(Parent
(N
)))
26224 -- Loop to find out if entity has a renaming
26227 Elmt
:= First_Elmt
(Map
);
26228 while Present
(Elmt
) loop
26229 if Node
(Elmt
) = Entity
(N
) then
26230 New_E
:= Node
(Next_Elmt
(Elmt
));
26237 if Present
(New_E
) then
26238 Rewrite
(N
, New_Occurrence_Of
(New_E
, Sloc
(N
)));
26241 -- Check that there are no calls left to abstract operations
26242 -- if the current subprogram is not abstract.
26244 if Nkind
(Parent
(N
)) = N_Function_Call
26245 and then N
= Name
(Parent
(N
))
26246 and then not Is_Abstract_Subprogram
(Subp_Id
)
26247 and then Is_Abstract_Subprogram
(Entity
(N
))
26249 Error_Msg_Sloc
:= Sloc
(Current_Scope
);
26251 ("cannot call abstract subprogram in inherited condition "
26252 & "for&#", N
, Current_Scope
);
26255 -- The whole expression will be reanalyzed
26257 elsif Nkind
(N
) in N_Has_Etype
then
26258 Set_Analyzed
(N
, False);
26262 end Replace_Entity
;
26264 ------------------------
26265 -- Suppress_Reference --
26266 ------------------------
26268 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
26269 Formal
: Entity_Id
;
26272 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26273 Formal
:= Entity
(N
);
26275 -- The formal parameter is subject to pragma Unreferenced.
26276 -- Prevent the generation of a reference by resetting the
26277 -- Comes_From_Source flag.
26279 if Is_Formal
(Formal
)
26280 and then Has_Pragma_Unreferenced
(Formal
)
26282 Set_Comes_From_Source
(N
, False);
26287 end Suppress_Reference
;
26289 procedure Replace_Condition_Entities
is
26290 new Traverse_Proc
(Replace_Entity
);
26292 procedure Suppress_References
is
26293 new Traverse_Proc
(Suppress_Reference
);
26297 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
26298 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
26299 Check_Prag
: Node_Id
;
26300 Inher_Formal
: Entity_Id
;
26303 Subp_Formal
: Entity_Id
;
26305 -- Start of processing for Build_Pragma_Check_Equivalent
26310 -- When the pre- or postcondition is inherited, map the formals of the
26311 -- inherited subprogram to those of the current subprogram. In addition,
26312 -- map primitive operations of the parent type into the corresponding
26313 -- primitive operations of the descendant.
26315 if Present
(Inher_Id
) then
26316 pragma Assert
(Present
(Subp_Id
));
26318 Map
:= New_Elmt_List
;
26320 -- Create a mapping <inherited formal> => <subprogram formal>
26322 Inher_Formal
:= First_Formal
(Inher_Id
);
26323 Subp_Formal
:= First_Formal
(Subp_Id
);
26324 while Present
(Inher_Formal
) and then Present
(Subp_Formal
) loop
26325 Append_Elmt
(Inher_Formal
, Map
);
26326 Append_Elmt
(Subp_Formal
, Map
);
26328 Next_Formal
(Inher_Formal
);
26329 Next_Formal
(Subp_Formal
);
26332 -- Map primitive operations of the parent type to the corresponding
26333 -- operations of the descendant. Note that the descendant type may
26334 -- not be frozen yet, so we cannot use the dispatch table directly.
26336 -- Note : the construction of the map involves a full traversal of
26337 -- the list of primitive operations, as well as a scan of the
26338 -- declarations in the scope of the operation. Given that class-wide
26339 -- conditions are typically short expressions, it might be much more
26340 -- efficient to collect the identifiers in the expression first, and
26341 -- then determine the ones that have to be mapped. Optimization ???
26343 Primitive_Mapping
: declare
26344 function Overridden_Ancestor
(S
: Entity_Id
) return Entity_Id
;
26345 -- Given the controlling type of the overridden operation and a
26346 -- primitive of the current type, find the corresponding operation
26347 -- of the parent type.
26349 -------------------------
26350 -- Overridden_Ancestor --
26351 -------------------------
26353 function Overridden_Ancestor
(S
: Entity_Id
) return Entity_Id
is
26358 while Present
(Overridden_Operation
(Anc
)) loop
26359 exit when Scope
(Anc
) = Scope
(Inher_Id
);
26360 Anc
:= Overridden_Operation
(Anc
);
26364 end Overridden_Ancestor
;
26368 Old_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Inher_Id
);
26369 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp_Id
);
26371 Old_Elmt
: Elmt_Id
;
26372 Old_Prim
: Entity_Id
;
26375 -- Start of processing for Primitive_Mapping
26378 Decl
:= First
(List_Containing
(Unit_Declaration_Node
(Subp_Id
)));
26380 -- Look for primitive operations of the current type that have
26381 -- overridden an operation of the type related to the original
26382 -- class-wide precondition. There may be several intermediate
26383 -- overridings between them.
26385 while Present
(Decl
) loop
26386 if Nkind
(Decl
) = N_Subprogram_Declaration
then
26387 Prim
:= Defining_Entity
(Decl
);
26389 if Is_Subprogram
(Prim
)
26390 and then Present
(Overridden_Operation
(Prim
))
26391 and then Find_Dispatching_Type
(Prim
) = Typ
26393 Old_Prim
:= Overridden_Ancestor
(Prim
);
26395 Append_Elmt
(Old_Prim
, Map
);
26396 Append_Elmt
(Prim
, Map
);
26403 -- Now examine inherited operations. These do not override, but
26404 -- have an alias, which is the entity used in a call. In turn
26405 -- that alias may be inherited or comes from source, in which
26406 -- case it may override an earlier operation. We only need to
26407 -- examine inherited functions, that may appear within the
26408 -- inherited expression.
26410 Prim
:= First_Entity
(Scope
(Subp_Id
));
26411 while Present
(Prim
) loop
26412 if not Comes_From_Source
(Prim
)
26413 and then Ekind
(Prim
) = E_Function
26414 and then Present
(Alias
(Prim
))
26416 Old_Prim
:= Alias
(Prim
);
26418 if Comes_From_Source
(Old_Prim
) then
26419 Old_Prim
:= Overridden_Ancestor
(Old_Prim
);
26422 while Present
(Alias
(Old_Prim
))
26423 and then Scope
(Old_Prim
) /= Scope
(Inher_Id
)
26425 Old_Prim
:= Alias
(Old_Prim
);
26427 if Comes_From_Source
(Old_Prim
) then
26428 Old_Prim
:= Overridden_Ancestor
(Old_Prim
);
26434 Append_Elmt
(Old_Prim
, Map
);
26435 Append_Elmt
(Prim
, Map
);
26438 Next_Entity
(Prim
);
26441 -- If the parent operation is an interface operation, the
26442 -- overriding indicator is not present. Instead, we get from
26443 -- the interface operation the primitive of the current type
26444 -- that implements it.
26446 if Is_Interface
(Old_Typ
) then
26447 Old_Elmt
:= First_Elmt
(Collect_Primitive_Operations
(Old_Typ
));
26448 while Present
(Old_Elmt
) loop
26449 Old_Prim
:= Node
(Old_Elmt
);
26450 Prim
:= Find_Primitive_Covering_Interface
(Typ
, Old_Prim
);
26452 if Present
(Prim
) then
26453 Append_Elmt
(Old_Prim
, Map
);
26454 Append_Elmt
(Prim
, Map
);
26457 Next_Elmt
(Old_Elmt
);
26461 if Map
/= No_Elist
then
26462 Append_Elmt
(Old_Typ
, Map
);
26463 Append_Elmt
(Typ
, Map
);
26465 end Primitive_Mapping
;
26468 -- Copy the original pragma while performing substitutions (if
26471 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
26473 if Map
/= No_Elist
then
26474 Replace_Condition_Entities
(Check_Prag
);
26477 -- Mark the pragma as being internally generated and reset the Analyzed
26480 Set_Analyzed
(Check_Prag
, False);
26481 Set_Comes_From_Source
(Check_Prag
, False);
26482 Set_Class_Present
(Check_Prag
, False);
26484 -- The tree of the original pragma may contain references to the
26485 -- formal parameters of the related subprogram. At the same time
26486 -- the corresponding body may mark the formals as unreferenced:
26488 -- procedure Proc (Formal : ...)
26489 -- with Pre => Formal ...;
26491 -- procedure Proc (Formal : ...) is
26492 -- pragma Unreferenced (Formal);
26495 -- This creates problems because all pragma Check equivalents are
26496 -- analyzed at the end of the body declarations. Since all source
26497 -- references have already been accounted for, reset any references
26498 -- to such formals in the generated pragma Check equivalent.
26500 Suppress_References
(Check_Prag
);
26502 if Present
(Corresponding_Aspect
(Prag
)) then
26503 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
26508 -- Convert the copy into pragma Check by correcting the name and adding
26509 -- a check_kind argument.
26511 Set_Pragma_Identifier
26512 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
26514 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
26515 Make_Pragma_Argument_Association
(Loc
,
26516 Expression
=> Make_Identifier
(Loc
, Nam
)));
26518 -- Update the error message when the pragma is inherited
26520 if Present
(Inher_Id
) then
26521 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
26523 if Chars
(Msg_Arg
) = Name_Message
then
26524 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
26526 -- Insert "inherited" to improve the error message
26528 if Name_Buffer
(1 .. 8) = "failed p" then
26529 Insert_Str_In_Name_Buffer
("inherited ", 8);
26530 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
26536 end Build_Pragma_Check_Equivalent
;
26538 -----------------------------
26539 -- Check_Applicable_Policy --
26540 -----------------------------
26542 procedure Check_Applicable_Policy
(N
: Node_Id
) is
26546 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
26549 -- No effect if not valid assertion kind name
26551 if not Is_Valid_Assertion_Kind
(Ename
) then
26555 -- Loop through entries in check policy list
26557 PP
:= Opt
.Check_Policy_List
;
26558 while Present
(PP
) loop
26560 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
26561 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
26565 or else Pnm
= Name_Assertion
26566 or else (Pnm
= Name_Statement_Assertions
26567 and then Nam_In
(Ename
, Name_Assert
,
26568 Name_Assert_And_Cut
,
26570 Name_Loop_Invariant
,
26571 Name_Loop_Variant
))
26573 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
26576 when Name_Off | Name_Ignore
=>
26577 Set_Is_Ignored
(N
, True);
26578 Set_Is_Checked
(N
, False);
26580 when Name_On | Name_Check
=>
26581 Set_Is_Checked
(N
, True);
26582 Set_Is_Ignored
(N
, False);
26584 when Name_Disable
=>
26585 Set_Is_Ignored
(N
, True);
26586 Set_Is_Checked
(N
, False);
26587 Set_Is_Disabled
(N
, True);
26589 -- That should be exhaustive, the null here is a defence
26590 -- against a malformed tree from previous errors.
26599 PP
:= Next_Pragma
(PP
);
26603 -- If there are no specific entries that matched, then we let the
26604 -- setting of assertions govern. Note that this provides the needed
26605 -- compatibility with the RM for the cases of assertion, invariant,
26606 -- precondition, predicate, and postcondition.
26608 if Assertions_Enabled
then
26609 Set_Is_Checked
(N
, True);
26610 Set_Is_Ignored
(N
, False);
26612 Set_Is_Checked
(N
, False);
26613 Set_Is_Ignored
(N
, True);
26615 end Check_Applicable_Policy
;
26617 -------------------------------
26618 -- Check_External_Properties --
26619 -------------------------------
26621 procedure Check_External_Properties
26629 -- All properties enabled
26631 if AR
and AW
and ER
and EW
then
26634 -- Async_Readers + Effective_Writes
26635 -- Async_Readers + Async_Writers + Effective_Writes
26637 elsif AR
and EW
and not ER
then
26640 -- Async_Writers + Effective_Reads
26641 -- Async_Readers + Async_Writers + Effective_Reads
26643 elsif AW
and ER
and not EW
then
26646 -- Async_Readers + Async_Writers
26648 elsif AR
and AW
and not ER
and not EW
then
26653 elsif AR
and not AW
and not ER
and not EW
then
26658 elsif AW
and not AR
and not ER
and not EW
then
26663 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
26666 end Check_External_Properties
;
26672 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
26676 -- Loop through entries in check policy list
26678 PP
:= Opt
.Check_Policy_List
;
26679 while Present
(PP
) loop
26681 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
26682 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
26686 or else (Pnm
= Name_Assertion
26687 and then Is_Valid_Assertion_Kind
(Nam
))
26688 or else (Pnm
= Name_Statement_Assertions
26689 and then Nam_In
(Nam
, Name_Assert
,
26690 Name_Assert_And_Cut
,
26692 Name_Loop_Invariant
,
26693 Name_Loop_Variant
))
26695 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
26696 when Name_On | Name_Check
=>
26698 when Name_Off | Name_Ignore
=>
26699 return Name_Ignore
;
26700 when Name_Disable
=>
26701 return Name_Disable
;
26703 raise Program_Error
;
26707 PP
:= Next_Pragma
(PP
);
26712 -- If there are no specific entries that matched, then we let the
26713 -- setting of assertions govern. Note that this provides the needed
26714 -- compatibility with the RM for the cases of assertion, invariant,
26715 -- precondition, predicate, and postcondition.
26717 if Assertions_Enabled
then
26720 return Name_Ignore
;
26724 ---------------------------
26725 -- Check_Missing_Part_Of --
26726 ---------------------------
26728 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
26729 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
26730 -- Determine whether a package denoted by Pack_Id declares at least one
26733 -----------------------
26734 -- Has_Visible_State --
26735 -----------------------
26737 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
26738 Item_Id
: Entity_Id
;
26741 -- Traverse the entity chain of the package trying to find at least
26742 -- one visible abstract state, variable or a package [instantiation]
26743 -- that declares a visible state.
26745 Item_Id
:= First_Entity
(Pack_Id
);
26746 while Present
(Item_Id
)
26747 and then not In_Private_Part
(Item_Id
)
26749 -- Do not consider internally generated items
26751 if not Comes_From_Source
(Item_Id
) then
26754 -- A visible state has been found
26756 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
26759 -- Recursively peek into nested packages and instantiations
26761 elsif Ekind
(Item_Id
) = E_Package
26762 and then Has_Visible_State
(Item_Id
)
26767 Next_Entity
(Item_Id
);
26771 end Has_Visible_State
;
26775 Pack_Id
: Entity_Id
;
26776 Placement
: State_Space_Kind
;
26778 -- Start of processing for Check_Missing_Part_Of
26781 -- Do not consider abstract states, variables or package instantiations
26782 -- coming from an instance as those always inherit the Part_Of indicator
26783 -- of the instance itself.
26785 if In_Instance
then
26788 -- Do not consider internally generated entities as these can never
26789 -- have a Part_Of indicator.
26791 elsif not Comes_From_Source
(Item_Id
) then
26794 -- Perform these checks only when SPARK_Mode is enabled as they will
26795 -- interfere with standard Ada rules and produce false positives.
26797 elsif SPARK_Mode
/= On
then
26800 -- Do not consider constants, because the compiler cannot accurately
26801 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
26802 -- act as a hidden state of a package.
26804 elsif Ekind
(Item_Id
) = E_Constant
then
26808 -- Find where the abstract state, variable or package instantiation
26809 -- lives with respect to the state space.
26811 Find_Placement_In_State_Space
26812 (Item_Id
=> Item_Id
,
26813 Placement
=> Placement
,
26814 Pack_Id
=> Pack_Id
);
26816 -- Items that appear in a non-package construct (subprogram, block, etc)
26817 -- do not require a Part_Of indicator because they can never act as a
26820 if Placement
= Not_In_Package
then
26823 -- An item declared in the body state space of a package always act as a
26824 -- constituent and does not need explicit Part_Of indicator.
26826 elsif Placement
= Body_State_Space
then
26829 -- In general an item declared in the visible state space of a package
26830 -- does not require a Part_Of indicator. The only exception is when the
26831 -- related package is a private child unit in which case Part_Of must
26832 -- denote a state in the parent unit or in one of its descendants.
26834 elsif Placement
= Visible_State_Space
then
26835 if Is_Child_Unit
(Pack_Id
)
26836 and then Is_Private_Descendant
(Pack_Id
)
26838 -- A package instantiation does not need a Part_Of indicator when
26839 -- the related generic template has no visible state.
26841 if Ekind
(Item_Id
) = E_Package
26842 and then Is_Generic_Instance
(Item_Id
)
26843 and then not Has_Visible_State
(Item_Id
)
26847 -- All other cases require Part_Of
26851 ("indicator Part_Of is required in this context "
26852 & "(SPARK RM 7.2.6(3))", Item_Id
);
26853 Error_Msg_Name_1
:= Chars
(Pack_Id
);
26855 ("\& is declared in the visible part of private child "
26856 & "unit %", Item_Id
);
26860 -- When the item appears in the private state space of a packge, it must
26861 -- be a part of some state declared by the said package.
26863 else pragma Assert
(Placement
= Private_State_Space
);
26865 -- The related package does not declare a state, the item cannot act
26866 -- as a Part_Of constituent.
26868 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
26871 -- A package instantiation does not need a Part_Of indicator when the
26872 -- related generic template has no visible state.
26874 elsif Ekind
(Pack_Id
) = E_Package
26875 and then Is_Generic_Instance
(Pack_Id
)
26876 and then not Has_Visible_State
(Pack_Id
)
26880 -- All other cases require Part_Of
26884 ("indicator Part_Of is required in this context "
26885 & "(SPARK RM 7.2.6(2))", Item_Id
);
26886 Error_Msg_Name_1
:= Chars
(Pack_Id
);
26888 ("\& is declared in the private part of package %", Item_Id
);
26891 end Check_Missing_Part_Of
;
26893 ---------------------------------------------------
26894 -- Check_Postcondition_Use_In_Inlined_Subprogram --
26895 ---------------------------------------------------
26897 procedure Check_Postcondition_Use_In_Inlined_Subprogram
26899 Spec_Id
: Entity_Id
)
26902 if Warn_On_Redundant_Constructs
26903 and then Has_Pragma_Inline_Always
(Spec_Id
)
26905 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
26907 if From_Aspect_Specification
(Prag
) then
26909 ("aspect % not enforced on inlined subprogram &?r?",
26910 Corresponding_Aspect
(Prag
), Spec_Id
);
26913 ("pragma % not enforced on inlined subprogram &?r?",
26917 end Check_Postcondition_Use_In_Inlined_Subprogram
;
26919 -------------------------------------
26920 -- Check_State_And_Constituent_Use --
26921 -------------------------------------
26923 procedure Check_State_And_Constituent_Use
26924 (States
: Elist_Id
;
26925 Constits
: Elist_Id
;
26928 function Find_Encapsulating_State
26929 (Constit_Id
: Entity_Id
) return Entity_Id
;
26930 -- Given the entity of a constituent, try to find a corresponding
26931 -- encapsulating state that appears in the same context. The routine
26932 -- returns Empty is no such state is found.
26934 ------------------------------
26935 -- Find_Encapsulating_State --
26936 ------------------------------
26938 function Find_Encapsulating_State
26939 (Constit_Id
: Entity_Id
) return Entity_Id
26941 State_Id
: Entity_Id
;
26944 -- Since a constituent may be part of a larger constituent set, climb
26945 -- the encapsulating state chain looking for a state that appears in
26946 -- the same context.
26948 State_Id
:= Encapsulating_State
(Constit_Id
);
26949 while Present
(State_Id
) loop
26950 if Contains
(States
, State_Id
) then
26954 State_Id
:= Encapsulating_State
(State_Id
);
26958 end Find_Encapsulating_State
;
26962 Constit_Elmt
: Elmt_Id
;
26963 Constit_Id
: Entity_Id
;
26964 State_Id
: Entity_Id
;
26966 -- Start of processing for Check_State_And_Constituent_Use
26969 -- Nothing to do if there are no states or constituents
26971 if No
(States
) or else No
(Constits
) then
26975 -- Inspect the list of constituents and try to determine whether its
26976 -- encapsulating state is in list States.
26978 Constit_Elmt
:= First_Elmt
(Constits
);
26979 while Present
(Constit_Elmt
) loop
26980 Constit_Id
:= Node
(Constit_Elmt
);
26982 -- Determine whether the constituent is part of an encapsulating
26983 -- state that appears in the same context and if this is the case,
26984 -- emit an error (SPARK RM 7.2.6(7)).
26986 State_Id
:= Find_Encapsulating_State
(Constit_Id
);
26988 if Present
(State_Id
) then
26989 Error_Msg_Name_1
:= Chars
(Constit_Id
);
26991 ("cannot mention state & and its constituent % in the same "
26992 & "context", Context
, State_Id
);
26996 Next_Elmt
(Constit_Elmt
);
26998 end Check_State_And_Constituent_Use
;
27000 ---------------------------------------------
27001 -- Collect_Inherited_Class_Wide_Conditions --
27002 ---------------------------------------------
27004 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
27005 Parent_Subp
: constant Entity_Id
:= Overridden_Operation
(Subp
);
27006 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
27007 In_Spec_Expr
: Boolean;
27008 Installed
: Boolean;
27010 New_Prag
: Node_Id
;
27013 Installed
:= False;
27015 -- Iterate over the contract of the overridden subprogram to find all
27016 -- inherited class-wide pre- and postconditions.
27018 if Present
(Prags
) then
27019 Prag
:= Pre_Post_Conditions
(Prags
);
27021 while Present
(Prag
) loop
27022 if Nam_In
(Pragma_Name
(Prag
), Name_Precondition
,
27023 Name_Postcondition
)
27024 and then Class_Present
(Prag
)
27026 -- The generated pragma must be analyzed in the context of
27027 -- the subprogram, to make its formals visible. In addition,
27028 -- we must inhibit freezing and full analysis because the
27029 -- controlling type of the subprogram is not frozen yet, and
27030 -- may have further primitives.
27032 if not Installed
then
27035 Install_Formals
(Subp
);
27036 In_Spec_Expr
:= In_Spec_Expression
;
27037 In_Spec_Expression
:= True;
27041 Build_Pragma_Check_Equivalent
(Prag
, Subp
, Parent_Subp
);
27042 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
27043 Preanalyze
(New_Prag
);
27045 -- Prevent further analysis in subsequent processing of the
27046 -- current list of declarations
27048 Set_Analyzed
(New_Prag
);
27051 Prag
:= Next_Pragma
(Prag
);
27055 In_Spec_Expression
:= In_Spec_Expr
;
27059 end Collect_Inherited_Class_Wide_Conditions
;
27061 ---------------------------------------
27062 -- Collect_Subprogram_Inputs_Outputs --
27063 ---------------------------------------
27065 procedure Collect_Subprogram_Inputs_Outputs
27066 (Subp_Id
: Entity_Id
;
27067 Synthesize
: Boolean := False;
27068 Subp_Inputs
: in out Elist_Id
;
27069 Subp_Outputs
: in out Elist_Id
;
27070 Global_Seen
: out Boolean)
27072 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
27073 -- Collect all relevant items from a dependency clause
27075 procedure Collect_Global_List
27077 Mode
: Name_Id
:= Name_Input
);
27078 -- Collect all relevant items from a global list
27080 -------------------------------
27081 -- Collect_Dependency_Clause --
27082 -------------------------------
27084 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
27085 procedure Collect_Dependency_Item
27087 Is_Input
: Boolean);
27088 -- Add an item to the proper subprogram input or output collection
27090 -----------------------------
27091 -- Collect_Dependency_Item --
27092 -----------------------------
27094 procedure Collect_Dependency_Item
27096 Is_Input
: Boolean)
27101 -- Nothing to collect when the item is null
27103 if Nkind
(Item
) = N_Null
then
27106 -- Ditto for attribute 'Result
27108 elsif Is_Attribute_Result
(Item
) then
27111 -- Multiple items appear as an aggregate
27113 elsif Nkind
(Item
) = N_Aggregate
then
27114 Extra
:= First
(Expressions
(Item
));
27115 while Present
(Extra
) loop
27116 Collect_Dependency_Item
(Extra
, Is_Input
);
27120 -- Otherwise this is a solitary item
27124 Append_New_Elmt
(Item
, Subp_Inputs
);
27126 Append_New_Elmt
(Item
, Subp_Outputs
);
27129 end Collect_Dependency_Item
;
27131 -- Start of processing for Collect_Dependency_Clause
27134 if Nkind
(Clause
) = N_Null
then
27137 -- A dependency cause appears as component association
27139 elsif Nkind
(Clause
) = N_Component_Association
then
27140 Collect_Dependency_Item
27141 (Item
=> Expression
(Clause
),
27144 Collect_Dependency_Item
27145 (Item
=> First
(Choices
(Clause
)),
27146 Is_Input
=> False);
27148 -- To accomodate partial decoration of disabled SPARK features, this
27149 -- routine may be called with illegal input. If this is the case, do
27150 -- not raise Program_Error.
27155 end Collect_Dependency_Clause
;
27157 -------------------------
27158 -- Collect_Global_List --
27159 -------------------------
27161 procedure Collect_Global_List
27163 Mode
: Name_Id
:= Name_Input
)
27165 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
27166 -- Add an item to the proper subprogram input or output collection
27168 -------------------------
27169 -- Collect_Global_Item --
27170 -------------------------
27172 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
27174 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
27175 Append_New_Elmt
(Item
, Subp_Inputs
);
27178 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
27179 Append_New_Elmt
(Item
, Subp_Outputs
);
27181 end Collect_Global_Item
;
27188 -- Start of processing for Collect_Global_List
27191 if Nkind
(List
) = N_Null
then
27194 -- Single global item declaration
27196 elsif Nkind_In
(List
, N_Expanded_Name
,
27198 N_Selected_Component
)
27200 Collect_Global_Item
(List
, Mode
);
27202 -- Simple global list or moded global list declaration
27204 elsif Nkind
(List
) = N_Aggregate
then
27205 if Present
(Expressions
(List
)) then
27206 Item
:= First
(Expressions
(List
));
27207 while Present
(Item
) loop
27208 Collect_Global_Item
(Item
, Mode
);
27213 Assoc
:= First
(Component_Associations
(List
));
27214 while Present
(Assoc
) loop
27215 Collect_Global_List
27216 (List
=> Expression
(Assoc
),
27217 Mode
=> Chars
(First
(Choices
(Assoc
))));
27222 -- To accomodate partial decoration of disabled SPARK features, this
27223 -- routine may be called with illegal input. If this is the case, do
27224 -- not raise Program_Error.
27229 end Collect_Global_List
;
27236 Formal
: Entity_Id
;
27238 Spec_Id
: Entity_Id
;
27239 Subp_Decl
: Node_Id
;
27242 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27245 Global_Seen
:= False;
27247 -- Process all formal parameters of entries, [generic] subprograms, and
27250 if Ekind_In
(Subp_Id
, E_Entry
,
27253 E_Generic_Function
,
27254 E_Generic_Procedure
,
27258 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
27259 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27261 -- Process all [generic] formal parameters
27263 Formal
:= First_Entity
(Spec_Id
);
27264 while Present
(Formal
) loop
27265 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
27266 E_In_Out_Parameter
,
27269 Append_New_Elmt
(Formal
, Subp_Inputs
);
27272 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
27273 E_In_Out_Parameter
,
27276 Append_New_Elmt
(Formal
, Subp_Outputs
);
27278 -- Out parameters can act as inputs when the related type is
27279 -- tagged, unconstrained array, unconstrained record, or record
27280 -- with unconstrained components.
27282 if Ekind
(Formal
) = E_Out_Parameter
27283 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
27285 Append_New_Elmt
(Formal
, Subp_Inputs
);
27289 Next_Entity
(Formal
);
27292 -- Otherwise the input denotes a task type, a task body, or the
27293 -- anonymous object created for a single task type.
27295 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
27296 or else Is_Single_Task_Object
(Subp_Id
)
27298 Subp_Decl
:= Declaration_Node
(Subp_Id
);
27299 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27302 -- When processing an entry, subprogram or task body, look for pragmas
27303 -- Refined_Depends and Refined_Global as they specify the inputs and
27306 if Is_Entry_Body
(Subp_Id
)
27307 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
27309 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
27310 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
27312 -- Subprogram declaration or stand alone body case, look for pragmas
27313 -- Depends and Global
27316 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
27317 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
27320 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27321 -- because it provides finer granularity of inputs and outputs.
27323 if Present
(Global
) then
27324 Global_Seen
:= True;
27325 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
27327 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27328 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27329 -- the inputs and outputs from [Refined_]Depends.
27331 elsif Synthesize
and then Present
(Depends
) then
27332 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
27334 -- Multiple dependency clauses appear as an aggregate
27336 if Nkind
(Clauses
) = N_Aggregate
then
27337 Clause
:= First
(Component_Associations
(Clauses
));
27338 while Present
(Clause
) loop
27339 Collect_Dependency_Clause
(Clause
);
27343 -- Otherwise this is a single dependency clause
27346 Collect_Dependency_Clause
(Clauses
);
27350 -- The current instance of a protected type acts as a formal parameter
27351 -- of mode IN for functions and IN OUT for entries and procedures
27352 -- (SPARK RM 6.1.4).
27354 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
27355 Typ
:= Scope
(Spec_Id
);
27357 -- Use the anonymous object when the type is single protected
27359 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27360 Typ
:= Anonymous_Object
(Typ
);
27363 Append_New_Elmt
(Typ
, Subp_Inputs
);
27365 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
27366 Append_New_Elmt
(Typ
, Subp_Outputs
);
27369 -- The current instance of a task type acts as a formal parameter of
27370 -- mode IN OUT (SPARK RM 6.1.4).
27372 elsif Ekind
(Spec_Id
) = E_Task_Type
then
27375 -- Use the anonymous object when the type is single task
27377 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27378 Typ
:= Anonymous_Object
(Typ
);
27381 Append_New_Elmt
(Typ
, Subp_Inputs
);
27382 Append_New_Elmt
(Typ
, Subp_Outputs
);
27384 elsif Is_Single_Task_Object
(Spec_Id
) then
27385 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
27386 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
27388 end Collect_Subprogram_Inputs_Outputs
;
27390 ---------------------------
27391 -- Contract_Freeze_Error --
27392 ---------------------------
27394 procedure Contract_Freeze_Error
27395 (Contract_Id
: Entity_Id
;
27396 Freeze_Id
: Entity_Id
)
27399 Error_Msg_Name_1
:= Chars
(Contract_Id
);
27400 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27403 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
27405 ("\all contractual items must be declared before body #", Contract_Id
);
27406 end Contract_Freeze_Error
;
27408 ---------------------------------
27409 -- Delay_Config_Pragma_Analyze --
27410 ---------------------------------
27412 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
27414 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
27415 Name_Priority_Specific_Dispatching
);
27416 end Delay_Config_Pragma_Analyze
;
27418 -----------------------
27419 -- Duplication_Error --
27420 -----------------------
27422 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
27423 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
27424 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
27427 Error_Msg_Sloc
:= Sloc
(Prev
);
27428 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27430 -- Emit a precise message to distinguish between source pragmas and
27431 -- pragmas generated from aspects. The ordering of the two pragmas is
27435 -- Prag -- duplicate
27437 -- No error is emitted when both pragmas come from aspects because this
27438 -- is already detected by the general aspect analysis mechanism.
27440 if Prag_From_Asp
and Prev_From_Asp
then
27442 elsif Prag_From_Asp
then
27443 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
27444 elsif Prev_From_Asp
then
27445 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
27447 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
27449 end Duplication_Error
;
27451 --------------------------
27452 -- Find_Related_Context --
27453 --------------------------
27455 function Find_Related_Context
27457 Do_Checks
: Boolean := False) return Node_Id
27462 Stmt
:= Prev
(Prag
);
27463 while Present
(Stmt
) loop
27465 -- Skip prior pragmas, but check for duplicates
27467 if Nkind
(Stmt
) = N_Pragma
then
27468 if Do_Checks
and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
) then
27474 -- Skip internally generated code
27476 elsif not Comes_From_Source
(Stmt
) then
27478 -- The anonymous object created for a single concurrent type is a
27479 -- suitable context.
27481 if Nkind
(Stmt
) = N_Object_Declaration
27482 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
27487 -- Return the current source construct
27497 end Find_Related_Context
;
27499 --------------------------------------
27500 -- Find_Related_Declaration_Or_Body --
27501 --------------------------------------
27503 function Find_Related_Declaration_Or_Body
27505 Do_Checks
: Boolean := False) return Node_Id
27507 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
27509 procedure Expression_Function_Error
;
27510 -- Emit an error concerning pragma Prag that illegaly applies to an
27511 -- expression function.
27513 -------------------------------
27514 -- Expression_Function_Error --
27515 -------------------------------
27517 procedure Expression_Function_Error
is
27519 Error_Msg_Name_1
:= Prag_Nam
;
27521 -- Emit a precise message to distinguish between source pragmas and
27522 -- pragmas generated from aspects.
27524 if From_Aspect_Specification
(Prag
) then
27526 ("aspect % cannot apply to a stand alone expression function",
27530 ("pragma % cannot apply to a stand alone expression function",
27533 end Expression_Function_Error
;
27537 Context
: constant Node_Id
:= Parent
(Prag
);
27540 Look_For_Body
: constant Boolean :=
27541 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
27542 Name_Refined_Global
,
27543 Name_Refined_Post
);
27544 -- Refinement pragmas must be associated with a subprogram body [stub]
27546 -- Start of processing for Find_Related_Declaration_Or_Body
27549 Stmt
:= Prev
(Prag
);
27550 while Present
(Stmt
) loop
27552 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27553 -- by splitting a complex pre/postcondition are not considered to
27556 if Nkind
(Stmt
) = N_Pragma
then
27558 and then not Split_PPC
(Stmt
)
27559 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
27566 -- Emit an error when a refinement pragma appears on an expression
27567 -- function without a completion.
27570 and then Look_For_Body
27571 and then Nkind
(Stmt
) = N_Subprogram_Declaration
27572 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
27573 and then not Has_Completion
(Defining_Entity
(Stmt
))
27575 Expression_Function_Error
;
27578 -- The refinement pragma applies to a subprogram body stub
27580 elsif Look_For_Body
27581 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
27585 -- Skip internally generated code
27587 elsif not Comes_From_Source
(Stmt
) then
27589 -- The anonymous object created for a single concurrent type is a
27590 -- suitable context.
27592 if Nkind
(Stmt
) = N_Object_Declaration
27593 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
27597 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
27599 -- The subprogram declaration is an internally generated spec
27600 -- for an expression function.
27602 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
27605 -- The subprogram is actually an instance housed within an
27606 -- anonymous wrapper package.
27608 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
27613 -- Return the current construct which is either a subprogram body,
27614 -- a subprogram declaration or is illegal.
27623 -- If we fall through, then the pragma was either the first declaration
27624 -- or it was preceded by other pragmas and no source constructs.
27626 -- The pragma is associated with a library-level subprogram
27628 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
27629 return Unit
(Parent
(Context
));
27631 -- The pragma appears inside the declarations of an entry body
27633 elsif Nkind
(Context
) = N_Entry_Body
then
27636 -- The pragma appears inside the statements of a subprogram body. This
27637 -- placement is the result of subprogram contract expansion.
27639 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
27640 return Parent
(Context
);
27642 -- The pragma appears inside the declarative part of a subprogram body
27644 elsif Nkind
(Context
) = N_Subprogram_Body
then
27647 -- The pragma appears inside the declarative part of a task body
27649 elsif Nkind
(Context
) = N_Task_Body
then
27652 -- The pragma is a byproduct of aspect expansion, return the related
27653 -- context of the original aspect. This case has a lower priority as
27654 -- the above circuitry pinpoints precisely the related context.
27656 elsif Present
(Corresponding_Aspect
(Prag
)) then
27657 return Parent
(Corresponding_Aspect
(Prag
));
27659 -- No candidate subprogram [body] found
27664 end Find_Related_Declaration_Or_Body
;
27666 ----------------------------------
27667 -- Find_Related_Package_Or_Body --
27668 ----------------------------------
27670 function Find_Related_Package_Or_Body
27672 Do_Checks
: Boolean := False) return Node_Id
27674 Context
: constant Node_Id
:= Parent
(Prag
);
27675 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
27679 Stmt
:= Prev
(Prag
);
27680 while Present
(Stmt
) loop
27682 -- Skip prior pragmas, but check for duplicates
27684 if Nkind
(Stmt
) = N_Pragma
then
27685 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
27691 -- Skip internally generated code
27693 elsif not Comes_From_Source
(Stmt
) then
27694 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
27696 -- The subprogram declaration is an internally generated spec
27697 -- for an expression function.
27699 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
27702 -- The subprogram is actually an instance housed within an
27703 -- anonymous wrapper package.
27705 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
27710 -- Return the current source construct which is illegal
27719 -- If we fall through, then the pragma was either the first declaration
27720 -- or it was preceded by other pragmas and no source constructs.
27722 -- The pragma is associated with a package. The immediate context in
27723 -- this case is the specification of the package.
27725 if Nkind
(Context
) = N_Package_Specification
then
27726 return Parent
(Context
);
27728 -- The pragma appears in the declarations of a package body
27730 elsif Nkind
(Context
) = N_Package_Body
then
27733 -- The pragma appears in the statements of a package body
27735 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
27736 and then Nkind
(Parent
(Context
)) = N_Package_Body
27738 return Parent
(Context
);
27740 -- The pragma is a byproduct of aspect expansion, return the related
27741 -- context of the original aspect. This case has a lower priority as
27742 -- the above circuitry pinpoints precisely the related context.
27744 elsif Present
(Corresponding_Aspect
(Prag
)) then
27745 return Parent
(Corresponding_Aspect
(Prag
));
27747 -- No candidate packge [body] found
27752 end Find_Related_Package_Or_Body
;
27758 function Get_Argument
27760 Context_Id
: Entity_Id
:= Empty
) return Node_Id
27762 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
27765 -- Use the expression of the original aspect when compiling for ASIS or
27766 -- when analyzing the template of a generic unit. In both cases the
27767 -- aspect's tree must be decorated to allow for ASIS queries or to save
27768 -- the global references in the generic context.
27770 if From_Aspect_Specification
(Prag
)
27771 and then (ASIS_Mode
or else (Present
(Context_Id
)
27772 and then Is_Generic_Unit
(Context_Id
)))
27774 return Corresponding_Aspect
(Prag
);
27776 -- Otherwise use the expression of the pragma
27778 elsif Present
(Args
) then
27779 return First
(Args
);
27786 -------------------------
27787 -- Get_Base_Subprogram --
27788 -------------------------
27790 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
27791 Result
: Entity_Id
;
27794 -- Follow subprogram renaming chain
27798 if Is_Subprogram
(Result
)
27800 Nkind
(Parent
(Declaration_Node
(Result
))) =
27801 N_Subprogram_Renaming_Declaration
27802 and then Present
(Alias
(Result
))
27804 Result
:= Alias
(Result
);
27808 end Get_Base_Subprogram
;
27810 -----------------------
27811 -- Get_SPARK_Mode_Type --
27812 -----------------------
27814 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
27816 if N
= Name_On
then
27818 elsif N
= Name_Off
then
27821 -- Any other argument is illegal
27824 raise Program_Error
;
27826 end Get_SPARK_Mode_Type
;
27828 ------------------------------------
27829 -- Get_SPARK_Mode_From_Annotation --
27830 ------------------------------------
27832 function Get_SPARK_Mode_From_Annotation
27833 (N
: Node_Id
) return SPARK_Mode_Type
27838 if Nkind
(N
) = N_Aspect_Specification
then
27839 Mode
:= Expression
(N
);
27841 else pragma Assert
(Nkind
(N
) = N_Pragma
);
27842 Mode
:= First
(Pragma_Argument_Associations
(N
));
27844 if Present
(Mode
) then
27845 Mode
:= Get_Pragma_Arg
(Mode
);
27849 -- Aspect or pragma SPARK_Mode specifies an explicit mode
27851 if Present
(Mode
) then
27852 if Nkind
(Mode
) = N_Identifier
then
27853 return Get_SPARK_Mode_Type
(Chars
(Mode
));
27855 -- In case of a malformed aspect or pragma, return the default None
27861 -- Otherwise the lack of an expression defaults SPARK_Mode to On
27866 end Get_SPARK_Mode_From_Annotation
;
27868 ---------------------------
27869 -- Has_Extra_Parentheses --
27870 ---------------------------
27872 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
27876 -- The aggregate should not have an expression list because a clause
27877 -- is always interpreted as a component association. The only way an
27878 -- expression list can sneak in is by adding extra parentheses around
27879 -- the individual clauses:
27881 -- Depends (Output => Input) -- proper form
27882 -- Depends ((Output => Input)) -- extra parentheses
27884 -- Since the extra parentheses are not allowed by the syntax of the
27885 -- pragma, flag them now to avoid emitting misleading errors down the
27888 if Nkind
(Clause
) = N_Aggregate
27889 and then Present
(Expressions
(Clause
))
27891 Expr
:= First
(Expressions
(Clause
));
27892 while Present
(Expr
) loop
27894 -- A dependency clause surrounded by extra parentheses appears
27895 -- as an aggregate of component associations with an optional
27896 -- Paren_Count set.
27898 if Nkind
(Expr
) = N_Aggregate
27899 and then Present
(Component_Associations
(Expr
))
27902 ("dependency clause contains extra parentheses", Expr
);
27904 -- Otherwise the expression is a malformed construct
27907 SPARK_Msg_N
("malformed dependency clause", Expr
);
27917 end Has_Extra_Parentheses
;
27923 procedure Initialize
is
27934 Dummy
:= Dummy
+ 1;
27937 -----------------------------
27938 -- Is_Config_Static_String --
27939 -----------------------------
27941 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
27943 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
27944 -- This is an internal recursive function that is just like the outer
27945 -- function except that it adds the string to the name buffer rather
27946 -- than placing the string in the name buffer.
27948 ------------------------------
27949 -- Add_Config_Static_String --
27950 ------------------------------
27952 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
27959 if Nkind
(N
) = N_Op_Concat
then
27960 if Add_Config_Static_String
(Left_Opnd
(N
)) then
27961 N
:= Right_Opnd
(N
);
27967 if Nkind
(N
) /= N_String_Literal
then
27968 Error_Msg_N
("string literal expected for pragma argument", N
);
27972 for J
in 1 .. String_Length
(Strval
(N
)) loop
27973 C
:= Get_String_Char
(Strval
(N
), J
);
27975 if not In_Character_Range
(C
) then
27977 ("string literal contains invalid wide character",
27978 Sloc
(N
) + 1 + Source_Ptr
(J
));
27982 Add_Char_To_Name_Buffer
(Get_Character
(C
));
27987 end Add_Config_Static_String
;
27989 -- Start of processing for Is_Config_Static_String
27994 return Add_Config_Static_String
(Arg
);
27995 end Is_Config_Static_String
;
27997 ---------------------
27998 -- Is_CCT_Instance --
27999 ---------------------
28001 function Is_CCT_Instance
28002 (Ref_Id
: Entity_Id
;
28003 Context_Id
: Entity_Id
) return Boolean
28009 -- When the reference denotes a single protected type, the context is
28010 -- either a protected subprogram or its body.
28012 if Is_Single_Protected_Object
(Ref_Id
) then
28013 Typ
:= Scope
(Context_Id
);
28016 Ekind
(Typ
) = E_Protected_Type
28017 and then Present
(Anonymous_Object
(Typ
))
28018 and then Anonymous_Object
(Typ
) = Ref_Id
;
28020 -- When the reference denotes a single task type, the context is either
28021 -- the same type or if inside the body, the anonymous task type.
28023 elsif Is_Single_Task_Object
(Ref_Id
) then
28024 if Ekind
(Context_Id
) = E_Task_Type
then
28026 Present
(Anonymous_Object
(Context_Id
))
28027 and then Anonymous_Object
(Context_Id
) = Ref_Id
;
28029 return Ref_Id
= Context_Id
;
28032 -- Otherwise the reference denotes a protected or a task type. Climb the
28033 -- scope chain looking for an enclosing concurrent type that matches the
28034 -- referenced entity.
28037 pragma Assert
(Ekind_In
(Ref_Id
, E_Protected_Type
, E_Task_Type
));
28039 S
:= Current_Scope
;
28040 while Present
(S
) and then S
/= Standard_Standard
loop
28041 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
)
28042 and then S
= Ref_Id
28052 end Is_CCT_Instance
;
28054 -------------------------------
28055 -- Is_Elaboration_SPARK_Mode --
28056 -------------------------------
28058 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
28061 (Nkind
(N
) = N_Pragma
28062 and then Pragma_Name
(N
) = Name_SPARK_Mode
28063 and then Is_List_Member
(N
));
28065 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28066 -- appears in the statement part of the body.
28069 Present
(Parent
(N
))
28070 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
28071 and then List_Containing
(N
) = Statements
(Parent
(N
))
28072 and then Present
(Parent
(Parent
(N
)))
28073 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
28074 end Is_Elaboration_SPARK_Mode
;
28076 -----------------------
28077 -- Is_Enabled_Pragma --
28078 -----------------------
28080 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
28084 if Present
(Prag
) then
28085 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
28087 if Present
(Arg
) then
28088 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
28090 -- The lack of a Boolean argument automatically enables the pragma
28096 -- The pragma is missing, therefore it is not enabled
28101 end Is_Enabled_Pragma
;
28103 -----------------------------------------
28104 -- Is_Non_Significant_Pragma_Reference --
28105 -----------------------------------------
28107 -- This function makes use of the following static table which indicates
28108 -- whether appearance of some name in a given pragma is to be considered
28109 -- as a reference for the purposes of warnings about unreferenced objects.
28111 -- -1 indicates that appearence in any argument is significant
28112 -- 0 indicates that appearance in any argument is not significant
28113 -- +n indicates that appearance as argument n is significant, but all
28114 -- other arguments are not significant
28115 -- 9n arguments from n on are significant, before n insignificant
28117 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
28118 (Pragma_Abort_Defer
=> -1,
28119 Pragma_Abstract_State
=> -1,
28120 Pragma_Ada_83
=> -1,
28121 Pragma_Ada_95
=> -1,
28122 Pragma_Ada_05
=> -1,
28123 Pragma_Ada_2005
=> -1,
28124 Pragma_Ada_12
=> -1,
28125 Pragma_Ada_2012
=> -1,
28126 Pragma_All_Calls_Remote
=> -1,
28127 Pragma_Allow_Integer_Address
=> -1,
28128 Pragma_Annotate
=> 93,
28129 Pragma_Assert
=> -1,
28130 Pragma_Assert_And_Cut
=> -1,
28131 Pragma_Assertion_Policy
=> 0,
28132 Pragma_Assume
=> -1,
28133 Pragma_Assume_No_Invalid_Values
=> 0,
28134 Pragma_Async_Readers
=> 0,
28135 Pragma_Async_Writers
=> 0,
28136 Pragma_Asynchronous
=> 0,
28137 Pragma_Atomic
=> 0,
28138 Pragma_Atomic_Components
=> 0,
28139 Pragma_Attach_Handler
=> -1,
28140 Pragma_Attribute_Definition
=> 92,
28141 Pragma_Check
=> -1,
28142 Pragma_Check_Float_Overflow
=> 0,
28143 Pragma_Check_Name
=> 0,
28144 Pragma_Check_Policy
=> 0,
28145 Pragma_CPP_Class
=> 0,
28146 Pragma_CPP_Constructor
=> 0,
28147 Pragma_CPP_Virtual
=> 0,
28148 Pragma_CPP_Vtable
=> 0,
28150 Pragma_C_Pass_By_Copy
=> 0,
28151 Pragma_Comment
=> -1,
28152 Pragma_Common_Object
=> 0,
28153 Pragma_Compile_Time_Error
=> -1,
28154 Pragma_Compile_Time_Warning
=> -1,
28155 Pragma_Compiler_Unit
=> -1,
28156 Pragma_Compiler_Unit_Warning
=> -1,
28157 Pragma_Complete_Representation
=> 0,
28158 Pragma_Complex_Representation
=> 0,
28159 Pragma_Component_Alignment
=> 0,
28160 Pragma_Constant_After_Elaboration
=> 0,
28161 Pragma_Contract_Cases
=> -1,
28162 Pragma_Controlled
=> 0,
28163 Pragma_Convention
=> 0,
28164 Pragma_Convention_Identifier
=> 0,
28165 Pragma_Debug
=> -1,
28166 Pragma_Debug_Policy
=> 0,
28167 Pragma_Detect_Blocking
=> 0,
28168 Pragma_Default_Initial_Condition
=> -1,
28169 Pragma_Default_Scalar_Storage_Order
=> 0,
28170 Pragma_Default_Storage_Pool
=> 0,
28171 Pragma_Depends
=> -1,
28172 Pragma_Disable_Atomic_Synchronization
=> 0,
28173 Pragma_Discard_Names
=> 0,
28174 Pragma_Dispatching_Domain
=> -1,
28175 Pragma_Effective_Reads
=> 0,
28176 Pragma_Effective_Writes
=> 0,
28177 Pragma_Elaborate
=> 0,
28178 Pragma_Elaborate_All
=> 0,
28179 Pragma_Elaborate_Body
=> 0,
28180 Pragma_Elaboration_Checks
=> 0,
28181 Pragma_Eliminate
=> 0,
28182 Pragma_Enable_Atomic_Synchronization
=> 0,
28183 Pragma_Export
=> -1,
28184 Pragma_Export_Function
=> -1,
28185 Pragma_Export_Object
=> -1,
28186 Pragma_Export_Procedure
=> -1,
28187 Pragma_Export_Value
=> -1,
28188 Pragma_Export_Valued_Procedure
=> -1,
28189 Pragma_Extend_System
=> -1,
28190 Pragma_Extensions_Allowed
=> 0,
28191 Pragma_Extensions_Visible
=> 0,
28192 Pragma_External
=> -1,
28193 Pragma_Favor_Top_Level
=> 0,
28194 Pragma_External_Name_Casing
=> 0,
28195 Pragma_Fast_Math
=> 0,
28196 Pragma_Finalize_Storage_Only
=> 0,
28198 Pragma_Global
=> -1,
28199 Pragma_Ident
=> -1,
28200 Pragma_Ignore_Pragma
=> 0,
28201 Pragma_Implementation_Defined
=> -1,
28202 Pragma_Implemented
=> -1,
28203 Pragma_Implicit_Packing
=> 0,
28204 Pragma_Import
=> 93,
28205 Pragma_Import_Function
=> 0,
28206 Pragma_Import_Object
=> 0,
28207 Pragma_Import_Procedure
=> 0,
28208 Pragma_Import_Valued_Procedure
=> 0,
28209 Pragma_Independent
=> 0,
28210 Pragma_Independent_Components
=> 0,
28211 Pragma_Initial_Condition
=> -1,
28212 Pragma_Initialize_Scalars
=> 0,
28213 Pragma_Initializes
=> -1,
28214 Pragma_Inline
=> 0,
28215 Pragma_Inline_Always
=> 0,
28216 Pragma_Inline_Generic
=> 0,
28217 Pragma_Inspection_Point
=> -1,
28218 Pragma_Interface
=> 92,
28219 Pragma_Interface_Name
=> 0,
28220 Pragma_Interrupt_Handler
=> -1,
28221 Pragma_Interrupt_Priority
=> -1,
28222 Pragma_Interrupt_State
=> -1,
28223 Pragma_Invariant
=> -1,
28224 Pragma_Keep_Names
=> 0,
28225 Pragma_License
=> 0,
28226 Pragma_Link_With
=> -1,
28227 Pragma_Linker_Alias
=> -1,
28228 Pragma_Linker_Constructor
=> -1,
28229 Pragma_Linker_Destructor
=> -1,
28230 Pragma_Linker_Options
=> -1,
28231 Pragma_Linker_Section
=> 0,
28233 Pragma_Lock_Free
=> 0,
28234 Pragma_Locking_Policy
=> 0,
28235 Pragma_Loop_Invariant
=> -1,
28236 Pragma_Loop_Optimize
=> 0,
28237 Pragma_Loop_Variant
=> -1,
28238 Pragma_Machine_Attribute
=> -1,
28240 Pragma_Main_Storage
=> -1,
28241 Pragma_Memory_Size
=> 0,
28242 Pragma_No_Return
=> 0,
28243 Pragma_No_Body
=> 0,
28244 Pragma_No_Elaboration_Code_All
=> 0,
28245 Pragma_No_Inline
=> 0,
28246 Pragma_No_Run_Time
=> -1,
28247 Pragma_No_Strict_Aliasing
=> -1,
28248 Pragma_No_Tagged_Streams
=> 0,
28249 Pragma_Normalize_Scalars
=> 0,
28250 Pragma_Obsolescent
=> 0,
28251 Pragma_Optimize
=> 0,
28252 Pragma_Optimize_Alignment
=> 0,
28253 Pragma_Overflow_Mode
=> 0,
28254 Pragma_Overriding_Renamings
=> 0,
28255 Pragma_Ordered
=> 0,
28258 Pragma_Part_Of
=> 0,
28259 Pragma_Partition_Elaboration_Policy
=> 0,
28260 Pragma_Passive
=> 0,
28261 Pragma_Persistent_BSS
=> 0,
28262 Pragma_Polling
=> 0,
28263 Pragma_Prefix_Exception_Messages
=> 0,
28265 Pragma_Postcondition
=> -1,
28266 Pragma_Post_Class
=> -1,
28268 Pragma_Precondition
=> -1,
28269 Pragma_Predicate
=> -1,
28270 Pragma_Predicate_Failure
=> -1,
28271 Pragma_Preelaborable_Initialization
=> -1,
28272 Pragma_Preelaborate
=> 0,
28273 Pragma_Pre_Class
=> -1,
28274 Pragma_Priority
=> -1,
28275 Pragma_Priority_Specific_Dispatching
=> 0,
28276 Pragma_Profile
=> 0,
28277 Pragma_Profile_Warnings
=> 0,
28278 Pragma_Propagate_Exceptions
=> 0,
28279 Pragma_Provide_Shift_Operators
=> 0,
28280 Pragma_Psect_Object
=> 0,
28282 Pragma_Pure_Function
=> 0,
28283 Pragma_Queuing_Policy
=> 0,
28284 Pragma_Rational
=> 0,
28285 Pragma_Ravenscar
=> 0,
28286 Pragma_Refined_Depends
=> -1,
28287 Pragma_Refined_Global
=> -1,
28288 Pragma_Refined_Post
=> -1,
28289 Pragma_Refined_State
=> -1,
28290 Pragma_Relative_Deadline
=> 0,
28291 Pragma_Remote_Access_Type
=> -1,
28292 Pragma_Remote_Call_Interface
=> -1,
28293 Pragma_Remote_Types
=> -1,
28294 Pragma_Restricted_Run_Time
=> 0,
28295 Pragma_Restriction_Warnings
=> 0,
28296 Pragma_Restrictions
=> 0,
28297 Pragma_Reviewable
=> -1,
28298 Pragma_Short_Circuit_And_Or
=> 0,
28299 Pragma_Share_Generic
=> 0,
28300 Pragma_Shared
=> 0,
28301 Pragma_Shared_Passive
=> 0,
28302 Pragma_Short_Descriptors
=> 0,
28303 Pragma_Simple_Storage_Pool_Type
=> 0,
28304 Pragma_Source_File_Name
=> 0,
28305 Pragma_Source_File_Name_Project
=> 0,
28306 Pragma_Source_Reference
=> 0,
28307 Pragma_SPARK_Mode
=> 0,
28308 Pragma_Storage_Size
=> -1,
28309 Pragma_Storage_Unit
=> 0,
28310 Pragma_Static_Elaboration_Desired
=> 0,
28311 Pragma_Stream_Convert
=> 0,
28312 Pragma_Style_Checks
=> 0,
28313 Pragma_Subtitle
=> 0,
28314 Pragma_Suppress
=> 0,
28315 Pragma_Suppress_Exception_Locations
=> 0,
28316 Pragma_Suppress_All
=> 0,
28317 Pragma_Suppress_Debug_Info
=> 0,
28318 Pragma_Suppress_Initialization
=> 0,
28319 Pragma_System_Name
=> 0,
28320 Pragma_Task_Dispatching_Policy
=> 0,
28321 Pragma_Task_Info
=> -1,
28322 Pragma_Task_Name
=> -1,
28323 Pragma_Task_Storage
=> -1,
28324 Pragma_Test_Case
=> -1,
28325 Pragma_Thread_Local_Storage
=> -1,
28326 Pragma_Time_Slice
=> -1,
28328 Pragma_Type_Invariant
=> -1,
28329 Pragma_Type_Invariant_Class
=> -1,
28330 Pragma_Unchecked_Union
=> 0,
28331 Pragma_Unimplemented_Unit
=> 0,
28332 Pragma_Universal_Aliasing
=> 0,
28333 Pragma_Universal_Data
=> 0,
28334 Pragma_Unmodified
=> 0,
28335 Pragma_Unreferenced
=> 0,
28336 Pragma_Unreferenced_Objects
=> 0,
28337 Pragma_Unreserve_All_Interrupts
=> 0,
28338 Pragma_Unsuppress
=> 0,
28339 Pragma_Unevaluated_Use_Of_Old
=> 0,
28340 Pragma_Use_VADS_Size
=> 0,
28341 Pragma_Validity_Checks
=> 0,
28342 Pragma_Volatile
=> 0,
28343 Pragma_Volatile_Components
=> 0,
28344 Pragma_Volatile_Full_Access
=> 0,
28345 Pragma_Volatile_Function
=> 0,
28346 Pragma_Warning_As_Error
=> 0,
28347 Pragma_Warnings
=> 0,
28348 Pragma_Weak_External
=> 0,
28349 Pragma_Wide_Character_Encoding
=> 0,
28350 Unknown_Pragma
=> 0);
28352 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
28358 function Arg_No
return Nat
;
28359 -- Returns an integer showing what argument we are in. A value of
28360 -- zero means we are not in any of the arguments.
28366 function Arg_No
return Nat
is
28371 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
28385 -- Start of processing for Non_Significant_Pragma_Reference
28390 if Nkind
(P
) /= N_Pragma_Argument_Association
then
28394 Id
:= Get_Pragma_Id
(Parent
(P
));
28395 C
:= Sig_Flags
(Id
);
28410 return AN
< (C
- 90);
28416 end Is_Non_Significant_Pragma_Reference
;
28418 ------------------------------
28419 -- Is_Pragma_String_Literal --
28420 ------------------------------
28422 -- This function returns true if the corresponding pragma argument is a
28423 -- static string expression. These are the only cases in which string
28424 -- literals can appear as pragma arguments. We also allow a string literal
28425 -- as the first argument to pragma Assert (although it will of course
28426 -- always generate a type error).
28428 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
28429 Pragn
: constant Node_Id
:= Parent
(Par
);
28430 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
28431 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
28437 N
:= First
(Assoc
);
28444 if Pname
= Name_Assert
then
28447 elsif Pname
= Name_Export
then
28450 elsif Pname
= Name_Ident
then
28453 elsif Pname
= Name_Import
then
28456 elsif Pname
= Name_Interface_Name
then
28459 elsif Pname
= Name_Linker_Alias
then
28462 elsif Pname
= Name_Linker_Section
then
28465 elsif Pname
= Name_Machine_Attribute
then
28468 elsif Pname
= Name_Source_File_Name
then
28471 elsif Pname
= Name_Source_Reference
then
28474 elsif Pname
= Name_Title
then
28477 elsif Pname
= Name_Subtitle
then
28483 end Is_Pragma_String_Literal
;
28485 ---------------------------
28486 -- Is_Private_SPARK_Mode --
28487 ---------------------------
28489 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
28492 (Nkind
(N
) = N_Pragma
28493 and then Pragma_Name
(N
) = Name_SPARK_Mode
28494 and then Is_List_Member
(N
));
28496 -- For pragma SPARK_Mode to be private, it has to appear in the private
28497 -- declarations of a package.
28500 Present
(Parent
(N
))
28501 and then Nkind
(Parent
(N
)) = N_Package_Specification
28502 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
28503 end Is_Private_SPARK_Mode
;
28505 -------------------------------------
28506 -- Is_Unconstrained_Or_Tagged_Item --
28507 -------------------------------------
28509 function Is_Unconstrained_Or_Tagged_Item
28510 (Item
: Entity_Id
) return Boolean
28512 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
28513 -- Determine whether record type Typ has at least one unconstrained
28516 ---------------------------------
28517 -- Has_Unconstrained_Component --
28518 ---------------------------------
28520 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
28524 Comp
:= First_Component
(Typ
);
28525 while Present
(Comp
) loop
28526 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
28530 Next_Component
(Comp
);
28534 end Has_Unconstrained_Component
;
28538 Typ
: constant Entity_Id
:= Etype
(Item
);
28540 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28543 if Is_Tagged_Type
(Typ
) then
28546 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
28549 elsif Is_Record_Type
(Typ
) then
28550 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
28553 return Has_Unconstrained_Component
(Typ
);
28556 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
28562 end Is_Unconstrained_Or_Tagged_Item
;
28564 -----------------------------
28565 -- Is_Valid_Assertion_Kind --
28566 -----------------------------
28568 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
28575 Name_Static_Predicate |
28576 Name_Dynamic_Predicate |
28581 Name_Type_Invariant |
28582 Name_uType_Invariant |
28586 Name_Assert_And_Cut |
28588 Name_Contract_Cases |
28590 Name_Default_Initial_Condition |
28592 Name_Initial_Condition |
28595 Name_Loop_Invariant |
28596 Name_Loop_Variant |
28597 Name_Postcondition |
28598 Name_Precondition |
28600 Name_Refined_Post |
28601 Name_Statement_Assertions
=> return True;
28603 when others => return False;
28605 end Is_Valid_Assertion_Kind
;
28607 --------------------------------------
28608 -- Process_Compilation_Unit_Pragmas --
28609 --------------------------------------
28611 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
28613 -- A special check for pragma Suppress_All, a very strange DEC pragma,
28614 -- strange because it comes at the end of the unit. Rational has the
28615 -- same name for a pragma, but treats it as a program unit pragma, In
28616 -- GNAT we just decide to allow it anywhere at all. If it appeared then
28617 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
28618 -- node, and we insert a pragma Suppress (All_Checks) at the start of
28619 -- the context clause to ensure the correct processing.
28621 if Has_Pragma_Suppress_All
(N
) then
28622 Prepend_To
(Context_Items
(N
),
28623 Make_Pragma
(Sloc
(N
),
28624 Chars
=> Name_Suppress
,
28625 Pragma_Argument_Associations
=> New_List
(
28626 Make_Pragma_Argument_Association
(Sloc
(N
),
28627 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
28630 -- Nothing else to do at the current time
28632 end Process_Compilation_Unit_Pragmas
;
28634 ------------------------------------
28635 -- Record_Possible_Body_Reference --
28636 ------------------------------------
28638 procedure Record_Possible_Body_Reference
28639 (State_Id
: Entity_Id
;
28643 Spec_Id
: Entity_Id
;
28646 -- Ensure that we are dealing with a reference to a state
28648 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
28650 -- Climb the tree starting from the reference looking for a package body
28651 -- whose spec declares the referenced state. This criteria automatically
28652 -- excludes references in package specs which are legal. Note that it is
28653 -- not wise to emit an error now as the package body may lack pragma
28654 -- Refined_State or the referenced state may not be mentioned in the
28655 -- refinement. This approach avoids the generation of misleading errors.
28658 while Present
(Context
) loop
28659 if Nkind
(Context
) = N_Package_Body
then
28660 Spec_Id
:= Corresponding_Spec
(Context
);
28662 if Present
(Abstract_States
(Spec_Id
))
28663 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
28665 if No
(Body_References
(State_Id
)) then
28666 Set_Body_References
(State_Id
, New_Elmt_List
);
28669 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
28674 Context
:= Parent
(Context
);
28676 end Record_Possible_Body_Reference
;
28678 ------------------------------------------
28679 -- Relocate_Pragmas_To_Anonymous_Object --
28680 ------------------------------------------
28682 procedure Relocate_Pragmas_To_Anonymous_Object
28683 (Typ_Decl
: Node_Id
;
28684 Obj_Decl
: Node_Id
)
28688 Next_Decl
: Node_Id
;
28691 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
28692 Def
:= Protected_Definition
(Typ_Decl
);
28694 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
28695 Def
:= Task_Definition
(Typ_Decl
);
28698 -- The concurrent definition has a visible declaration list. Inspect it
28699 -- and relocate all canidate pragmas.
28701 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
28702 Decl
:= First
(Visible_Declarations
(Def
));
28703 while Present
(Decl
) loop
28705 -- Preserve the following declaration for iteration purposes due
28706 -- to possible relocation of a pragma.
28708 Next_Decl
:= Next
(Decl
);
28710 if Nkind
(Decl
) = N_Pragma
28711 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
28714 Insert_After
(Obj_Decl
, Decl
);
28716 -- Skip internally generated code
28718 elsif not Comes_From_Source
(Decl
) then
28721 -- No candidate pragmas are available for relocation
28730 end Relocate_Pragmas_To_Anonymous_Object
;
28732 ------------------------------
28733 -- Relocate_Pragmas_To_Body --
28734 ------------------------------
28736 procedure Relocate_Pragmas_To_Body
28737 (Subp_Body
: Node_Id
;
28738 Target_Body
: Node_Id
:= Empty
)
28740 procedure Relocate_Pragma
(Prag
: Node_Id
);
28741 -- Remove a single pragma from its current list and add it to the
28742 -- declarations of the proper body (either Subp_Body or Target_Body).
28744 ---------------------
28745 -- Relocate_Pragma --
28746 ---------------------
28748 procedure Relocate_Pragma
(Prag
: Node_Id
) is
28753 -- When subprogram stubs or expression functions are involves, the
28754 -- destination declaration list belongs to the proper body.
28756 if Present
(Target_Body
) then
28757 Target
:= Target_Body
;
28759 Target
:= Subp_Body
;
28762 Decls
:= Declarations
(Target
);
28766 Set_Declarations
(Target
, Decls
);
28769 -- Unhook the pragma from its current list
28772 Prepend
(Prag
, Decls
);
28773 end Relocate_Pragma
;
28777 Body_Id
: constant Entity_Id
:=
28778 Defining_Unit_Name
(Specification
(Subp_Body
));
28779 Next_Stmt
: Node_Id
;
28782 -- Start of processing for Relocate_Pragmas_To_Body
28785 -- Do not process a body that comes from a separate unit as no construct
28786 -- can possibly follow it.
28788 if not Is_List_Member
(Subp_Body
) then
28791 -- Do not relocate pragmas that follow a stub if the stub does not have
28794 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
28795 and then No
(Target_Body
)
28799 -- Do not process internally generated routine _Postconditions
28801 elsif Ekind
(Body_Id
) = E_Procedure
28802 and then Chars
(Body_Id
) = Name_uPostconditions
28807 -- Look at what is following the body. We are interested in certain kind
28808 -- of pragmas (either from source or byproducts of expansion) that can
28809 -- apply to a body [stub].
28811 Stmt
:= Next
(Subp_Body
);
28812 while Present
(Stmt
) loop
28814 -- Preserve the following statement for iteration purposes due to a
28815 -- possible relocation of a pragma.
28817 Next_Stmt
:= Next
(Stmt
);
28819 -- Move a candidate pragma following the body to the declarations of
28822 if Nkind
(Stmt
) = N_Pragma
28823 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
28825 Relocate_Pragma
(Stmt
);
28827 -- Skip internally generated code
28829 elsif not Comes_From_Source
(Stmt
) then
28832 -- No candidate pragmas are available for relocation
28840 end Relocate_Pragmas_To_Body
;
28842 -------------------
28843 -- Resolve_State --
28844 -------------------
28846 procedure Resolve_State
(N
: Node_Id
) is
28851 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
28852 Func
:= Entity
(N
);
28854 -- Handle overloading of state names by functions. Traverse the
28855 -- homonym chain looking for an abstract state.
28857 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
28858 State
:= Homonym
(Func
);
28859 while Present
(State
) loop
28861 -- Resolve the overloading by setting the proper entity of the
28862 -- reference to that of the state.
28864 if Ekind
(State
) = E_Abstract_State
then
28865 Set_Etype
(N
, Standard_Void_Type
);
28866 Set_Entity
(N
, State
);
28867 Set_Associated_Node
(N
, State
);
28871 State
:= Homonym
(State
);
28874 -- A function can never act as a state. If the homonym chain does
28875 -- not contain a corresponding state, then something went wrong in
28876 -- the overloading mechanism.
28878 raise Program_Error
;
28883 ----------------------------
28884 -- Rewrite_Assertion_Kind --
28885 ----------------------------
28887 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
28891 if Nkind
(N
) = N_Attribute_Reference
28892 and then Attribute_Name
(N
) = Name_Class
28893 and then Nkind
(Prefix
(N
)) = N_Identifier
28895 case Chars
(Prefix
(N
)) is
28900 when Name_Type_Invariant
=>
28901 Nam
:= Name_uType_Invariant
;
28902 when Name_Invariant
=>
28903 Nam
:= Name_uInvariant
;
28908 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
28910 end Rewrite_Assertion_Kind
;
28918 Dummy
:= Dummy
+ 1;
28921 --------------------------------
28922 -- Set_Encoded_Interface_Name --
28923 --------------------------------
28925 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
28926 Str
: constant String_Id
:= Strval
(S
);
28927 Len
: constant Nat
:= String_Length
(Str
);
28932 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
28935 -- Stores encoded value of character code CC. The encoding we use an
28936 -- underscore followed by four lower case hex digits.
28942 procedure Encode
is
28944 Store_String_Char
(Get_Char_Code
('_'));
28946 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
28948 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
28950 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
28952 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
28955 -- Start of processing for Set_Encoded_Interface_Name
28958 -- If first character is asterisk, this is a link name, and we leave it
28959 -- completely unmodified. We also ignore null strings (the latter case
28960 -- happens only in error cases) and no encoding should occur for AAMP
28961 -- interface names.
28964 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
28965 or else AAMP_On_Target
28967 Set_Interface_Name
(E
, S
);
28972 CC
:= Get_String_Char
(Str
, J
);
28974 exit when not In_Character_Range
(CC
);
28976 C
:= Get_Character
(CC
);
28978 exit when C
/= '_' and then C
/= '$'
28979 and then C
not in '0' .. '9'
28980 and then C
not in 'a' .. 'z'
28981 and then C
not in 'A' .. 'Z';
28984 Set_Interface_Name
(E
, S
);
28992 -- Here we need to encode. The encoding we use as follows:
28993 -- three underscores + four hex digits (lower case)
28997 for J
in 1 .. String_Length
(Str
) loop
28998 CC
:= Get_String_Char
(Str
, J
);
29000 if not In_Character_Range
(CC
) then
29003 C
:= Get_Character
(CC
);
29005 if C
= '_' or else C
= '$'
29006 or else C
in '0' .. '9'
29007 or else C
in 'a' .. 'z'
29008 or else C
in 'A' .. 'Z'
29010 Store_String_Char
(CC
);
29017 Set_Interface_Name
(E
,
29018 Make_String_Literal
(Sloc
(S
),
29019 Strval
=> End_String
));
29021 end Set_Encoded_Interface_Name
;
29023 ------------------------
29024 -- Set_Elab_Unit_Name --
29025 ------------------------
29027 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
29032 if Nkind
(N
) = N_Identifier
29033 and then Nkind
(With_Item
) = N_Identifier
29035 Set_Entity
(N
, Entity
(With_Item
));
29037 elsif Nkind
(N
) = N_Selected_Component
then
29038 Change_Selected_Component_To_Expanded_Name
(N
);
29039 Set_Entity
(N
, Entity
(With_Item
));
29040 Set_Entity
(Selector_Name
(N
), Entity
(N
));
29042 Pref
:= Prefix
(N
);
29043 Scop
:= Scope
(Entity
(N
));
29044 while Nkind
(Pref
) = N_Selected_Component
loop
29045 Change_Selected_Component_To_Expanded_Name
(Pref
);
29046 Set_Entity
(Selector_Name
(Pref
), Scop
);
29047 Set_Entity
(Pref
, Scop
);
29048 Pref
:= Prefix
(Pref
);
29049 Scop
:= Scope
(Scop
);
29052 Set_Entity
(Pref
, Scop
);
29055 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
29056 end Set_Elab_Unit_Name
;
29058 -------------------
29059 -- Test_Case_Arg --
29060 -------------------
29062 function Test_Case_Arg
29065 From_Aspect
: Boolean := False) return Node_Id
29067 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
29072 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
29077 -- The caller requests the aspect argument
29079 if From_Aspect
then
29080 if Present
(Aspect
)
29081 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
29083 Args
:= Expression
(Aspect
);
29085 -- "Name" and "Mode" may appear without an identifier as a
29086 -- positional association.
29088 if Present
(Expressions
(Args
)) then
29089 Arg
:= First
(Expressions
(Args
));
29091 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29099 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29104 -- Some or all arguments may appear as component associatons
29106 if Present
(Component_Associations
(Args
)) then
29107 Arg
:= First
(Component_Associations
(Args
));
29108 while Present
(Arg
) loop
29109 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
29118 -- Otherwise retrieve the argument directly from the pragma
29121 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29123 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29127 -- Skip argument "Name"
29131 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29135 -- Skip argument "Mode"
29139 -- Arguments "Requires" and "Ensures" are optional and may not be
29142 while Present
(Arg
) loop
29143 if Chars
(Arg
) = Arg_Nam
then