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_Ch7
; use Exp_Ch7
;
43 with Exp_Dist
; use Exp_Dist
;
44 with Exp_Util
; use Exp_Util
;
45 with Freeze
; use Freeze
;
46 with Ghost
; use Ghost
;
47 with Gnatvsn
; use Gnatvsn
;
49 with Lib
.Writ
; use Lib
.Writ
;
50 with Lib
.Xref
; use Lib
.Xref
;
51 with Namet
.Sp
; use Namet
.Sp
;
52 with Nlists
; use Nlists
;
53 with Nmake
; use Nmake
;
54 with Output
; use Output
;
55 with Par_SCO
; use Par_SCO
;
56 with Restrict
; use Restrict
;
57 with Rident
; use Rident
;
58 with Rtsfind
; use Rtsfind
;
60 with Sem_Aux
; use Sem_Aux
;
61 with Sem_Ch3
; use Sem_Ch3
;
62 with Sem_Ch6
; use Sem_Ch6
;
63 with Sem_Ch8
; use Sem_Ch8
;
64 with Sem_Ch12
; use Sem_Ch12
;
65 with Sem_Ch13
; use Sem_Ch13
;
66 with Sem_Disp
; use Sem_Disp
;
67 with Sem_Dist
; use Sem_Dist
;
68 with Sem_Elim
; use Sem_Elim
;
69 with Sem_Eval
; use Sem_Eval
;
70 with Sem_Intr
; use Sem_Intr
;
71 with Sem_Mech
; use Sem_Mech
;
72 with Sem_Res
; use Sem_Res
;
73 with Sem_Type
; use Sem_Type
;
74 with Sem_Util
; use Sem_Util
;
75 with Sem_Warn
; use Sem_Warn
;
76 with Stand
; use Stand
;
77 with Sinfo
; use Sinfo
;
78 with Sinfo
.CN
; use Sinfo
.CN
;
79 with Sinput
; use Sinput
;
80 with Stringt
; use Stringt
;
81 with Stylesw
; use Stylesw
;
83 with Targparm
; use Targparm
;
84 with Tbuild
; use Tbuild
;
86 with Uintp
; use Uintp
;
87 with Uname
; use Uname
;
88 with Urealp
; use Urealp
;
89 with Validsw
; use Validsw
;
90 with Warnsw
; use Warnsw
;
92 with GNAT
.HTable
; use GNAT
.HTable
;
94 package body Sem_Prag
is
96 ----------------------------------------------
97 -- Common Handling of Import-Export Pragmas --
98 ----------------------------------------------
100 -- In the following section, a number of Import_xxx and Export_xxx pragmas
101 -- are defined by GNAT. These are compatible with the DEC pragmas of the
102 -- same name, and all have the following common form and processing:
105 -- [Internal =>] LOCAL_NAME
106 -- [, [External =>] EXTERNAL_SYMBOL]
107 -- [, other optional parameters ]);
110 -- [Internal =>] LOCAL_NAME
111 -- [, [External =>] EXTERNAL_SYMBOL]
112 -- [, other optional parameters ]);
114 -- EXTERNAL_SYMBOL ::=
116 -- | static_string_EXPRESSION
118 -- The internal LOCAL_NAME designates the entity that is imported or
119 -- exported, and must refer to an entity in the current declarative
120 -- part (as required by the rules for LOCAL_NAME).
122 -- The external linker name is designated by the External parameter if
123 -- given, or the Internal parameter if not (if there is no External
124 -- parameter, the External parameter is a copy of the Internal name).
126 -- If the External parameter is given as a string, then this string is
127 -- treated as an external name (exactly as though it had been given as an
128 -- External_Name parameter for a normal Import pragma).
130 -- If the External parameter is given as an identifier (or there is no
131 -- External parameter, so that the Internal identifier is used), then
132 -- the external name is the characters of the identifier, translated
133 -- to all lower case letters.
135 -- Note: the external name specified or implied by any of these special
136 -- Import_xxx or Export_xxx pragmas override an external or link name
137 -- specified in a previous Import or Export pragma.
139 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
140 -- named notation, following the standard rules for subprogram calls, i.e.
141 -- parameters can be given in any order if named notation is used, and
142 -- positional and named notation can be mixed, subject to the rule that all
143 -- positional parameters must appear first.
145 -- Note: All these pragmas are implemented exactly following the DEC design
146 -- and implementation and are intended to be fully compatible with the use
147 -- of these pragmas in the DEC Ada compiler.
149 --------------------------------------------
150 -- Checking for Duplicated External Names --
151 --------------------------------------------
153 -- It is suspicious if two separate Export pragmas use the same external
154 -- name. The following table is used to diagnose this situation so that
155 -- an appropriate warning can be issued.
157 -- The Node_Id stored is for the N_String_Literal node created to hold
158 -- the value of the external name. The Sloc of this node is used to
159 -- cross-reference the location of the duplication.
161 package Externals
is new Table
.Table
(
162 Table_Component_Type
=> Node_Id
,
163 Table_Index_Type
=> Int
,
164 Table_Low_Bound
=> 0,
165 Table_Initial
=> 100,
166 Table_Increment
=> 100,
167 Table_Name
=> "Name_Externals");
169 ---------------------------------------------------------
170 -- Handling of inherited class-wide pre/postconditions --
171 ---------------------------------------------------------
173 -- Following AI12-0113, the expression for a class-wide condition is
174 -- transformed for a subprogram that inherits it, by replacing calls
175 -- to primitive operations of the original controlling type into the
176 -- corresponding overriding operations of the derived type. The following
177 -- hash table manages this mapping, and is expanded on demand whenever
178 -- such inherited expression needs to be constructed.
180 -- The mapping is also used to check whether an inherited operation has
181 -- a condition that depends on overridden operations. For such an
182 -- operation we must create a wrapper that is then treated as a normal
183 -- overriding. In SPARK mode such operations are illegal.
185 -- For a given root type there may be several type extensions with their
186 -- own overriding operations, so at various times a given operation of
187 -- the root will be mapped into different overridings. The root type is
188 -- also mapped into the current type extension to indicate that its
189 -- operations are mapped into the overriding operations of that current
192 subtype Num_Primitives
is Integer range 0 .. 510;
193 function Entity_Hash
(E
: Entity_Id
) return Num_Primitives
;
195 package Primitives_Mapping
is new Gnat
.HTable
.Simple_Htable
196 (Header_Num
=> Num_Primitives
,
198 Element
=> Entity_Id
,
203 -------------------------------------
204 -- Local Subprograms and Variables --
205 -------------------------------------
207 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
208 -- This routine is used for possible casing adjustment of an explicit
209 -- external name supplied as a string literal (the node N), according to
210 -- the casing requirement of Opt.External_Name_Casing. If this is set to
211 -- As_Is, then the string literal is returned unchanged, but if it is set
212 -- to Uppercase or Lowercase, then a new string literal with appropriate
213 -- casing is constructed.
215 procedure Analyze_Part_Of
219 Encap_Id
: out Entity_Id
;
220 Legal
: out Boolean);
221 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
222 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
223 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
224 -- package instantiation. Encap denotes the encapsulating state or single
225 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
226 -- the indicator is legal.
228 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
229 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
230 -- Query whether a particular item appears in a mixed list of nodes and
231 -- entities. It is assumed that all nodes in the list have entities.
233 procedure Check_Postcondition_Use_In_Inlined_Subprogram
235 Spec_Id
: Entity_Id
);
236 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
237 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
238 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
240 procedure Check_State_And_Constituent_Use
244 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
245 -- Global and Initializes. Determine whether a state from list States and a
246 -- corresponding constituent from list Constits (if any) appear in the same
247 -- context denoted by Context. If this is the case, emit an error.
249 procedure Contract_Freeze_Error
250 (Contract_Id
: Entity_Id
;
251 Freeze_Id
: Entity_Id
);
252 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
253 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
254 -- of a body which caused contract "freezing" and Contract_Id denotes the
255 -- entity of the affected contstruct.
257 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
258 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
259 -- Prag that duplicates previous pragma Prev.
261 function Find_Encapsulating_State
263 Constit_Id
: Entity_Id
) return Entity_Id
;
264 -- Given the entity of a constituent Constit_Id, find the corresponding
265 -- encapsulating state which appears in States. The routine returns Empty
266 -- if no such state is found.
268 function Find_Related_Context
270 Do_Checks
: Boolean := False) return Node_Id
;
271 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
272 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
273 -- Part_Of. Find the first source declaration or statement found while
274 -- traversing the previous node chain starting from pragma Prag. If flag
275 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
276 -- returns Empty when reaching the start of the node chain.
278 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
279 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
280 -- original one, following the renaming chain) is returned. Otherwise the
281 -- entity is returned unchanged. Should be in Einfo???
283 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
284 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
285 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
286 -- value of type SPARK_Mode_Type.
288 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
289 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
290 -- Determine whether dependency clause Clause is surrounded by extra
291 -- parentheses. If this is the case, issue an error message.
293 function Is_CCT_Instance
295 Context_Id
: Entity_Id
) return Boolean;
296 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
297 -- Global. Determine whether entity Ref_Id denotes the current instance of
298 -- a concurrent type. Context_Id denotes the associated context where the
301 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
302 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
303 -- pragma Depends. Determine whether the type of dependency item Item is
304 -- tagged, unconstrained array, unconstrained record or a record with at
305 -- least one unconstrained component.
307 procedure Record_Possible_Body_Reference
308 (State_Id
: Entity_Id
;
310 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
311 -- Global. Given an abstract state denoted by State_Id and a reference Ref
312 -- to it, determine whether the reference appears in a package body that
313 -- will eventually refine the state. If this is the case, record the
314 -- reference for future checks (see Analyze_Refined_State_In_Decls).
316 procedure Resolve_State
(N
: Node_Id
);
317 -- Handle the overloading of state names by functions. When N denotes a
318 -- function, this routine finds the corresponding state and sets the entity
319 -- of N to that of the state.
321 procedure Rewrite_Assertion_Kind
(N
: Node_Id
);
322 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
323 -- then it is rewritten as an identifier with the corresponding special
324 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
327 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
328 -- Place semantic information on the argument of an Elaborate/Elaborate_All
329 -- pragma. Entity name for unit and its parents is taken from item in
330 -- previous with_clause that mentions the unit.
332 Dummy
: Integer := 0;
333 pragma Volatile
(Dummy
);
334 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
337 pragma No_Inline
(ip
);
338 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
339 -- is just to help debugging the front end. If a pragma Inspection_Point
340 -- is added to a source program, then breaking on ip will get you to that
341 -- point in the program.
344 pragma No_Inline
(rv
);
345 -- This is a dummy function called by the processing for pragma Reviewable.
346 -- It is there for assisting front end debugging. By placing a Reviewable
347 -- pragma in the source program, a breakpoint on rv catches this place in
348 -- the source, allowing convenient stepping to the point of interest.
350 -------------------------------
351 -- Adjust_External_Name_Case --
352 -------------------------------
354 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
358 -- Adjust case of literal if required
360 if Opt
.External_Name_Exp_Casing
= As_Is
then
364 -- Copy existing string
370 for J
in 1 .. String_Length
(Strval
(N
)) loop
371 CC
:= Get_String_Char
(Strval
(N
), J
);
373 if Opt
.External_Name_Exp_Casing
= Uppercase
374 and then CC
>= Get_Char_Code
('a')
375 and then CC
<= Get_Char_Code
('z')
377 Store_String_Char
(CC
- 32);
379 elsif Opt
.External_Name_Exp_Casing
= Lowercase
380 and then CC
>= Get_Char_Code
('A')
381 and then CC
<= Get_Char_Code
('Z')
383 Store_String_Char
(CC
+ 32);
386 Store_String_Char
(CC
);
391 Make_String_Literal
(Sloc
(N
),
392 Strval
=> End_String
);
394 end Adjust_External_Name_Case
;
396 -----------------------------------------
397 -- Analyze_Contract_Cases_In_Decl_Part --
398 -----------------------------------------
400 procedure Analyze_Contract_Cases_In_Decl_Part
402 Freeze_Id
: Entity_Id
:= Empty
)
404 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
405 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
407 Others_Seen
: Boolean := False;
408 -- This flag is set when an "others" choice is encountered. It is used
409 -- to detect multiple illegal occurrences of "others".
411 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
412 -- Verify the legality of a single contract case
414 ---------------------------
415 -- Analyze_Contract_Case --
416 ---------------------------
418 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
419 Case_Guard
: Node_Id
;
422 Extra_Guard
: Node_Id
;
425 if Nkind
(CCase
) = N_Component_Association
then
426 Case_Guard
:= First
(Choices
(CCase
));
427 Conseq
:= Expression
(CCase
);
429 -- Each contract case must have exactly one case guard
431 Extra_Guard
:= Next
(Case_Guard
);
433 if Present
(Extra_Guard
) then
435 ("contract case must have exactly one case guard",
439 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
441 if Nkind
(Case_Guard
) = N_Others_Choice
then
444 ("only one others choice allowed in contract cases",
450 elsif Others_Seen
then
452 ("others must be the last choice in contract cases", N
);
455 -- Preanalyze the case guard and consequence
457 if Nkind
(Case_Guard
) /= N_Others_Choice
then
458 Errors
:= Serious_Errors_Detected
;
459 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
461 -- Emit a clarification message when the case guard contains
462 -- at least one undefined reference, possibly due to contract
465 if Errors
/= Serious_Errors_Detected
466 and then Present
(Freeze_Id
)
467 and then Has_Undefined_Reference
(Case_Guard
)
469 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
473 Errors
:= Serious_Errors_Detected
;
474 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
476 -- Emit a clarification message when the consequence contains
477 -- at least one undefined reference, possibly due to contract
480 if Errors
/= Serious_Errors_Detected
481 and then Present
(Freeze_Id
)
482 and then Has_Undefined_Reference
(Conseq
)
484 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
487 -- The contract case is malformed
490 Error_Msg_N
("wrong syntax in contract case", CCase
);
492 end Analyze_Contract_Case
;
496 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
498 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
501 Restore_Scope
: Boolean := False;
503 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
506 -- Do not analyze the pragma multiple times
508 if Is_Analyzed_Pragma
(N
) then
512 -- Set the Ghost mode in effect from the pragma. Due to the delayed
513 -- analysis of the pragma, the Ghost mode at point of declaration and
514 -- point of analysis may not necessarily be the same. Use the mode in
515 -- effect at the point of declaration.
519 -- Single and multiple contract cases must appear in aggregate form. If
520 -- this is not the case, then either the parser of the analysis of the
521 -- pragma failed to produce an aggregate.
523 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
525 if Present
(Component_Associations
(CCases
)) then
527 -- Ensure that the formal parameters are visible when analyzing all
528 -- clauses. This falls out of the general rule of aspects pertaining
529 -- to subprogram declarations.
531 if not In_Open_Scopes
(Spec_Id
) then
532 Restore_Scope
:= True;
533 Push_Scope
(Spec_Id
);
535 if Is_Generic_Subprogram
(Spec_Id
) then
536 Install_Generic_Formals
(Spec_Id
);
538 Install_Formals
(Spec_Id
);
542 CCase
:= First
(Component_Associations
(CCases
));
543 while Present
(CCase
) loop
544 Analyze_Contract_Case
(CCase
);
548 if Restore_Scope
then
552 -- Currently it is not possible to inline pre/postconditions on a
553 -- subprogram subject to pragma Inline_Always.
555 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
557 -- Otherwise the pragma is illegal
560 Error_Msg_N
("wrong syntax for constract cases", N
);
563 Ghost_Mode
:= Save_Ghost_Mode
;
564 Set_Is_Analyzed_Pragma
(N
);
565 end Analyze_Contract_Cases_In_Decl_Part
;
567 ----------------------------------
568 -- Analyze_Depends_In_Decl_Part --
569 ----------------------------------
571 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
572 Loc
: constant Source_Ptr
:= Sloc
(N
);
573 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
574 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
576 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
577 -- A list containing the entities of all the inputs processed so far.
578 -- The list is populated with unique entities because the same input
579 -- may appear in multiple input lists.
581 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
582 -- A list containing the entities of all the outputs processed so far.
583 -- The list is populated with unique entities because output items are
584 -- unique in a dependence relation.
586 Constits_Seen
: Elist_Id
:= No_Elist
;
587 -- A list containing the entities of all constituents processed so far.
588 -- It aids in detecting illegal usage of a state and a corresponding
589 -- constituent in pragma [Refinde_]Depends.
591 Global_Seen
: Boolean := False;
592 -- A flag set when pragma Global has been processed
594 Null_Output_Seen
: Boolean := False;
595 -- A flag used to track the legality of a null output
597 Result_Seen
: Boolean := False;
598 -- A flag set when Spec_Id'Result is processed
600 States_Seen
: Elist_Id
:= No_Elist
;
601 -- A list containing the entities of all states processed so far. It
602 -- helps in detecting illegal usage of a state and a corresponding
603 -- constituent in pragma [Refined_]Depends.
605 Subp_Inputs
: Elist_Id
:= No_Elist
;
606 Subp_Outputs
: Elist_Id
:= No_Elist
;
607 -- Two lists containing the full set of inputs and output of the related
608 -- subprograms. Note that these lists contain both nodes and entities.
610 Task_Input_Seen
: Boolean := False;
611 Task_Output_Seen
: Boolean := False;
612 -- Flags used to track the implicit dependence of a task unit on itself
614 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
615 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
616 -- to the name buffer. The individual kinds are as follows:
617 -- E_Abstract_State - "state"
618 -- E_Constant - "constant"
619 -- E_Discriminant - "discriminant"
620 -- E_Generic_In_Out_Parameter - "generic parameter"
621 -- E_Generic_In_Parameter - "generic parameter"
622 -- E_In_Parameter - "parameter"
623 -- E_In_Out_Parameter - "parameter"
624 -- E_Loop_Parameter - "loop parameter"
625 -- E_Out_Parameter - "parameter"
626 -- E_Protected_Type - "current instance of protected type"
627 -- E_Task_Type - "current instance of task type"
628 -- E_Variable - "global"
630 procedure Analyze_Dependency_Clause
633 -- Verify the legality of a single dependency clause. Flag Is_Last
634 -- denotes whether Clause is the last clause in the relation.
636 procedure Check_Function_Return
;
637 -- Verify that Funtion'Result appears as one of the outputs
638 -- (SPARK RM 6.1.5(10)).
645 -- Ensure that an item fulfills its designated input and/or output role
646 -- as specified by pragma Global (if any) or the enclosing context. If
647 -- this is not the case, emit an error. Item and Item_Id denote the
648 -- attributes of an item. Flag Is_Input should be set when item comes
649 -- from an input list. Flag Self_Ref should be set when the item is an
650 -- output and the dependency clause has operator "+".
652 procedure Check_Usage
653 (Subp_Items
: Elist_Id
;
654 Used_Items
: Elist_Id
;
656 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
657 -- error if this is not the case.
659 procedure Normalize_Clause
(Clause
: Node_Id
);
660 -- Remove a self-dependency "+" from the input list of a clause
662 -----------------------------
663 -- Add_Item_To_Name_Buffer --
664 -----------------------------
666 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
668 if Ekind
(Item_Id
) = E_Abstract_State
then
669 Add_Str_To_Name_Buffer
("state");
671 elsif Ekind
(Item_Id
) = E_Constant
then
672 Add_Str_To_Name_Buffer
("constant");
674 elsif Ekind
(Item_Id
) = E_Discriminant
then
675 Add_Str_To_Name_Buffer
("discriminant");
677 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
678 E_Generic_In_Parameter
)
680 Add_Str_To_Name_Buffer
("generic parameter");
682 elsif Is_Formal
(Item_Id
) then
683 Add_Str_To_Name_Buffer
("parameter");
685 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
686 Add_Str_To_Name_Buffer
("loop parameter");
688 elsif Ekind
(Item_Id
) = E_Protected_Type
689 or else Is_Single_Protected_Object
(Item_Id
)
691 Add_Str_To_Name_Buffer
("current instance of protected type");
693 elsif Ekind
(Item_Id
) = E_Task_Type
694 or else Is_Single_Task_Object
(Item_Id
)
696 Add_Str_To_Name_Buffer
("current instance of task type");
698 elsif Ekind
(Item_Id
) = E_Variable
then
699 Add_Str_To_Name_Buffer
("global");
701 -- The routine should not be called with non-SPARK items
706 end Add_Item_To_Name_Buffer
;
708 -------------------------------
709 -- Analyze_Dependency_Clause --
710 -------------------------------
712 procedure Analyze_Dependency_Clause
716 procedure Analyze_Input_List
(Inputs
: Node_Id
);
717 -- Verify the legality of a single input list
719 procedure Analyze_Input_Output
724 Seen
: in out Elist_Id
;
725 Null_Seen
: in out Boolean;
726 Non_Null_Seen
: in out Boolean);
727 -- Verify the legality of a single input or output item. Flag
728 -- Is_Input should be set whenever Item is an input, False when it
729 -- denotes an output. Flag Self_Ref should be set when the item is an
730 -- output and the dependency clause has a "+". Flag Top_Level should
731 -- be set whenever Item appears immediately within an input or output
732 -- list. Seen is a collection of all abstract states, objects and
733 -- formals processed so far. Flag Null_Seen denotes whether a null
734 -- input or output has been encountered. Flag Non_Null_Seen denotes
735 -- whether a non-null input or output has been encountered.
737 ------------------------
738 -- Analyze_Input_List --
739 ------------------------
741 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
742 Inputs_Seen
: Elist_Id
:= No_Elist
;
743 -- A list containing the entities of all inputs that appear in the
744 -- current input list.
746 Non_Null_Input_Seen
: Boolean := False;
747 Null_Input_Seen
: Boolean := False;
748 -- Flags used to check the legality of an input list
753 -- Multiple inputs appear as an aggregate
755 if Nkind
(Inputs
) = N_Aggregate
then
756 if Present
(Component_Associations
(Inputs
)) then
758 ("nested dependency relations not allowed", Inputs
);
760 elsif Present
(Expressions
(Inputs
)) then
761 Input
:= First
(Expressions
(Inputs
));
762 while Present
(Input
) loop
769 Null_Seen
=> Null_Input_Seen
,
770 Non_Null_Seen
=> Non_Null_Input_Seen
);
775 -- Syntax error, always report
778 Error_Msg_N
("malformed input dependency list", Inputs
);
781 -- Process a solitary input
790 Null_Seen
=> Null_Input_Seen
,
791 Non_Null_Seen
=> Non_Null_Input_Seen
);
794 -- Detect an illegal dependency clause of the form
798 if Null_Output_Seen
and then Null_Input_Seen
then
800 ("null dependency clause cannot have a null input list",
803 end Analyze_Input_List
;
805 --------------------------
806 -- Analyze_Input_Output --
807 --------------------------
809 procedure Analyze_Input_Output
814 Seen
: in out Elist_Id
;
815 Null_Seen
: in out Boolean;
816 Non_Null_Seen
: in out Boolean)
818 procedure Current_Task_Instance_Seen
;
819 -- Set the appropriate global flag when the current instance of a
820 -- task unit is encountered.
822 --------------------------------
823 -- Current_Task_Instance_Seen --
824 --------------------------------
826 procedure Current_Task_Instance_Seen
is
829 Task_Input_Seen
:= True;
831 Task_Output_Seen
:= True;
833 end Current_Task_Instance_Seen
;
837 Is_Output
: constant Boolean := not Is_Input
;
841 -- Start of processing for Analyze_Input_Output
844 -- Multiple input or output items appear as an aggregate
846 if Nkind
(Item
) = N_Aggregate
then
847 if not Top_Level
then
848 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
850 elsif Present
(Component_Associations
(Item
)) then
852 ("nested dependency relations not allowed", Item
);
854 -- Recursively analyze the grouped items
856 elsif Present
(Expressions
(Item
)) then
857 Grouped
:= First
(Expressions
(Item
));
858 while Present
(Grouped
) loop
861 Is_Input
=> Is_Input
,
862 Self_Ref
=> Self_Ref
,
865 Null_Seen
=> Null_Seen
,
866 Non_Null_Seen
=> Non_Null_Seen
);
871 -- Syntax error, always report
874 Error_Msg_N
("malformed dependency list", Item
);
877 -- Process attribute 'Result in the context of a dependency clause
879 elsif Is_Attribute_Result
(Item
) then
880 Non_Null_Seen
:= True;
884 -- Attribute 'Result is allowed to appear on the output side of
885 -- a dependency clause (SPARK RM 6.1.5(6)).
888 SPARK_Msg_N
("function result cannot act as input", Item
);
892 ("cannot mix null and non-null dependency items", Item
);
898 -- Detect multiple uses of null in a single dependency list or
899 -- throughout the whole relation. Verify the placement of a null
900 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
902 elsif Nkind
(Item
) = N_Null
then
905 ("multiple null dependency relations not allowed", Item
);
907 elsif Non_Null_Seen
then
909 ("cannot mix null and non-null dependency items", Item
);
917 ("null output list must be the last clause in a "
918 & "dependency relation", Item
);
920 -- Catch a useless dependence of the form:
925 ("useless dependence, null depends on itself", Item
);
933 Non_Null_Seen
:= True;
936 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
940 Resolve_State
(Item
);
942 -- Find the entity of the item. If this is a renaming, climb
943 -- the renaming chain to reach the root object. Renamings of
944 -- non-entire objects do not yield an entity (Empty).
946 Item_Id
:= Entity_Of
(Item
);
948 if Present
(Item_Id
) then
952 if Ekind_In
(Item_Id
, E_Constant
,
957 -- Current instances of concurrent types
959 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
964 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
965 E_Generic_In_Parameter
,
973 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
975 -- The item denotes a concurrent type. Note that single
976 -- protected/task types are not considered here because
977 -- they behave as objects in the context of pragma
978 -- [Refined_]Depends.
980 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
982 -- This use is legal as long as the concurrent type is
983 -- the current instance of an enclosing type.
985 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
987 -- The dependence of a task unit on itself is
988 -- implicit and may or may not be explicitly
989 -- specified (SPARK RM 6.1.4).
991 if Ekind
(Item_Id
) = E_Task_Type
then
992 Current_Task_Instance_Seen
;
995 -- Otherwise this is not the current instance
999 ("invalid use of subtype mark in dependency "
1000 & "relation", Item
);
1003 -- The dependency of a task unit on itself is implicit
1004 -- and may or may not be explicitly specified
1005 -- (SPARK RM 6.1.4).
1007 elsif Is_Single_Task_Object
(Item_Id
)
1008 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
1010 Current_Task_Instance_Seen
;
1013 -- Ensure that the item fulfills its role as input and/or
1014 -- output as specified by pragma Global or the enclosing
1017 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
1019 -- Detect multiple uses of the same state, variable or
1020 -- formal parameter. If this is not the case, add the
1021 -- item to the list of processed relations.
1023 if Contains
(Seen
, Item_Id
) then
1025 ("duplicate use of item &", Item
, Item_Id
);
1027 Append_New_Elmt
(Item_Id
, Seen
);
1030 -- Detect illegal use of an input related to a null
1031 -- output. Such input items cannot appear in other
1032 -- input lists (SPARK RM 6.1.5(13)).
1035 and then Null_Output_Seen
1036 and then Contains
(All_Inputs_Seen
, Item_Id
)
1039 ("input of a null output list cannot appear in "
1040 & "multiple input lists", Item
);
1043 -- Add an input or a self-referential output to the list
1044 -- of all processed inputs.
1046 if Is_Input
or else Self_Ref
then
1047 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1050 -- State related checks (SPARK RM 6.1.5(3))
1052 if Ekind
(Item_Id
) = E_Abstract_State
then
1054 -- Package and subprogram bodies are instantiated
1055 -- individually in a separate compiler pass. Due to
1056 -- this mode of instantiation, the refinement of a
1057 -- state may no longer be visible when a subprogram
1058 -- body contract is instantiated. Since the generic
1059 -- template is legal, do not perform this check in
1060 -- the instance to circumvent this oddity.
1062 if Is_Generic_Instance
(Spec_Id
) then
1065 -- An abstract state with visible refinement cannot
1066 -- appear in pragma [Refined_]Depends as its place
1067 -- must be taken by some of its constituents
1068 -- (SPARK RM 6.1.4(7)).
1070 elsif Has_Visible_Refinement
(Item_Id
) then
1072 ("cannot mention state & in dependence relation",
1074 SPARK_Msg_N
("\use its constituents instead", Item
);
1077 -- If the reference to the abstract state appears in
1078 -- an enclosing package body that will eventually
1079 -- refine the state, record the reference for future
1083 Record_Possible_Body_Reference
1084 (State_Id
=> Item_Id
,
1089 -- When the item renames an entire object, replace the
1090 -- item with a reference to the object.
1092 if Entity
(Item
) /= Item_Id
then
1094 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1098 -- Add the entity of the current item to the list of
1101 if Ekind
(Item_Id
) = E_Abstract_State
then
1102 Append_New_Elmt
(Item_Id
, States_Seen
);
1104 -- The variable may eventually become a constituent of a
1105 -- single protected/task type. Record the reference now
1106 -- and verify its legality when analyzing the contract of
1107 -- the variable (SPARK RM 9.3).
1109 elsif Ekind
(Item_Id
) = E_Variable
then
1110 Record_Possible_Part_Of_Reference
1115 if Ekind_In
(Item_Id
, E_Abstract_State
,
1118 and then Present
(Encapsulating_State
(Item_Id
))
1120 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1123 -- All other input/output items are illegal
1124 -- (SPARK RM 6.1.5(1)).
1128 ("item must denote parameter, variable, state or "
1129 & "current instance of concurren type", Item
);
1132 -- All other input/output items are illegal
1133 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1137 ("item must denote parameter, variable, state or current "
1138 & "instance of concurrent type", Item
);
1141 end Analyze_Input_Output
;
1149 Non_Null_Output_Seen
: Boolean := False;
1150 -- Flag used to check the legality of an output list
1152 -- Start of processing for Analyze_Dependency_Clause
1155 Inputs
:= Expression
(Clause
);
1158 -- An input list with a self-dependency appears as operator "+" where
1159 -- the actuals inputs are the right operand.
1161 if Nkind
(Inputs
) = N_Op_Plus
then
1162 Inputs
:= Right_Opnd
(Inputs
);
1166 -- Process the output_list of a dependency_clause
1168 Output
:= First
(Choices
(Clause
));
1169 while Present
(Output
) loop
1170 Analyze_Input_Output
1173 Self_Ref
=> Self_Ref
,
1175 Seen
=> All_Outputs_Seen
,
1176 Null_Seen
=> Null_Output_Seen
,
1177 Non_Null_Seen
=> Non_Null_Output_Seen
);
1182 -- Process the input_list of a dependency_clause
1184 Analyze_Input_List
(Inputs
);
1185 end Analyze_Dependency_Clause
;
1187 ---------------------------
1188 -- Check_Function_Return --
1189 ---------------------------
1191 procedure Check_Function_Return
is
1193 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1194 and then not Result_Seen
1197 ("result of & must appear in exactly one output list",
1200 end Check_Function_Return
;
1206 procedure Check_Role
1208 Item_Id
: Entity_Id
;
1213 (Item_Is_Input
: out Boolean;
1214 Item_Is_Output
: out Boolean);
1215 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1216 -- Item_Is_Output are set depending on the role.
1218 procedure Role_Error
1219 (Item_Is_Input
: Boolean;
1220 Item_Is_Output
: Boolean);
1221 -- Emit an error message concerning the incorrect use of Item in
1222 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1223 -- denote whether the item is an input and/or an output.
1230 (Item_Is_Input
: out Boolean;
1231 Item_Is_Output
: out Boolean)
1234 Item_Is_Input
:= False;
1235 Item_Is_Output
:= False;
1239 if Ekind
(Item_Id
) = E_Abstract_State
then
1241 -- When pragma Global is present, the mode of the state may be
1242 -- further constrained by setting a more restrictive mode.
1245 if Appears_In
(Subp_Inputs
, Item_Id
) then
1246 Item_Is_Input
:= True;
1249 if Appears_In
(Subp_Outputs
, Item_Id
) then
1250 Item_Is_Output
:= True;
1253 -- Otherwise the state has a default IN OUT mode
1256 Item_Is_Input
:= True;
1257 Item_Is_Output
:= True;
1262 elsif Ekind_In
(Item_Id
, E_Constant
,
1266 Item_Is_Input
:= True;
1270 elsif Ekind_In
(Item_Id
, E_Generic_In_Parameter
,
1273 Item_Is_Input
:= True;
1275 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
1278 Item_Is_Input
:= True;
1279 Item_Is_Output
:= True;
1281 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1282 if Scope
(Item_Id
) = Spec_Id
then
1284 -- An OUT parameter of the related subprogram has mode IN
1285 -- if its type is unconstrained or tagged because array
1286 -- bounds, discriminants or tags can be read.
1288 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1289 Item_Is_Input
:= True;
1292 Item_Is_Output
:= True;
1294 -- An OUT parameter of an enclosing subprogram behaves as a
1295 -- read-write variable in which case the mode is IN OUT.
1298 Item_Is_Input
:= True;
1299 Item_Is_Output
:= True;
1304 elsif Ekind
(Item_Id
) = E_Protected_Type
then
1306 -- A protected type acts as a formal parameter of mode IN when
1307 -- it applies to a protected function.
1309 if Ekind
(Spec_Id
) = E_Function
then
1310 Item_Is_Input
:= True;
1312 -- Otherwise the protected type acts as a formal of mode IN OUT
1315 Item_Is_Input
:= True;
1316 Item_Is_Output
:= True;
1321 elsif Ekind
(Item_Id
) = E_Task_Type
then
1322 Item_Is_Input
:= True;
1323 Item_Is_Output
:= True;
1327 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1329 -- When pragma Global is present, the mode of the variable may
1330 -- be further constrained by setting a more restrictive mode.
1334 -- A variable has mode IN when its type is unconstrained or
1335 -- tagged because array bounds, discriminants or tags can be
1338 if Appears_In
(Subp_Inputs
, Item_Id
)
1339 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1341 Item_Is_Input
:= True;
1344 if Appears_In
(Subp_Outputs
, Item_Id
) then
1345 Item_Is_Output
:= True;
1348 -- Otherwise the variable has a default IN OUT mode
1351 Item_Is_Input
:= True;
1352 Item_Is_Output
:= True;
1361 procedure Role_Error
1362 (Item_Is_Input
: Boolean;
1363 Item_Is_Output
: Boolean)
1365 Error_Msg
: Name_Id
;
1370 -- When the item is not part of the input and the output set of
1371 -- the related subprogram, then it appears as extra in pragma
1372 -- [Refined_]Depends.
1374 if not Item_Is_Input
and then not Item_Is_Output
then
1375 Add_Item_To_Name_Buffer
(Item_Id
);
1376 Add_Str_To_Name_Buffer
1377 (" & cannot appear in dependence relation");
1379 Error_Msg
:= Name_Find
;
1380 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1382 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1384 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1385 & "set of subprogram %"), Item
, Item_Id
);
1387 -- The mode of the item and its role in pragma [Refined_]Depends
1388 -- are in conflict. Construct a detailed message explaining the
1389 -- illegality (SPARK RM 6.1.5(5-6)).
1392 if Item_Is_Input
then
1393 Add_Str_To_Name_Buffer
("read-only");
1395 Add_Str_To_Name_Buffer
("write-only");
1398 Add_Char_To_Name_Buffer
(' ');
1399 Add_Item_To_Name_Buffer
(Item_Id
);
1400 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1402 if Item_Is_Input
then
1403 Add_Str_To_Name_Buffer
("output");
1405 Add_Str_To_Name_Buffer
("input");
1408 Add_Str_To_Name_Buffer
(" in dependence relation");
1409 Error_Msg
:= Name_Find
;
1410 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1416 Item_Is_Input
: Boolean;
1417 Item_Is_Output
: Boolean;
1419 -- Start of processing for Check_Role
1422 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1427 if not Item_Is_Input
then
1428 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1431 -- Self-referential item
1434 if not Item_Is_Input
or else not Item_Is_Output
then
1435 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1440 elsif not Item_Is_Output
then
1441 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1449 procedure Check_Usage
1450 (Subp_Items
: Elist_Id
;
1451 Used_Items
: Elist_Id
;
1454 procedure Usage_Error
(Item_Id
: Entity_Id
);
1455 -- Emit an error concerning the illegal usage of an item
1461 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1462 Error_Msg
: Name_Id
;
1469 -- Unconstrained and tagged items are not part of the explicit
1470 -- input set of the related subprogram, they do not have to be
1471 -- present in a dependence relation and should not be flagged
1472 -- (SPARK RM 6.1.5(8)).
1474 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1477 Add_Item_To_Name_Buffer
(Item_Id
);
1478 Add_Str_To_Name_Buffer
1479 (" & is missing from input dependence list");
1481 Error_Msg
:= Name_Find
;
1482 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1485 -- Output case (SPARK RM 6.1.5(10))
1490 Add_Item_To_Name_Buffer
(Item_Id
);
1491 Add_Str_To_Name_Buffer
1492 (" & is missing from output dependence list");
1494 Error_Msg
:= Name_Find
;
1495 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1503 Item_Id
: Entity_Id
;
1505 -- Start of processing for Check_Usage
1508 if No
(Subp_Items
) then
1512 -- Each input or output of the subprogram must appear in a dependency
1515 Elmt
:= First_Elmt
(Subp_Items
);
1516 while Present
(Elmt
) loop
1517 Item
:= Node
(Elmt
);
1519 if Nkind
(Item
) = N_Defining_Identifier
then
1522 Item_Id
:= Entity_Of
(Item
);
1525 -- The item does not appear in a dependency
1527 if Present
(Item_Id
)
1528 and then not Contains
(Used_Items
, Item_Id
)
1530 if Is_Formal
(Item_Id
) then
1531 Usage_Error
(Item_Id
);
1533 -- The current instance of a protected type behaves as a formal
1534 -- parameter (SPARK RM 6.1.4).
1536 elsif Ekind
(Item_Id
) = E_Protected_Type
1537 or else Is_Single_Protected_Object
(Item_Id
)
1539 Usage_Error
(Item_Id
);
1541 -- The current instance of a task type behaves as a formal
1542 -- parameter (SPARK RM 6.1.4).
1544 elsif Ekind
(Item_Id
) = E_Task_Type
1545 or else Is_Single_Task_Object
(Item_Id
)
1547 -- The dependence of a task unit on itself is implicit and
1548 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1549 -- Emit an error if only one input/output is present.
1551 if Task_Input_Seen
/= Task_Output_Seen
then
1552 Usage_Error
(Item_Id
);
1555 -- States and global objects are not used properly only when
1556 -- the subprogram is subject to pragma Global.
1558 elsif Global_Seen
then
1559 Usage_Error
(Item_Id
);
1567 ----------------------
1568 -- Normalize_Clause --
1569 ----------------------
1571 procedure Normalize_Clause
(Clause
: Node_Id
) is
1572 procedure Create_Or_Modify_Clause
1578 Multiple
: Boolean);
1579 -- Create a brand new clause to represent the self-reference or
1580 -- modify the input and/or output lists of an existing clause. Output
1581 -- denotes a self-referencial output. Outputs is the output list of a
1582 -- clause. Inputs is the input list of a clause. After denotes the
1583 -- clause after which the new clause is to be inserted. Flag In_Place
1584 -- should be set when normalizing the last output of an output list.
1585 -- Flag Multiple should be set when Output comes from a list with
1588 -----------------------------
1589 -- Create_Or_Modify_Clause --
1590 -----------------------------
1592 procedure Create_Or_Modify_Clause
1600 procedure Propagate_Output
1603 -- Handle the various cases of output propagation to the input
1604 -- list. Output denotes a self-referencial output item. Inputs
1605 -- is the input list of a clause.
1607 ----------------------
1608 -- Propagate_Output --
1609 ----------------------
1611 procedure Propagate_Output
1615 function In_Input_List
1617 Inputs
: List_Id
) return Boolean;
1618 -- Determine whether a particulat item appears in the input
1619 -- list of a clause.
1625 function In_Input_List
1627 Inputs
: List_Id
) return Boolean
1632 Elmt
:= First
(Inputs
);
1633 while Present
(Elmt
) loop
1634 if Entity_Of
(Elmt
) = Item
then
1646 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1649 -- Start of processing for Propagate_Output
1652 -- The clause is of the form:
1654 -- (Output =>+ null)
1656 -- Remove null input and replace it with a copy of the output:
1658 -- (Output => Output)
1660 if Nkind
(Inputs
) = N_Null
then
1661 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1663 -- The clause is of the form:
1665 -- (Output =>+ (Input1, ..., InputN))
1667 -- Determine whether the output is not already mentioned in the
1668 -- input list and if not, add it to the list of inputs:
1670 -- (Output => (Output, Input1, ..., InputN))
1672 elsif Nkind
(Inputs
) = N_Aggregate
then
1673 Grouped
:= Expressions
(Inputs
);
1675 if not In_Input_List
1679 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1682 -- The clause is of the form:
1684 -- (Output =>+ Input)
1686 -- If the input does not mention the output, group the two
1689 -- (Output => (Output, Input))
1691 elsif Entity_Of
(Inputs
) /= Output_Id
then
1693 Make_Aggregate
(Loc
,
1694 Expressions
=> New_List
(
1695 New_Copy_Tree
(Output
),
1696 New_Copy_Tree
(Inputs
))));
1698 end Propagate_Output
;
1702 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1703 New_Clause
: Node_Id
;
1705 -- Start of processing for Create_Or_Modify_Clause
1708 -- A null output depending on itself does not require any
1711 if Nkind
(Output
) = N_Null
then
1714 -- A function result cannot depend on itself because it cannot
1715 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1717 elsif Is_Attribute_Result
(Output
) then
1718 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1722 -- When performing the transformation in place, simply add the
1723 -- output to the list of inputs (if not already there). This
1724 -- case arises when dealing with the last output of an output
1725 -- list. Perform the normalization in place to avoid generating
1726 -- a malformed tree.
1729 Propagate_Output
(Output
, Inputs
);
1731 -- A list with multiple outputs is slowly trimmed until only
1732 -- one element remains. When this happens, replace aggregate
1733 -- with the element itself.
1737 Rewrite
(Outputs
, Output
);
1743 -- Unchain the output from its output list as it will appear in
1744 -- a new clause. Note that we cannot simply rewrite the output
1745 -- as null because this will violate the semantics of pragma
1750 -- Generate a new clause of the form:
1751 -- (Output => Inputs)
1754 Make_Component_Association
(Loc
,
1755 Choices
=> New_List
(Output
),
1756 Expression
=> New_Copy_Tree
(Inputs
));
1758 -- The new clause contains replicated content that has already
1759 -- been analyzed. There is not need to reanalyze or renormalize
1762 Set_Analyzed
(New_Clause
);
1765 (Output
=> First
(Choices
(New_Clause
)),
1766 Inputs
=> Expression
(New_Clause
));
1768 Insert_After
(After
, New_Clause
);
1770 end Create_Or_Modify_Clause
;
1774 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1776 Last_Output
: Node_Id
;
1777 Next_Output
: Node_Id
;
1780 -- Start of processing for Normalize_Clause
1783 -- A self-dependency appears as operator "+". Remove the "+" from the
1784 -- tree by moving the real inputs to their proper place.
1786 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1787 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1788 Inputs
:= Expression
(Clause
);
1790 -- Multiple outputs appear as an aggregate
1792 if Nkind
(Outputs
) = N_Aggregate
then
1793 Last_Output
:= Last
(Expressions
(Outputs
));
1795 Output
:= First
(Expressions
(Outputs
));
1796 while Present
(Output
) loop
1798 -- Normalization may remove an output from its list,
1799 -- preserve the subsequent output now.
1801 Next_Output
:= Next
(Output
);
1803 Create_Or_Modify_Clause
1808 In_Place
=> Output
= Last_Output
,
1811 Output
:= Next_Output
;
1817 Create_Or_Modify_Clause
1826 end Normalize_Clause
;
1830 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1831 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1835 Last_Clause
: Node_Id
;
1836 Restore_Scope
: Boolean := False;
1838 -- Start of processing for Analyze_Depends_In_Decl_Part
1841 -- Do not analyze the pragma multiple times
1843 if Is_Analyzed_Pragma
(N
) then
1847 -- Empty dependency list
1849 if Nkind
(Deps
) = N_Null
then
1851 -- Gather all states, objects and formal parameters that the
1852 -- subprogram may depend on. These items are obtained from the
1853 -- parameter profile or pragma [Refined_]Global (if available).
1855 Collect_Subprogram_Inputs_Outputs
1856 (Subp_Id
=> Subp_Id
,
1857 Subp_Inputs
=> Subp_Inputs
,
1858 Subp_Outputs
=> Subp_Outputs
,
1859 Global_Seen
=> Global_Seen
);
1861 -- Verify that every input or output of the subprogram appear in a
1864 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1865 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1866 Check_Function_Return
;
1868 -- Dependency clauses appear as component associations of an aggregate
1870 elsif Nkind
(Deps
) = N_Aggregate
then
1872 -- Do not attempt to perform analysis of a syntactically illegal
1873 -- clause as this will lead to misleading errors.
1875 if Has_Extra_Parentheses
(Deps
) then
1879 if Present
(Component_Associations
(Deps
)) then
1880 Last_Clause
:= Last
(Component_Associations
(Deps
));
1882 -- Gather all states, objects and formal parameters that the
1883 -- subprogram may depend on. These items are obtained from the
1884 -- parameter profile or pragma [Refined_]Global (if available).
1886 Collect_Subprogram_Inputs_Outputs
1887 (Subp_Id
=> Subp_Id
,
1888 Subp_Inputs
=> Subp_Inputs
,
1889 Subp_Outputs
=> Subp_Outputs
,
1890 Global_Seen
=> Global_Seen
);
1892 -- When pragma [Refined_]Depends appears on a single concurrent
1893 -- type, it is relocated to the anonymous object.
1895 if Is_Single_Concurrent_Object
(Spec_Id
) then
1898 -- Ensure that the formal parameters are visible when analyzing
1899 -- all clauses. This falls out of the general rule of aspects
1900 -- pertaining to subprogram declarations.
1902 elsif not In_Open_Scopes
(Spec_Id
) then
1903 Restore_Scope
:= True;
1904 Push_Scope
(Spec_Id
);
1906 if Ekind
(Spec_Id
) = E_Task_Type
then
1907 if Has_Discriminants
(Spec_Id
) then
1908 Install_Discriminants
(Spec_Id
);
1911 elsif Is_Generic_Subprogram
(Spec_Id
) then
1912 Install_Generic_Formals
(Spec_Id
);
1915 Install_Formals
(Spec_Id
);
1919 Clause
:= First
(Component_Associations
(Deps
));
1920 while Present
(Clause
) loop
1921 Errors
:= Serious_Errors_Detected
;
1923 -- The normalization mechanism may create extra clauses that
1924 -- contain replicated input and output names. There is no need
1925 -- to reanalyze them.
1927 if not Analyzed
(Clause
) then
1928 Set_Analyzed
(Clause
);
1930 Analyze_Dependency_Clause
1932 Is_Last
=> Clause
= Last_Clause
);
1935 -- Do not normalize a clause if errors were detected (count
1936 -- of Serious_Errors has increased) because the inputs and/or
1937 -- outputs may denote illegal items. Normalization is disabled
1938 -- in ASIS mode as it alters the tree by introducing new nodes
1939 -- similar to expansion.
1941 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1942 Normalize_Clause
(Clause
);
1948 if Restore_Scope
then
1952 -- Verify that every input or output of the subprogram appear in a
1955 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1956 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1957 Check_Function_Return
;
1959 -- The dependency list is malformed. This is a syntax error, always
1963 Error_Msg_N
("malformed dependency relation", Deps
);
1967 -- The top level dependency relation is malformed. This is a syntax
1968 -- error, always report.
1971 Error_Msg_N
("malformed dependency relation", Deps
);
1975 -- Ensure that a state and a corresponding constituent do not appear
1976 -- together in pragma [Refined_]Depends.
1978 Check_State_And_Constituent_Use
1979 (States
=> States_Seen
,
1980 Constits
=> Constits_Seen
,
1984 Set_Is_Analyzed_Pragma
(N
);
1985 end Analyze_Depends_In_Decl_Part
;
1987 --------------------------------------------
1988 -- Analyze_External_Property_In_Decl_Part --
1989 --------------------------------------------
1991 procedure Analyze_External_Property_In_Decl_Part
1993 Expr_Val
: out Boolean)
1995 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1996 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
1997 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
2003 -- Do not analyze the pragma multiple times
2005 if Is_Analyzed_Pragma
(N
) then
2009 Error_Msg_Name_1
:= Pragma_Name
(N
);
2011 -- An external property pragma must apply to an effectively volatile
2012 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
2013 -- The check is performed at the end of the declarative region due to a
2014 -- possible out-of-order arrangement of pragmas:
2017 -- pragma Async_Readers (Obj);
2018 -- pragma Volatile (Obj);
2020 if not Is_Effectively_Volatile
(Obj_Id
) then
2022 ("external property % must apply to a volatile object", N
);
2025 -- Ensure that the Boolean expression (if present) is static. A missing
2026 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2030 if Present
(Arg1
) then
2031 Expr
:= Get_Pragma_Arg
(Arg1
);
2033 if Is_OK_Static_Expression
(Expr
) then
2034 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2038 Set_Is_Analyzed_Pragma
(N
);
2039 end Analyze_External_Property_In_Decl_Part
;
2041 ---------------------------------
2042 -- Analyze_Global_In_Decl_Part --
2043 ---------------------------------
2045 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2046 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2047 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2048 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2050 Constits_Seen
: Elist_Id
:= No_Elist
;
2051 -- A list containing the entities of all constituents processed so far.
2052 -- It aids in detecting illegal usage of a state and a corresponding
2053 -- constituent in pragma [Refinde_]Global.
2055 Seen
: Elist_Id
:= No_Elist
;
2056 -- A list containing the entities of all the items processed so far. It
2057 -- plays a role in detecting distinct entities.
2059 States_Seen
: Elist_Id
:= No_Elist
;
2060 -- A list containing the entities of all states processed so far. It
2061 -- helps in detecting illegal usage of a state and a corresponding
2062 -- constituent in pragma [Refined_]Global.
2064 In_Out_Seen
: Boolean := False;
2065 Input_Seen
: Boolean := False;
2066 Output_Seen
: Boolean := False;
2067 Proof_Seen
: Boolean := False;
2068 -- Flags used to verify the consistency of modes
2070 procedure Analyze_Global_List
2072 Global_Mode
: Name_Id
:= Name_Input
);
2073 -- Verify the legality of a single global list declaration. Global_Mode
2074 -- denotes the current mode in effect.
2076 -------------------------
2077 -- Analyze_Global_List --
2078 -------------------------
2080 procedure Analyze_Global_List
2082 Global_Mode
: Name_Id
:= Name_Input
)
2084 procedure Analyze_Global_Item
2086 Global_Mode
: Name_Id
);
2087 -- Verify the legality of a single global item declaration denoted by
2088 -- Item. Global_Mode denotes the current mode in effect.
2090 procedure Check_Duplicate_Mode
2092 Status
: in out Boolean);
2093 -- Flag Status denotes whether a particular mode has been seen while
2094 -- processing a global list. This routine verifies that Mode is not a
2095 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2097 procedure Check_Mode_Restriction_In_Enclosing_Context
2099 Item_Id
: Entity_Id
);
2100 -- Verify that an item of mode In_Out or Output does not appear as an
2101 -- input in the Global aspect of an enclosing subprogram. If this is
2102 -- the case, emit an error. Item and Item_Id are respectively the
2103 -- item and its entity.
2105 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2106 -- Mode denotes either In_Out or Output. Depending on the kind of the
2107 -- related subprogram, emit an error if those two modes apply to a
2108 -- function (SPARK RM 6.1.4(10)).
2110 -------------------------
2111 -- Analyze_Global_Item --
2112 -------------------------
2114 procedure Analyze_Global_Item
2116 Global_Mode
: Name_Id
)
2118 Item_Id
: Entity_Id
;
2121 -- Detect one of the following cases
2123 -- with Global => (null, Name)
2124 -- with Global => (Name_1, null, Name_2)
2125 -- with Global => (Name, null)
2127 if Nkind
(Item
) = N_Null
then
2128 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2133 Resolve_State
(Item
);
2135 -- Find the entity of the item. If this is a renaming, climb the
2136 -- renaming chain to reach the root object. Renamings of non-
2137 -- entire objects do not yield an entity (Empty).
2139 Item_Id
:= Entity_Of
(Item
);
2141 if Present
(Item_Id
) then
2143 -- A global item may denote a formal parameter of an enclosing
2144 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2145 -- provide a better error diagnostic.
2147 if Is_Formal
(Item_Id
) then
2148 if Scope
(Item_Id
) = Spec_Id
then
2150 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2151 & "parameter of subprogram &"), Item
, Spec_Id
);
2155 -- A global item may denote a concurrent type as long as it is
2156 -- the current instance of an enclosing protected or task type
2157 -- (SPARK RM 6.1.4).
2159 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2160 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2162 -- Pragma [Refined_]Global associated with a protected
2163 -- subprogram cannot mention the current instance of a
2164 -- protected type because the instance behaves as a
2165 -- formal parameter.
2167 if Ekind
(Item_Id
) = E_Protected_Type
then
2168 Error_Msg_Name_1
:= Chars
(Item_Id
);
2170 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2171 & "cannot reference current instance of protected "
2172 & "type %"), Item
, Spec_Id
);
2175 -- Pragma [Refined_]Global associated with a task type
2176 -- cannot mention the current instance of a task type
2177 -- because the instance behaves as a formal parameter.
2179 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2180 Error_Msg_Name_1
:= Chars
(Item_Id
);
2182 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2183 & "cannot reference current instance of task type "
2184 & "%"), Item
, Spec_Id
);
2188 -- Otherwise the global item denotes a subtype mark that is
2189 -- not a current instance.
2193 ("invalid use of subtype mark in global list", Item
);
2197 -- A global item may denote the anonymous object created for a
2198 -- single protected/task type as long as the current instance
2199 -- is the same single type (SPARK RM 6.1.4).
2201 elsif Is_Single_Concurrent_Object
(Item_Id
)
2202 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
2204 -- Pragma [Refined_]Global associated with a protected
2205 -- subprogram cannot mention the current instance of a
2206 -- protected type because the instance behaves as a formal
2209 if Is_Single_Protected_Object
(Item_Id
) then
2210 Error_Msg_Name_1
:= Chars
(Item_Id
);
2212 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2213 & "reference current instance of protected type %"),
2217 -- Pragma [Refined_]Global associated with a task type
2218 -- cannot mention the current instance of a task type
2219 -- because the instance behaves as a formal parameter.
2221 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2222 Error_Msg_Name_1
:= Chars
(Item_Id
);
2224 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2225 & "reference current instance of task type %"),
2230 -- A formal object may act as a global item inside a generic
2232 elsif Is_Formal_Object
(Item_Id
) then
2235 -- The only legal references are those to abstract states,
2236 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2238 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2245 ("global item must denote object, state or current "
2246 & "instance of concurrent type", Item
);
2250 -- State related checks
2252 if Ekind
(Item_Id
) = E_Abstract_State
then
2254 -- Package and subprogram bodies are instantiated
2255 -- individually in a separate compiler pass. Due to this
2256 -- mode of instantiation, the refinement of a state may
2257 -- no longer be visible when a subprogram body contract
2258 -- is instantiated. Since the generic template is legal,
2259 -- do not perform this check in the instance to circumvent
2262 if Is_Generic_Instance
(Spec_Id
) then
2265 -- An abstract state with visible refinement cannot appear
2266 -- in pragma [Refined_]Global as its place must be taken by
2267 -- some of its constituents (SPARK RM 6.1.4(7)).
2269 elsif Has_Visible_Refinement
(Item_Id
) then
2271 ("cannot mention state & in global refinement",
2273 SPARK_Msg_N
("\use its constituents instead", Item
);
2276 -- An external state cannot appear as a global item of a
2277 -- nonvolatile function (SPARK RM 7.1.3(8)).
2279 elsif Is_External_State
(Item_Id
)
2280 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2281 and then not Is_Volatile_Function
(Spec_Id
)
2284 ("external state & cannot act as global item of "
2285 & "nonvolatile function", Item
, Item_Id
);
2288 -- If the reference to the abstract state appears in an
2289 -- enclosing package body that will eventually refine the
2290 -- state, record the reference for future checks.
2293 Record_Possible_Body_Reference
2294 (State_Id
=> Item_Id
,
2298 -- Constant related checks
2300 elsif Ekind
(Item_Id
) = E_Constant
then
2302 -- A constant is a read-only item, therefore it cannot act
2305 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2307 ("constant & cannot act as output", Item
, Item_Id
);
2311 -- Discriminant related checks
2313 elsif Ekind
(Item_Id
) = E_Discriminant
then
2315 -- A discriminant is a read-only item, therefore it cannot
2316 -- act as an output.
2318 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2320 ("discriminant & cannot act as output", Item
, Item_Id
);
2324 -- Loop parameter related checks
2326 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2328 -- A loop parameter is a read-only item, therefore it cannot
2329 -- act as an output.
2331 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2333 ("loop parameter & cannot act as output",
2338 -- Variable related checks. These are only relevant when
2339 -- SPARK_Mode is on as they are not standard Ada legality
2342 elsif SPARK_Mode
= On
2343 and then Ekind
(Item_Id
) = E_Variable
2344 and then Is_Effectively_Volatile
(Item_Id
)
2346 -- An effectively volatile object cannot appear as a global
2347 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2349 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2350 and then not Is_Volatile_Function
(Spec_Id
)
2353 ("volatile object & cannot act as global item of a "
2354 & "function", Item
, Item_Id
);
2357 -- An effectively volatile object with external property
2358 -- Effective_Reads set to True must have mode Output or
2359 -- In_Out (SPARK RM 7.1.3(10)).
2361 elsif Effective_Reads_Enabled
(Item_Id
)
2362 and then Global_Mode
= Name_Input
2365 ("volatile object & with property Effective_Reads must "
2366 & "have mode In_Out or Output", Item
, Item_Id
);
2371 -- When the item renames an entire object, replace the item
2372 -- with a reference to the object.
2374 if Entity
(Item
) /= Item_Id
then
2375 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2379 -- Some form of illegal construct masquerading as a name
2380 -- (SPARK RM 6.1.4(4)).
2384 ("global item must denote object, state or current instance "
2385 & "of concurrent type", Item
);
2389 -- Verify that an output does not appear as an input in an
2390 -- enclosing subprogram.
2392 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2393 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2396 -- The same entity might be referenced through various way.
2397 -- Check the entity of the item rather than the item itself
2398 -- (SPARK RM 6.1.4(10)).
2400 if Contains
(Seen
, Item_Id
) then
2401 SPARK_Msg_N
("duplicate global item", Item
);
2403 -- Add the entity of the current item to the list of processed
2407 Append_New_Elmt
(Item_Id
, Seen
);
2409 if Ekind
(Item_Id
) = E_Abstract_State
then
2410 Append_New_Elmt
(Item_Id
, States_Seen
);
2412 -- The variable may eventually become a constituent of a single
2413 -- protected/task type. Record the reference now and verify its
2414 -- legality when analyzing the contract of the variable
2417 elsif Ekind
(Item_Id
) = E_Variable
then
2418 Record_Possible_Part_Of_Reference
2423 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2424 and then Present
(Encapsulating_State
(Item_Id
))
2426 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2429 end Analyze_Global_Item
;
2431 --------------------------
2432 -- Check_Duplicate_Mode --
2433 --------------------------
2435 procedure Check_Duplicate_Mode
2437 Status
: in out Boolean)
2441 SPARK_Msg_N
("duplicate global mode", Mode
);
2445 end Check_Duplicate_Mode
;
2447 -------------------------------------------------
2448 -- Check_Mode_Restriction_In_Enclosing_Context --
2449 -------------------------------------------------
2451 procedure Check_Mode_Restriction_In_Enclosing_Context
2453 Item_Id
: Entity_Id
)
2455 Context
: Entity_Id
;
2457 Inputs
: Elist_Id
:= No_Elist
;
2458 Outputs
: Elist_Id
:= No_Elist
;
2461 -- Traverse the scope stack looking for enclosing subprograms
2462 -- subject to pragma [Refined_]Global.
2464 Context
:= Scope
(Subp_Id
);
2465 while Present
(Context
) and then Context
/= Standard_Standard
loop
2466 if Is_Subprogram
(Context
)
2468 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2470 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2472 Collect_Subprogram_Inputs_Outputs
2473 (Subp_Id
=> Context
,
2474 Subp_Inputs
=> Inputs
,
2475 Subp_Outputs
=> Outputs
,
2476 Global_Seen
=> Dummy
);
2478 -- The item is classified as In_Out or Output but appears as
2479 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2481 if Appears_In
(Inputs
, Item_Id
)
2482 and then not Appears_In
(Outputs
, Item_Id
)
2485 ("global item & cannot have mode In_Out or Output",
2489 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2490 & "subprogram &"), Item
, Context
);
2492 -- Stop the traversal once an error has been detected
2498 Context
:= Scope
(Context
);
2500 end Check_Mode_Restriction_In_Enclosing_Context
;
2502 ----------------------------------------
2503 -- Check_Mode_Restriction_In_Function --
2504 ----------------------------------------
2506 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2508 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2510 ("global mode & is not applicable to functions", Mode
);
2512 end Check_Mode_Restriction_In_Function
;
2520 -- Start of processing for Analyze_Global_List
2523 if Nkind
(List
) = N_Null
then
2524 Set_Analyzed
(List
);
2526 -- Single global item declaration
2528 elsif Nkind_In
(List
, N_Expanded_Name
,
2530 N_Selected_Component
)
2532 Analyze_Global_Item
(List
, Global_Mode
);
2534 -- Simple global list or moded global list declaration
2536 elsif Nkind
(List
) = N_Aggregate
then
2537 Set_Analyzed
(List
);
2539 -- The declaration of a simple global list appear as a collection
2542 if Present
(Expressions
(List
)) then
2543 if Present
(Component_Associations
(List
)) then
2545 ("cannot mix moded and non-moded global lists", List
);
2548 Item
:= First
(Expressions
(List
));
2549 while Present
(Item
) loop
2550 Analyze_Global_Item
(Item
, Global_Mode
);
2554 -- The declaration of a moded global list appears as a collection
2555 -- of component associations where individual choices denote
2558 elsif Present
(Component_Associations
(List
)) then
2559 if Present
(Expressions
(List
)) then
2561 ("cannot mix moded and non-moded global lists", List
);
2564 Assoc
:= First
(Component_Associations
(List
));
2565 while Present
(Assoc
) loop
2566 Mode
:= First
(Choices
(Assoc
));
2568 if Nkind
(Mode
) = N_Identifier
then
2569 if Chars
(Mode
) = Name_In_Out
then
2570 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2571 Check_Mode_Restriction_In_Function
(Mode
);
2573 elsif Chars
(Mode
) = Name_Input
then
2574 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2576 elsif Chars
(Mode
) = Name_Output
then
2577 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2578 Check_Mode_Restriction_In_Function
(Mode
);
2580 elsif Chars
(Mode
) = Name_Proof_In
then
2581 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2584 SPARK_Msg_N
("invalid mode selector", Mode
);
2588 SPARK_Msg_N
("invalid mode selector", Mode
);
2591 -- Items in a moded list appear as a collection of
2592 -- expressions. Reuse the existing machinery to analyze
2596 (List
=> Expression
(Assoc
),
2597 Global_Mode
=> Chars
(Mode
));
2605 raise Program_Error
;
2608 -- Any other attempt to declare a global item is illegal. This is a
2609 -- syntax error, always report.
2612 Error_Msg_N
("malformed global list", List
);
2614 end Analyze_Global_List
;
2618 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2620 Restore_Scope
: Boolean := False;
2622 -- Start of processing for Analyze_Global_In_Decl_Part
2625 -- Do not analyze the pragma multiple times
2627 if Is_Analyzed_Pragma
(N
) then
2631 -- There is nothing to be done for a null global list
2633 if Nkind
(Items
) = N_Null
then
2634 Set_Analyzed
(Items
);
2636 -- Analyze the various forms of global lists and items. Note that some
2637 -- of these may be malformed in which case the analysis emits error
2641 -- When pragma [Refined_]Global appears on a single concurrent type,
2642 -- it is relocated to the anonymous object.
2644 if Is_Single_Concurrent_Object
(Spec_Id
) then
2647 -- Ensure that the formal parameters are visible when processing an
2648 -- item. This falls out of the general rule of aspects pertaining to
2649 -- subprogram declarations.
2651 elsif not In_Open_Scopes
(Spec_Id
) then
2652 Restore_Scope
:= True;
2653 Push_Scope
(Spec_Id
);
2655 if Ekind
(Spec_Id
) = E_Task_Type
then
2656 if Has_Discriminants
(Spec_Id
) then
2657 Install_Discriminants
(Spec_Id
);
2660 elsif Is_Generic_Subprogram
(Spec_Id
) then
2661 Install_Generic_Formals
(Spec_Id
);
2664 Install_Formals
(Spec_Id
);
2668 Analyze_Global_List
(Items
);
2670 if Restore_Scope
then
2675 -- Ensure that a state and a corresponding constituent do not appear
2676 -- together in pragma [Refined_]Global.
2678 Check_State_And_Constituent_Use
2679 (States
=> States_Seen
,
2680 Constits
=> Constits_Seen
,
2683 Set_Is_Analyzed_Pragma
(N
);
2684 end Analyze_Global_In_Decl_Part
;
2686 --------------------------------------------
2687 -- Analyze_Initial_Condition_In_Decl_Part --
2688 --------------------------------------------
2690 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2691 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2692 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2693 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2695 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2698 -- Do not analyze the pragma multiple times
2700 if Is_Analyzed_Pragma
(N
) then
2704 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2705 -- analysis of the pragma, the Ghost mode at point of declaration and
2706 -- point of analysis may not necessarily be the same. Use the mode in
2707 -- effect at the point of declaration.
2711 -- The expression is preanalyzed because it has not been moved to its
2712 -- final place yet. A direct analysis may generate side effects and this
2713 -- is not desired at this point.
2715 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2716 Ghost_Mode
:= Save_Ghost_Mode
;
2718 Set_Is_Analyzed_Pragma
(N
);
2719 end Analyze_Initial_Condition_In_Decl_Part
;
2721 --------------------------------------
2722 -- Analyze_Initializes_In_Decl_Part --
2723 --------------------------------------
2725 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2726 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2727 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2729 Constits_Seen
: Elist_Id
:= No_Elist
;
2730 -- A list containing the entities of all constituents processed so far.
2731 -- It aids in detecting illegal usage of a state and a corresponding
2732 -- constituent in pragma Initializes.
2734 Items_Seen
: Elist_Id
:= No_Elist
;
2735 -- A list of all initialization items processed so far. This list is
2736 -- used to detect duplicate items.
2738 Non_Null_Seen
: Boolean := False;
2739 Null_Seen
: Boolean := False;
2740 -- Flags used to check the legality of a null initialization list
2742 States_And_Objs
: Elist_Id
:= No_Elist
;
2743 -- A list of all abstract states and objects declared in the visible
2744 -- declarations of the related package. This list is used to detect the
2745 -- legality of initialization items.
2747 States_Seen
: Elist_Id
:= No_Elist
;
2748 -- A list containing the entities of all states processed so far. It
2749 -- helps in detecting illegal usage of a state and a corresponding
2750 -- constituent in pragma Initializes.
2752 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2753 -- Verify the legality of a single initialization item
2755 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2756 -- Verify the legality of a single initialization item followed by a
2757 -- list of input items.
2759 procedure Collect_States_And_Objects
;
2760 -- Inspect the visible declarations of the related package and gather
2761 -- the entities of all abstract states and objects in States_And_Objs.
2763 ---------------------------------
2764 -- Analyze_Initialization_Item --
2765 ---------------------------------
2767 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2768 Item_Id
: Entity_Id
;
2771 -- Null initialization list
2773 if Nkind
(Item
) = N_Null
then
2775 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2777 elsif Non_Null_Seen
then
2779 ("cannot mix null and non-null initialization items", Item
);
2784 -- Initialization item
2787 Non_Null_Seen
:= True;
2791 ("cannot mix null and non-null initialization items", Item
);
2795 Resolve_State
(Item
);
2797 if Is_Entity_Name
(Item
) then
2798 Item_Id
:= Entity_Of
(Item
);
2800 if Ekind_In
(Item_Id
, E_Abstract_State
,
2804 -- The state or variable must be declared in the visible
2805 -- declarations of the package (SPARK RM 7.1.5(7)).
2807 if not Contains
(States_And_Objs
, Item_Id
) then
2808 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2810 ("initialization item & must appear in the visible "
2811 & "declarations of package %", Item
, Item_Id
);
2813 -- Detect a duplicate use of the same initialization item
2814 -- (SPARK RM 7.1.5(5)).
2816 elsif Contains
(Items_Seen
, Item_Id
) then
2817 SPARK_Msg_N
("duplicate initialization item", Item
);
2819 -- The item is legal, add it to the list of processed states
2823 Append_New_Elmt
(Item_Id
, Items_Seen
);
2825 if Ekind
(Item_Id
) = E_Abstract_State
then
2826 Append_New_Elmt
(Item_Id
, States_Seen
);
2829 if Present
(Encapsulating_State
(Item_Id
)) then
2830 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2834 -- The item references something that is not a state or object
2835 -- (SPARK RM 7.1.5(3)).
2839 ("initialization item must denote object or state", Item
);
2842 -- Some form of illegal construct masquerading as a name
2843 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2847 ("initialization item must denote object or state", Item
);
2850 end Analyze_Initialization_Item
;
2852 ---------------------------------------------
2853 -- Analyze_Initialization_Item_With_Inputs --
2854 ---------------------------------------------
2856 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2857 Inputs_Seen
: Elist_Id
:= No_Elist
;
2858 -- A list of all inputs processed so far. This list is used to detect
2859 -- duplicate uses of an input.
2861 Non_Null_Seen
: Boolean := False;
2862 Null_Seen
: Boolean := False;
2863 -- Flags used to check the legality of an input list
2865 procedure Analyze_Input_Item
(Input
: Node_Id
);
2866 -- Verify the legality of a single input item
2868 ------------------------
2869 -- Analyze_Input_Item --
2870 ------------------------
2872 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2873 Input_Id
: Entity_Id
;
2874 Input_OK
: Boolean := True;
2879 if Nkind
(Input
) = N_Null
then
2882 ("multiple null initializations not allowed", Item
);
2884 elsif Non_Null_Seen
then
2886 ("cannot mix null and non-null initialization item", Item
);
2894 Non_Null_Seen
:= True;
2898 ("cannot mix null and non-null initialization item", Item
);
2902 Resolve_State
(Input
);
2904 if Is_Entity_Name
(Input
) then
2905 Input_Id
:= Entity_Of
(Input
);
2907 if Ekind_In
(Input_Id
, E_Abstract_State
,
2909 E_Generic_In_Out_Parameter
,
2910 E_Generic_In_Parameter
,
2916 -- The input cannot denote states or objects declared
2917 -- within the related package (SPARK RM 7.1.5(4)).
2919 if Within_Scope
(Input_Id
, Current_Scope
) then
2921 -- Do not consider generic formal parameters or their
2922 -- respective mappings to generic formals. Even though
2923 -- the formals appear within the scope of the package,
2924 -- it is allowed for an initialization item to depend
2925 -- on an input item.
2927 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2928 E_Generic_In_Parameter
)
2932 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2933 and then Present
(Corresponding_Generic_Association
2934 (Declaration_Node
(Input_Id
)))
2940 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2942 ("input item & cannot denote a visible object or "
2943 & "state of package %", Input
, Input_Id
);
2947 -- Detect a duplicate use of the same input item
2948 -- (SPARK RM 7.1.5(5)).
2950 if Contains
(Inputs_Seen
, Input_Id
) then
2952 SPARK_Msg_N
("duplicate input item", Input
);
2955 -- Input is legal, add it to the list of processed inputs
2958 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2960 if Ekind
(Input_Id
) = E_Abstract_State
then
2961 Append_New_Elmt
(Input_Id
, States_Seen
);
2964 if Ekind_In
(Input_Id
, E_Abstract_State
,
2967 and then Present
(Encapsulating_State
(Input_Id
))
2969 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2973 -- The input references something that is not a state or an
2974 -- object (SPARK RM 7.1.5(3)).
2978 ("input item must denote object or state", Input
);
2981 -- Some form of illegal construct masquerading as a name
2982 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2986 ("input item must denote object or state", Input
);
2989 end Analyze_Input_Item
;
2993 Inputs
: constant Node_Id
:= Expression
(Item
);
2997 Name_Seen
: Boolean := False;
2998 -- A flag used to detect multiple item names
3000 -- Start of processing for Analyze_Initialization_Item_With_Inputs
3003 -- Inspect the name of an item with inputs
3005 Elmt
:= First
(Choices
(Item
));
3006 while Present
(Elmt
) loop
3008 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
3011 Analyze_Initialization_Item
(Elmt
);
3017 -- Multiple input items appear as an aggregate
3019 if Nkind
(Inputs
) = N_Aggregate
then
3020 if Present
(Expressions
(Inputs
)) then
3021 Input
:= First
(Expressions
(Inputs
));
3022 while Present
(Input
) loop
3023 Analyze_Input_Item
(Input
);
3028 if Present
(Component_Associations
(Inputs
)) then
3030 ("inputs must appear in named association form", Inputs
);
3033 -- Single input item
3036 Analyze_Input_Item
(Inputs
);
3038 end Analyze_Initialization_Item_With_Inputs
;
3040 --------------------------------
3041 -- Collect_States_And_Objects --
3042 --------------------------------
3044 procedure Collect_States_And_Objects
is
3045 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3049 -- Collect the abstract states defined in the package (if any)
3051 if Present
(Abstract_States
(Pack_Id
)) then
3052 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3055 -- Collect all objects the appear in the visible declarations of the
3058 if Present
(Visible_Declarations
(Pack_Spec
)) then
3059 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3060 while Present
(Decl
) loop
3061 if Comes_From_Source
(Decl
)
3062 and then Nkind
(Decl
) = N_Object_Declaration
3064 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3070 end Collect_States_And_Objects
;
3074 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3077 -- Start of processing for Analyze_Initializes_In_Decl_Part
3080 -- Do not analyze the pragma multiple times
3082 if Is_Analyzed_Pragma
(N
) then
3086 -- Nothing to do when the initialization list is empty
3088 if Nkind
(Inits
) = N_Null
then
3092 -- Single and multiple initialization clauses appear as an aggregate. If
3093 -- this is not the case, then either the parser or the analysis of the
3094 -- pragma failed to produce an aggregate.
3096 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3098 -- Initialize the various lists used during analysis
3100 Collect_States_And_Objects
;
3102 if Present
(Expressions
(Inits
)) then
3103 Init
:= First
(Expressions
(Inits
));
3104 while Present
(Init
) loop
3105 Analyze_Initialization_Item
(Init
);
3110 if Present
(Component_Associations
(Inits
)) then
3111 Init
:= First
(Component_Associations
(Inits
));
3112 while Present
(Init
) loop
3113 Analyze_Initialization_Item_With_Inputs
(Init
);
3118 -- Ensure that a state and a corresponding constituent do not appear
3119 -- together in pragma Initializes.
3121 Check_State_And_Constituent_Use
3122 (States
=> States_Seen
,
3123 Constits
=> Constits_Seen
,
3126 Set_Is_Analyzed_Pragma
(N
);
3127 end Analyze_Initializes_In_Decl_Part
;
3129 ---------------------
3130 -- Analyze_Part_Of --
3131 ---------------------
3133 procedure Analyze_Part_Of
3135 Item_Id
: Entity_Id
;
3137 Encap_Id
: out Entity_Id
;
3138 Legal
: out Boolean)
3140 Encap_Typ
: Entity_Id
;
3141 Item_Decl
: Node_Id
;
3142 Pack_Id
: Entity_Id
;
3143 Placement
: State_Space_Kind
;
3144 Parent_Unit
: Entity_Id
;
3147 -- Assume that the indicator is illegal
3152 if Nkind_In
(Encap
, N_Expanded_Name
,
3154 N_Selected_Component
)
3157 Resolve_State
(Encap
);
3159 Encap_Id
:= Entity
(Encap
);
3161 -- The encapsulator is an abstract state
3163 if Ekind
(Encap_Id
) = E_Abstract_State
then
3166 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3168 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3171 -- Otherwise the encapsulator is not a legal choice
3175 ("indicator Part_Of must denote abstract state, single "
3176 & "protected type or single task type", Encap
);
3180 -- This is a syntax error, always report
3184 ("indicator Part_Of must denote abstract state, single protected "
3185 & "type or single task type", Encap
);
3189 -- Catch a case where indicator Part_Of denotes the abstract view of a
3190 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3192 if From_Limited_With
(Encap_Id
)
3193 and then Present
(Non_Limited_View
(Encap_Id
))
3194 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3196 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3197 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3201 -- The encapsulator is an abstract state
3203 if Ekind
(Encap_Id
) = E_Abstract_State
then
3205 -- Determine where the object, package instantiation or state lives
3206 -- with respect to the enclosing packages or package bodies.
3208 Find_Placement_In_State_Space
3209 (Item_Id
=> Item_Id
,
3210 Placement
=> Placement
,
3211 Pack_Id
=> Pack_Id
);
3213 -- The item appears in a non-package construct with a declarative
3214 -- part (subprogram, block, etc). As such, the item is not allowed
3215 -- to be a part of an encapsulating state because the item is not
3218 if Placement
= Not_In_Package
then
3220 ("indicator Part_Of cannot appear in this context "
3221 & "(SPARK RM 7.2.6(5))", Indic
);
3222 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3224 ("\& is not part of the hidden state of package %",
3227 -- The item appears in the visible state space of some package. In
3228 -- general this scenario does not warrant Part_Of except when the
3229 -- package is a private child unit and the encapsulating state is
3230 -- declared in a parent unit or a public descendant of that parent
3233 elsif Placement
= Visible_State_Space
then
3234 if Is_Child_Unit
(Pack_Id
)
3235 and then Is_Private_Descendant
(Pack_Id
)
3237 -- A variable or state abstraction which is part of the visible
3238 -- state of a private child unit (or one of its public
3239 -- descendants) must have its Part_Of indicator specified. The
3240 -- Part_Of indicator must denote a state abstraction declared
3241 -- by either the parent unit of the private unit or by a public
3242 -- descendant of that parent unit.
3244 -- Find nearest private ancestor (which can be the current unit
3247 Parent_Unit
:= Pack_Id
;
3248 while Present
(Parent_Unit
) loop
3251 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3252 Parent_Unit
:= Scope
(Parent_Unit
);
3255 Parent_Unit
:= Scope
(Parent_Unit
);
3257 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3259 ("indicator Part_Of must denote abstract state or public "
3260 & "descendant of & (SPARK RM 7.2.6(3))",
3261 Indic
, Parent_Unit
);
3263 elsif Scope
(Encap_Id
) = Parent_Unit
3265 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3266 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3272 ("indicator Part_Of must denote abstract state or public "
3273 & "descendant of & (SPARK RM 7.2.6(3))",
3274 Indic
, Parent_Unit
);
3277 -- Indicator Part_Of is not needed when the related package is not
3278 -- a private child unit or a public descendant thereof.
3282 ("indicator Part_Of cannot appear in this context "
3283 & "(SPARK RM 7.2.6(5))", Indic
);
3284 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3286 ("\& is declared in the visible part of package %",
3290 -- When the item appears in the private state space of a package, the
3291 -- encapsulating state must be declared in the same package.
3293 elsif Placement
= Private_State_Space
then
3294 if Scope
(Encap_Id
) /= Pack_Id
then
3296 ("indicator Part_Of must designate an abstract state of "
3297 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3298 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3300 ("\& is declared in the private part of package %",
3304 -- Items declared in the body state space of a package do not need
3305 -- Part_Of indicators as the refinement has already been seen.
3309 ("indicator Part_Of cannot appear in this context "
3310 & "(SPARK RM 7.2.6(5))", Indic
);
3312 if Scope
(Encap_Id
) = Pack_Id
then
3313 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3315 ("\& is declared in the body of package %", Indic
, Item_Id
);
3319 -- The encapsulator is a single concurrent type
3322 Encap_Typ
:= Etype
(Encap_Id
);
3324 -- Only abstract states and variables can act as constituents of an
3325 -- encapsulating single concurrent type.
3327 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3330 -- The constituent is a constant
3332 elsif Ekind
(Item_Id
) = E_Constant
then
3333 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3335 (Fix_Msg
(Encap_Typ
, "consant & cannot act as constituent of "
3336 & "single protected type %"), Indic
, Item_Id
);
3338 -- The constituent is a package instantiation
3341 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3343 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3344 & "constituent of single protected type %"), Indic
, Item_Id
);
3347 -- When the item denotes an abstract state of a nested package, use
3348 -- the declaration of the package to detect proper placement.
3353 -- with Abstract_State => (State with Part_Of => T)
3355 if Ekind
(Item_Id
) = E_Abstract_State
then
3356 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3358 Item_Decl
:= Declaration_Node
(Item_Id
);
3361 -- Both the item and its encapsulating single concurrent type must
3362 -- appear in the same declarative region (SPARK RM 9.3). Note that
3363 -- privacy is ignored.
3365 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3366 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3368 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3369 & "immediately within the same region as single protected "
3370 & "type %"), Indic
, Item_Id
);
3375 end Analyze_Part_Of
;
3377 ----------------------------------
3378 -- Analyze_Part_Of_In_Decl_Part --
3379 ----------------------------------
3381 procedure Analyze_Part_Of_In_Decl_Part
3383 Freeze_Id
: Entity_Id
:= Empty
)
3385 Encap
: constant Node_Id
:=
3386 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3387 Errors
: constant Nat
:= Serious_Errors_Detected
;
3388 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3389 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3390 Constits
: Elist_Id
;
3391 Encap_Id
: Entity_Id
;
3395 -- Detect any discrepancies between the placement of the variable with
3396 -- respect to general state space and the encapsulating state or single
3403 Encap_Id
=> Encap_Id
,
3406 -- The Part_Of indicator turns the variable into a constituent of the
3407 -- encapsulating state or single concurrent type.
3410 pragma Assert
(Present
(Encap_Id
));
3411 Constits
:= Part_Of_Constituents
(Encap_Id
);
3413 if No
(Constits
) then
3414 Constits
:= New_Elmt_List
;
3415 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3418 Append_Elmt
(Var_Id
, Constits
);
3419 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3421 -- A Part_Of constituent partially refines an abstract state. This
3422 -- property does not apply to protected or task units.
3424 if Ekind
(Encap_Id
) = E_Abstract_State
then
3425 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3429 -- Emit a clarification message when the encapsulator is undefined,
3430 -- possibly due to contract "freezing".
3432 if Errors
/= Serious_Errors_Detected
3433 and then Present
(Freeze_Id
)
3434 and then Has_Undefined_Reference
(Encap
)
3436 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3438 end Analyze_Part_Of_In_Decl_Part
;
3440 --------------------
3441 -- Analyze_Pragma --
3442 --------------------
3444 procedure Analyze_Pragma
(N
: Node_Id
) is
3445 Loc
: constant Source_Ptr
:= Sloc
(N
);
3446 Prag_Id
: Pragma_Id
;
3449 -- Name of the source pragma, or name of the corresponding aspect for
3450 -- pragmas which originate in a source aspect. In the latter case, the
3451 -- name may be different from the pragma name.
3453 Pragma_Exit
: exception;
3454 -- This exception is used to exit pragma processing completely. It
3455 -- is used when an error is detected, and no further processing is
3456 -- required. It is also used if an earlier error has left the tree in
3457 -- a state where the pragma should not be processed.
3460 -- Number of pragma argument associations
3466 -- First four pragma arguments (pragma argument association nodes, or
3467 -- Empty if the corresponding argument does not exist).
3469 type Name_List
is array (Natural range <>) of Name_Id
;
3470 type Args_List
is array (Natural range <>) of Node_Id
;
3471 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3473 -----------------------
3474 -- Local Subprograms --
3475 -----------------------
3477 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3478 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3479 -- get the given string argument, and place it in Name_Buffer, adding
3480 -- leading and trailing asterisks if they are not already present. The
3481 -- caller has already checked that Arg is a static string expression.
3483 procedure Ada_2005_Pragma
;
3484 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3485 -- Ada 95 mode, these are implementation defined pragmas, so should be
3486 -- caught by the No_Implementation_Pragmas restriction.
3488 procedure Ada_2012_Pragma
;
3489 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3490 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3491 -- should be caught by the No_Implementation_Pragmas restriction.
3493 procedure Analyze_Depends_Global
3494 (Spec_Id
: out Entity_Id
;
3495 Subp_Decl
: out Node_Id
;
3496 Legal
: out Boolean);
3497 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3498 -- legality of the placement and related context of the pragma. Spec_Id
3499 -- is the entity of the related subprogram. Subp_Decl is the declaration
3500 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3502 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3503 -- Inspect the remainder of the list containing pragma N and look for
3504 -- a pragma that matches Id. If found, analyze the pragma.
3506 procedure Analyze_Pre_Post_Condition
;
3507 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3509 procedure Analyze_Refined_Depends_Global_Post
3510 (Spec_Id
: out Entity_Id
;
3511 Body_Id
: out Entity_Id
;
3512 Legal
: out Boolean);
3513 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3514 -- Refined_Global and Refined_Post. Verify the legality of the placement
3515 -- and related context of the pragma. Spec_Id is the entity of the
3516 -- related subprogram. Body_Id is the entity of the subprogram body.
3517 -- Flag Legal is set when the pragma is legal.
3519 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3520 -- Perform full analysis of pragma Unmodified and the write aspect of
3521 -- pragma Unused. Flag Is_Unused should be set when verifying the
3522 -- semantics of pragma Unused.
3524 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3525 -- Perform full analysis of pragma Unreferenced and the read aspect of
3526 -- pragma Unused. Flag Is_Unused should be set when verifying the
3527 -- semantics of pragma Unused.
3529 procedure Check_Ada_83_Warning
;
3530 -- Issues a warning message for the current pragma if operating in Ada
3531 -- 83 mode (used for language pragmas that are not a standard part of
3532 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3535 procedure Check_Arg_Count
(Required
: Nat
);
3536 -- Check argument count for pragma is equal to given parameter. If not,
3537 -- then issue an error message and raise Pragma_Exit.
3539 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3540 -- Arg which can either be a pragma argument association, in which case
3541 -- the check is applied to the expression of the association or an
3542 -- expression directly.
3544 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3545 -- Check that an argument has the right form for an EXTERNAL_NAME
3546 -- parameter of an extended import/export pragma. The rule is that the
3547 -- name must be an identifier or string literal (in Ada 83 mode) or a
3548 -- static string expression (in Ada 95 mode).
3550 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3551 -- Check the specified argument Arg to make sure that it is an
3552 -- identifier. If not give error and raise Pragma_Exit.
3554 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3555 -- Check the specified argument Arg to make sure that it is an integer
3556 -- literal. If not give error and raise Pragma_Exit.
3558 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3559 -- Check the specified argument Arg to make sure that it has the proper
3560 -- syntactic form for a local name and meets the semantic requirements
3561 -- for a local name. The local name is analyzed as part of the
3562 -- processing for this call. In addition, the local name is required
3563 -- to represent an entity at the library level.
3565 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3566 -- Check the specified argument Arg to make sure that it has the proper
3567 -- syntactic form for a local name and meets the semantic requirements
3568 -- for a local name. The local name is analyzed as part of the
3569 -- processing for this call.
3571 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3572 -- Check the specified argument Arg to make sure that it is a valid
3573 -- locking policy name. If not give error and raise Pragma_Exit.
3575 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3576 -- Check the specified argument Arg to make sure that it is a valid
3577 -- elaboration policy name. If not give error and raise Pragma_Exit.
3579 procedure Check_Arg_Is_One_Of
3582 procedure Check_Arg_Is_One_Of
3584 N1
, N2
, N3
: Name_Id
);
3585 procedure Check_Arg_Is_One_Of
3587 N1
, N2
, N3
, N4
: Name_Id
);
3588 procedure Check_Arg_Is_One_Of
3590 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3591 -- Check the specified argument Arg to make sure that it is an
3592 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3593 -- present). If not then give error and raise Pragma_Exit.
3595 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3596 -- Check the specified argument Arg to make sure that it is a valid
3597 -- queuing policy name. If not give error and raise Pragma_Exit.
3599 procedure Check_Arg_Is_OK_Static_Expression
3601 Typ
: Entity_Id
:= Empty
);
3602 -- Check the specified argument Arg to make sure that it is a static
3603 -- expression of the given type (i.e. it will be analyzed and resolved
3604 -- using this type, which can be any valid argument to Resolve, e.g.
3605 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3606 -- Typ is left Empty, then any static expression is allowed. Includes
3607 -- checking that the argument does not raise Constraint_Error.
3609 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3610 -- Check the specified argument Arg to make sure that it is a valid task
3611 -- dispatching policy name. If not give error and raise Pragma_Exit.
3613 procedure Check_Arg_Order
(Names
: Name_List
);
3614 -- Checks for an instance of two arguments with identifiers for the
3615 -- current pragma which are not in the sequence indicated by Names,
3616 -- and if so, generates a fatal message about bad order of arguments.
3618 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3619 -- Check there are at least N arguments present
3621 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3622 -- Check there are no more than N arguments present
3624 procedure Check_Component
3627 In_Variant_Part
: Boolean := False);
3628 -- Examine an Unchecked_Union component for correct use of per-object
3629 -- constrained subtypes, and for restrictions on finalizable components.
3630 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3631 -- should be set when Comp comes from a record variant.
3633 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3634 -- Check if a rep item of the same name as the current pragma is already
3635 -- chained as a rep pragma to the given entity. If so give a message
3636 -- about the duplicate, and then raise Pragma_Exit so does not return.
3637 -- Note that if E is a type, then this routine avoids flagging a pragma
3638 -- which applies to a parent type from which E is derived.
3640 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3641 -- Nam is an N_String_Literal node containing the external name set by
3642 -- an Import or Export pragma (or extended Import or Export pragma).
3643 -- This procedure checks for possible duplications if this is the export
3644 -- case, and if found, issues an appropriate error message.
3646 procedure Check_Expr_Is_OK_Static_Expression
3648 Typ
: Entity_Id
:= Empty
);
3649 -- Check the specified expression Expr to make sure that it is a static
3650 -- expression of the given type (i.e. it will be analyzed and resolved
3651 -- using this type, which can be any valid argument to Resolve, e.g.
3652 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3653 -- Typ is left Empty, then any static expression is allowed. Includes
3654 -- checking that the expression does not raise Constraint_Error.
3656 procedure Check_First_Subtype
(Arg
: Node_Id
);
3657 -- Checks that Arg, whose expression is an entity name, references a
3660 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3661 -- Checks that the given argument has an identifier, and if so, requires
3662 -- it to match the given identifier name. If there is no identifier, or
3663 -- a non-matching identifier, then an error message is given and
3664 -- Pragma_Exit is raised.
3666 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3667 -- Checks that the given argument has an identifier, and if so, requires
3668 -- it to match one of the given identifier names. If there is no
3669 -- identifier, or a non-matching identifier, then an error message is
3670 -- given and Pragma_Exit is raised.
3672 procedure Check_In_Main_Program
;
3673 -- Common checks for pragmas that appear within a main program
3674 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3676 procedure Check_Interrupt_Or_Attach_Handler
;
3677 -- Common processing for first argument of pragma Interrupt_Handler or
3678 -- pragma Attach_Handler.
3680 procedure Check_Loop_Pragma_Placement
;
3681 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3682 -- appear immediately within a construct restricted to loops, and that
3683 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3685 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3686 -- Check that pragma appears in a declarative part, or in a package
3687 -- specification, i.e. that it does not occur in a statement sequence
3690 procedure Check_No_Identifier
(Arg
: Node_Id
);
3691 -- Checks that the given argument does not have an identifier. If
3692 -- an identifier is present, then an error message is issued, and
3693 -- Pragma_Exit is raised.
3695 procedure Check_No_Identifiers
;
3696 -- Checks that none of the arguments to the pragma has an identifier.
3697 -- If any argument has an identifier, then an error message is issued,
3698 -- and Pragma_Exit is raised.
3700 procedure Check_No_Link_Name
;
3701 -- Checks that no link name is specified
3703 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3704 -- Checks if the given argument has an identifier, and if so, requires
3705 -- it to match the given identifier name. If there is a non-matching
3706 -- identifier, then an error message is given and Pragma_Exit is raised.
3708 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3709 -- Checks if the given argument has an identifier, and if so, requires
3710 -- it to match the given identifier name. If there is a non-matching
3711 -- identifier, then an error message is given and Pragma_Exit is raised.
3712 -- In this version of the procedure, the identifier name is given as
3713 -- a string with lower case letters.
3715 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3716 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3717 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3718 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3719 -- is an OK static boolean expression. Emit an error if this is not the
3722 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3723 -- Constr is a constraint from an N_Subtype_Indication node from a
3724 -- component constraint in an Unchecked_Union type. This routine checks
3725 -- that the constraint is static as required by the restrictions for
3728 procedure Check_Valid_Configuration_Pragma
;
3729 -- Legality checks for placement of a configuration pragma
3731 procedure Check_Valid_Library_Unit_Pragma
;
3732 -- Legality checks for library unit pragmas. A special case arises for
3733 -- pragmas in generic instances that come from copies of the original
3734 -- library unit pragmas in the generic templates. In the case of other
3735 -- than library level instantiations these can appear in contexts which
3736 -- would normally be invalid (they only apply to the original template
3737 -- and to library level instantiations), and they are simply ignored,
3738 -- which is implemented by rewriting them as null statements.
3740 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3741 -- Check an Unchecked_Union variant for lack of nested variants and
3742 -- presence of at least one component. UU_Typ is the related Unchecked_
3745 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3746 -- Subsidiary routine to the processing of pragmas Abstract_State,
3747 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3748 -- Refined_Global and Refined_State. Transform argument Arg into
3749 -- an aggregate if not one already. N_Null is never transformed.
3750 -- Arg may denote an aspect specification or a pragma argument
3753 procedure Error_Pragma
(Msg
: String);
3754 pragma No_Return
(Error_Pragma
);
3755 -- Outputs error message for current pragma. The message contains a %
3756 -- that will be replaced with the pragma name, and the flag is placed
3757 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3758 -- calls Fix_Error (see spec of that procedure for details).
3760 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3761 pragma No_Return
(Error_Pragma_Arg
);
3762 -- Outputs error message for current pragma. The message may contain
3763 -- a % that will be replaced with the pragma name. The parameter Arg
3764 -- may either be a pragma argument association, in which case the flag
3765 -- is placed on the expression of this association, or an expression,
3766 -- in which case the flag is placed directly on the expression. The
3767 -- message is placed using Error_Msg_N, so the message may also contain
3768 -- an & insertion character which will reference the given Arg value.
3769 -- After placing the message, Pragma_Exit is raised. Note: this routine
3770 -- calls Fix_Error (see spec of that procedure for details).
3772 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3773 pragma No_Return
(Error_Pragma_Arg
);
3774 -- Similar to above form of Error_Pragma_Arg except that two messages
3775 -- are provided, the second is a continuation comment starting with \.
3777 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3778 pragma No_Return
(Error_Pragma_Arg_Ident
);
3779 -- Outputs error message for current pragma. The message may contain a %
3780 -- that will be replaced with the pragma name. The parameter Arg must be
3781 -- a pragma argument association with a non-empty identifier (i.e. its
3782 -- Chars field must be set), and the error message is placed on the
3783 -- identifier. The message is placed using Error_Msg_N so the message
3784 -- may also contain an & insertion character which will reference
3785 -- the identifier. After placing the message, Pragma_Exit is raised.
3786 -- Note: this routine calls Fix_Error (see spec of that procedure for
3789 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3790 pragma No_Return
(Error_Pragma_Ref
);
3791 -- Outputs error message for current pragma. The message may contain
3792 -- a % that will be replaced with the pragma name. The parameter Ref
3793 -- must be an entity whose name can be referenced by & and sloc by #.
3794 -- After placing the message, Pragma_Exit is raised. Note: this routine
3795 -- calls Fix_Error (see spec of that procedure for details).
3797 function Find_Lib_Unit_Name
return Entity_Id
;
3798 -- Used for a library unit pragma to find the entity to which the
3799 -- library unit pragma applies, returns the entity found.
3801 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3802 -- If the pragma is a compilation unit pragma, the id must denote the
3803 -- compilation unit in the same compilation, and the pragma must appear
3804 -- in the list of preceding or trailing pragmas. If it is a program
3805 -- unit pragma that is not a compilation unit pragma, then the
3806 -- identifier must be visible.
3808 function Find_Unique_Parameterless_Procedure
3810 Arg
: Node_Id
) return Entity_Id
;
3811 -- Used for a procedure pragma to find the unique parameterless
3812 -- procedure identified by Name, returns it if it exists, otherwise
3813 -- errors out and uses Arg as the pragma argument for the message.
3815 function Fix_Error
(Msg
: String) return String;
3816 -- This is called prior to issuing an error message. Msg is the normal
3817 -- error message issued in the pragma case. This routine checks for the
3818 -- case of a pragma coming from an aspect in the source, and returns a
3819 -- message suitable for the aspect case as follows:
3821 -- Each substring "pragma" is replaced by "aspect"
3823 -- If "argument of" is at the start of the error message text, it is
3824 -- replaced by "entity for".
3826 -- If "argument" is at the start of the error message text, it is
3827 -- replaced by "entity".
3829 -- So for example, "argument of pragma X must be discrete type"
3830 -- returns "entity for aspect X must be a discrete type".
3832 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3833 -- be different from the pragma name). If the current pragma results
3834 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3835 -- original pragma name.
3837 procedure Gather_Associations
3839 Args
: out Args_List
);
3840 -- This procedure is used to gather the arguments for a pragma that
3841 -- permits arbitrary ordering of parameters using the normal rules
3842 -- for named and positional parameters. The Names argument is a list
3843 -- of Name_Id values that corresponds to the allowed pragma argument
3844 -- association identifiers in order. The result returned in Args is
3845 -- a list of corresponding expressions that are the pragma arguments.
3846 -- Note that this is a list of expressions, not of pragma argument
3847 -- associations (Gather_Associations has completely checked all the
3848 -- optional identifiers when it returns). An entry in Args is Empty
3849 -- on return if the corresponding argument is not present.
3851 procedure GNAT_Pragma
;
3852 -- Called for all GNAT defined pragmas to check the relevant restriction
3853 -- (No_Implementation_Pragmas).
3855 function Is_Before_First_Decl
3856 (Pragma_Node
: Node_Id
;
3857 Decls
: List_Id
) return Boolean;
3858 -- Return True if Pragma_Node is before the first declarative item in
3859 -- Decls where Decls is the list of declarative items.
3861 function Is_Configuration_Pragma
return Boolean;
3862 -- Determines if the placement of the current pragma is appropriate
3863 -- for a configuration pragma.
3865 function Is_In_Context_Clause
return Boolean;
3866 -- Returns True if pragma appears within the context clause of a unit,
3867 -- and False for any other placement (does not generate any messages).
3869 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3870 -- Analyzes the argument, and determines if it is a static string
3871 -- expression, returns True if so, False if non-static or not String.
3872 -- A special case is that a string literal returns True in Ada 83 mode
3873 -- (which has no such thing as static string expressions). Note that
3874 -- the call analyzes its argument, so this cannot be used for the case
3875 -- where an identifier might not be declared.
3877 procedure Pragma_Misplaced
;
3878 pragma No_Return
(Pragma_Misplaced
);
3879 -- Issue fatal error message for misplaced pragma
3881 procedure Process_Atomic_Independent_Shared_Volatile
;
3882 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3883 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3884 -- and treated as being identical in effect to pragma Atomic.
3886 procedure Process_Compile_Time_Warning_Or_Error
;
3887 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3889 procedure Process_Convention
3890 (C
: out Convention_Id
;
3891 Ent
: out Entity_Id
);
3892 -- Common processing for Convention, Interface, Import and Export.
3893 -- Checks first two arguments of pragma, and sets the appropriate
3894 -- convention value in the specified entity or entities. On return
3895 -- C is the convention, Ent is the referenced entity.
3897 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3898 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3899 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3901 procedure Process_Extended_Import_Export_Object_Pragma
3902 (Arg_Internal
: Node_Id
;
3903 Arg_External
: Node_Id
;
3904 Arg_Size
: Node_Id
);
3905 -- Common processing for the pragmas Import/Export_Object. The three
3906 -- arguments correspond to the three named parameters of the pragmas. An
3907 -- argument is empty if the corresponding parameter is not present in
3910 procedure Process_Extended_Import_Export_Internal_Arg
3911 (Arg_Internal
: Node_Id
:= Empty
);
3912 -- Common processing for all extended Import and Export pragmas. The
3913 -- argument is the pragma parameter for the Internal argument. If
3914 -- Arg_Internal is empty or inappropriate, an error message is posted.
3915 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3916 -- set to identify the referenced entity.
3918 procedure Process_Extended_Import_Export_Subprogram_Pragma
3919 (Arg_Internal
: Node_Id
;
3920 Arg_External
: Node_Id
;
3921 Arg_Parameter_Types
: Node_Id
;
3922 Arg_Result_Type
: Node_Id
:= Empty
;
3923 Arg_Mechanism
: Node_Id
;
3924 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3925 -- Common processing for all extended Import and Export pragmas applying
3926 -- to subprograms. The caller omits any arguments that do not apply to
3927 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3928 -- only in the Import_Function and Export_Function cases). The argument
3929 -- names correspond to the allowed pragma association identifiers.
3931 procedure Process_Generic_List
;
3932 -- Common processing for Share_Generic and Inline_Generic
3934 procedure Process_Import_Or_Interface
;
3935 -- Common processing for Import or Interface
3937 procedure Process_Import_Predefined_Type
;
3938 -- Processing for completing a type with pragma Import. This is used
3939 -- to declare types that match predefined C types, especially for cases
3940 -- without corresponding Ada predefined type.
3942 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3943 -- Inline status of a subprogram, indicated as follows:
3944 -- Suppressed: inlining is suppressed for the subprogram
3945 -- Disabled: no inlining is requested for the subprogram
3946 -- Enabled: inlining is requested/required for the subprogram
3948 procedure Process_Inline
(Status
: Inline_Status
);
3949 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3950 -- indicates the inline status specified by the pragma.
3952 procedure Process_Interface_Name
3953 (Subprogram_Def
: Entity_Id
;
3955 Link_Arg
: Node_Id
);
3956 -- Given the last two arguments of pragma Import, pragma Export, or
3957 -- pragma Interface_Name, performs validity checks and sets the
3958 -- Interface_Name field of the given subprogram entity to the
3959 -- appropriate external or link name, depending on the arguments given.
3960 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3961 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3962 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3963 -- nor Link_Arg is present, the interface name is set to the default
3964 -- from the subprogram name.
3966 procedure Process_Interrupt_Or_Attach_Handler
;
3967 -- Common processing for Interrupt and Attach_Handler pragmas
3969 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3970 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3971 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3972 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3973 -- is not set in the Restrictions case.
3975 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3976 -- Common processing for Suppress and Unsuppress. The boolean parameter
3977 -- Suppress_Case is True for the Suppress case, and False for the
3980 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3981 -- Subsidiary to the analysis of pragmas Independent[_Components].
3982 -- Record such a pragma N applied to entity E for future checks.
3984 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3985 -- This procedure sets the Is_Exported flag for the given entity,
3986 -- checking that the entity was not previously imported. Arg is
3987 -- the argument that specified the entity. A check is also made
3988 -- for exporting inappropriate entities.
3990 procedure Set_Extended_Import_Export_External_Name
3991 (Internal_Ent
: Entity_Id
;
3992 Arg_External
: Node_Id
);
3993 -- Common processing for all extended import export pragmas. The first
3994 -- argument, Internal_Ent, is the internal entity, which has already
3995 -- been checked for validity by the caller. Arg_External is from the
3996 -- Import or Export pragma, and may be null if no External parameter
3997 -- was present. If Arg_External is present and is a non-null string
3998 -- (a null string is treated as the default), then the Interface_Name
3999 -- field of Internal_Ent is set appropriately.
4001 procedure Set_Imported
(E
: Entity_Id
);
4002 -- This procedure sets the Is_Imported flag for the given entity,
4003 -- checking that it is not previously exported or imported.
4005 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
4006 -- Mech is a parameter passing mechanism (see Import_Function syntax
4007 -- for MECHANISM_NAME). This routine checks that the mechanism argument
4008 -- has the right form, and if not issues an error message. If the
4009 -- argument has the right form then the Mechanism field of Ent is
4010 -- set appropriately.
4012 procedure Set_Rational_Profile
;
4013 -- Activate the set of configuration pragmas and permissions that make
4014 -- up the Rational profile.
4016 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
4017 -- Activate the set of configuration pragmas and restrictions that make
4018 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
4019 -- Ravenscar. N is the corresponding pragma node, which is used for
4020 -- error messages on any constructs violating the profile.
4022 ----------------------------------
4023 -- Acquire_Warning_Match_String --
4024 ----------------------------------
4026 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4028 String_To_Name_Buffer
4029 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4031 -- Add asterisk at start if not already there
4033 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4034 Name_Buffer
(2 .. Name_Len
+ 1) :=
4035 Name_Buffer
(1 .. Name_Len
);
4036 Name_Buffer
(1) := '*';
4037 Name_Len
:= Name_Len
+ 1;
4040 -- Add asterisk at end if not already there
4042 if Name_Buffer
(Name_Len
) /= '*' then
4043 Name_Len
:= Name_Len
+ 1;
4044 Name_Buffer
(Name_Len
) := '*';
4046 end Acquire_Warning_Match_String
;
4048 ---------------------
4049 -- Ada_2005_Pragma --
4050 ---------------------
4052 procedure Ada_2005_Pragma
is
4054 if Ada_Version
<= Ada_95
then
4055 Check_Restriction
(No_Implementation_Pragmas
, N
);
4057 end Ada_2005_Pragma
;
4059 ---------------------
4060 -- Ada_2012_Pragma --
4061 ---------------------
4063 procedure Ada_2012_Pragma
is
4065 if Ada_Version
<= Ada_2005
then
4066 Check_Restriction
(No_Implementation_Pragmas
, N
);
4068 end Ada_2012_Pragma
;
4070 ----------------------------
4071 -- Analyze_Depends_Global --
4072 ----------------------------
4074 procedure Analyze_Depends_Global
4075 (Spec_Id
: out Entity_Id
;
4076 Subp_Decl
: out Node_Id
;
4077 Legal
: out Boolean)
4080 -- Assume that the pragma is illegal
4087 Check_Arg_Count
(1);
4089 -- Ensure the proper placement of the pragma. Depends/Global must be
4090 -- associated with a subprogram declaration or a body that acts as a
4093 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4097 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4100 -- Generic subprogram
4102 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4105 -- Object declaration of a single concurrent type
4107 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
then
4112 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4115 -- Subprogram body acts as spec
4117 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4118 and then No
(Corresponding_Spec
(Subp_Decl
))
4122 -- Subprogram body stub acts as spec
4124 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4125 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4129 -- Subprogram declaration
4131 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4136 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4144 -- If we get here, then the pragma is legal
4147 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4149 -- When the related context is an entry, the entry must belong to a
4150 -- protected unit (SPARK RM 6.1.4(6)).
4152 if Is_Entry_Declaration
(Spec_Id
)
4153 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4158 -- When the related context is an anonymous object created for a
4159 -- simple concurrent type, the type must be a task
4160 -- (SPARK RM 6.1.4(6)).
4162 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4163 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4169 -- A pragma that applies to a Ghost entity becomes Ghost for the
4170 -- purposes of legality checks and removal of ignored Ghost code.
4172 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
4173 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4174 end Analyze_Depends_Global
;
4176 ------------------------
4177 -- Analyze_If_Present --
4178 ------------------------
4180 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4184 pragma Assert
(Is_List_Member
(N
));
4186 -- Inspect the declarations or statements following pragma N looking
4187 -- for another pragma whose Id matches the caller's request. If it is
4188 -- available, analyze it.
4191 while Present
(Stmt
) loop
4192 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4193 Analyze_Pragma
(Stmt
);
4196 -- The first source declaration or statement immediately following
4197 -- N ends the region where a pragma may appear.
4199 elsif Comes_From_Source
(Stmt
) then
4205 end Analyze_If_Present
;
4207 --------------------------------
4208 -- Analyze_Pre_Post_Condition --
4209 --------------------------------
4211 procedure Analyze_Pre_Post_Condition
is
4212 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4213 Subp_Decl
: Node_Id
;
4214 Subp_Id
: Entity_Id
;
4216 Duplicates_OK
: Boolean := False;
4217 -- Flag set when a pre/postcondition allows multiple pragmas of the
4220 In_Body_OK
: Boolean := False;
4221 -- Flag set when a pre/postcondition is allowed to appear on a body
4222 -- even though the subprogram may have a spec.
4224 Is_Pre_Post
: Boolean := False;
4225 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4229 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4230 -- offer uniformity among the various kinds of pre/postconditions by
4231 -- rewriting the pragma identifier. This allows the retrieval of the
4232 -- original pragma name by routine Original_Aspect_Pragma_Name.
4234 if Comes_From_Source
(N
) then
4235 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4236 Is_Pre_Post
:= True;
4237 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4238 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4240 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4241 Is_Pre_Post
:= True;
4242 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4243 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4247 -- Determine the semantics with respect to duplicates and placement
4248 -- in a body. Pragmas Precondition and Postcondition were introduced
4249 -- before aspects and are not subject to the same aspect-like rules.
4251 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4252 Duplicates_OK
:= True;
4258 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4259 -- argument without an identifier.
4262 Check_Arg_Count
(1);
4263 Check_No_Identifiers
;
4265 -- Pragmas Precondition and Postcondition have complex argument
4269 Check_At_Least_N_Arguments
(1);
4270 Check_At_Most_N_Arguments
(2);
4271 Check_Optional_Identifier
(Arg1
, Name_Check
);
4273 if Present
(Arg2
) then
4274 Check_Optional_Identifier
(Arg2
, Name_Message
);
4275 Preanalyze_Spec_Expression
4276 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4280 -- For a pragma PPC in the extended main source unit, record enabled
4282 -- ??? nothing checks that the pragma is in the main source unit
4284 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4285 Set_SCO_Pragma_Enabled
(Loc
);
4288 -- Ensure the proper placement of the pragma
4291 Find_Related_Declaration_Or_Body
4292 (N
, Do_Checks
=> not Duplicates_OK
);
4294 -- When a pre/postcondition pragma applies to an abstract subprogram,
4295 -- its original form must be an aspect with 'Class.
4297 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4298 if not From_Aspect_Specification
(N
) then
4300 ("pragma % cannot be applied to abstract subprogram");
4302 elsif not Class_Present
(N
) then
4304 ("aspect % requires ''Class for abstract subprogram");
4307 -- Entry declaration
4309 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4312 -- Generic subprogram declaration
4314 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4319 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4320 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4324 -- Subprogram body stub
4326 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4327 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4331 -- Subprogram declaration
4333 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4335 -- AI05-0230: When a pre/postcondition pragma applies to a null
4336 -- procedure, its original form must be an aspect with 'Class.
4338 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4339 and then Null_Present
(Specification
(Subp_Decl
))
4340 and then From_Aspect_Specification
(N
)
4341 and then not Class_Present
(N
)
4343 Error_Pragma
("aspect % requires ''Class for null procedure");
4346 -- Otherwise the placement is illegal
4353 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4355 -- Chain the pragma on the contract for further processing by
4356 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4358 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4360 -- A pragma that applies to a Ghost entity becomes Ghost for the
4361 -- purposes of legality checks and removal of ignored Ghost code.
4363 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
4365 -- Fully analyze the pragma when it appears inside an entry or
4366 -- subprogram body because it cannot benefit from forward references.
4368 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4370 N_Subprogram_Body_Stub
)
4372 -- The legality checks of pragmas Precondition and Postcondition
4373 -- are affected by the SPARK mode in effect and the volatility of
4374 -- the context. Analyze all pragmas in a specific order.
4376 Analyze_If_Present
(Pragma_SPARK_Mode
);
4377 Analyze_If_Present
(Pragma_Volatile_Function
);
4378 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4380 end Analyze_Pre_Post_Condition
;
4382 -----------------------------------------
4383 -- Analyze_Refined_Depends_Global_Post --
4384 -----------------------------------------
4386 procedure Analyze_Refined_Depends_Global_Post
4387 (Spec_Id
: out Entity_Id
;
4388 Body_Id
: out Entity_Id
;
4389 Legal
: out Boolean)
4391 Body_Decl
: Node_Id
;
4392 Spec_Decl
: Node_Id
;
4395 -- Assume that the pragma is illegal
4402 Check_Arg_Count
(1);
4403 Check_No_Identifiers
;
4405 -- Verify the placement of the pragma and check for duplicates. The
4406 -- pragma must apply to a subprogram body [stub].
4408 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4412 if Nkind
(Body_Decl
) = N_Entry_Body
then
4417 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4420 -- Subprogram body stub
4422 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4427 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4435 Body_Id
:= Defining_Entity
(Body_Decl
);
4436 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4438 -- The pragma must apply to the second declaration of a subprogram.
4439 -- In other words, the body [stub] cannot acts as a spec.
4441 if No
(Spec_Id
) then
4442 Error_Pragma
("pragma % cannot apply to a stand alone body");
4445 -- Catch the case where the subprogram body is a subunit and acts as
4446 -- the third declaration of the subprogram.
4448 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4449 Error_Pragma
("pragma % cannot apply to a subunit");
4453 -- A refined pragma can only apply to the body [stub] of a subprogram
4454 -- declared in the visible part of a package. Retrieve the context of
4455 -- the subprogram declaration.
4457 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4459 -- When dealing with protected entries or protected subprograms, use
4460 -- the enclosing protected type as the proper context.
4462 if Ekind_In
(Spec_Id
, E_Entry
,
4466 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4468 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4471 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4473 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4474 & "subprogram declared in a package specification"));
4478 -- If we get here, then the pragma is legal
4482 -- A pragma that applies to a Ghost entity becomes Ghost for the
4483 -- purposes of legality checks and removal of ignored Ghost code.
4485 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
4487 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4488 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4490 end Analyze_Refined_Depends_Global_Post
;
4492 ----------------------------------
4493 -- Analyze_Unmodified_Or_Unused --
4494 ----------------------------------
4496 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4501 Ghost_Error_Posted
: Boolean := False;
4502 -- Flag set when an error concerning the illegal mix of Ghost and
4503 -- non-Ghost variables is emitted.
4505 Ghost_Id
: Entity_Id
:= Empty
;
4506 -- The entity of the first Ghost variable encountered while
4507 -- processing the arguments of the pragma.
4511 Check_At_Least_N_Arguments
(1);
4513 -- Loop through arguments
4516 while Present
(Arg
) loop
4517 Check_No_Identifier
(Arg
);
4519 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4520 -- in fact generate reference, so that the entity will have a
4521 -- reference, which will inhibit any warnings about it not
4522 -- being referenced, and also properly show up in the ali file
4523 -- as a reference. But this reference is recorded before the
4524 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4525 -- generated for this reference.
4527 Check_Arg_Is_Local_Name
(Arg
);
4528 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4530 if Is_Entity_Name
(Arg_Expr
) then
4531 Arg_Id
:= Entity
(Arg_Expr
);
4533 -- Skip processing the argument if already flagged
4535 if Is_Assignable
(Arg_Id
)
4536 and then not Has_Pragma_Unmodified
(Arg_Id
)
4537 and then not Has_Pragma_Unused
(Arg_Id
)
4539 Set_Has_Pragma_Unmodified
(Arg_Id
);
4542 Set_Has_Pragma_Unused
(Arg_Id
);
4545 -- A pragma that applies to a Ghost entity becomes Ghost for
4546 -- the purposes of legality checks and removal of ignored
4549 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
4551 -- Capture the entity of the first Ghost variable being
4552 -- processed for error detection purposes.
4554 if Is_Ghost_Entity
(Arg_Id
) then
4555 if No
(Ghost_Id
) then
4559 -- Otherwise the variable is non-Ghost. It is illegal to mix
4560 -- references to Ghost and non-Ghost entities
4563 elsif Present
(Ghost_Id
)
4564 and then not Ghost_Error_Posted
4566 Ghost_Error_Posted
:= True;
4568 Error_Msg_Name_1
:= Pname
;
4570 ("pragma % cannot mention ghost and non-ghost "
4573 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4574 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4576 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4577 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4580 -- Warn if already flagged as Unused or Unmodified
4582 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4583 if Has_Pragma_Unused
(Arg_Id
) then
4585 ("??pragma Unused already given for &!", Arg_Expr
,
4589 ("??pragma Unmodified already given for &!", Arg_Expr
,
4593 -- Otherwise the pragma referenced an illegal entity
4597 ("pragma% can only be applied to a variable", Arg_Expr
);
4603 end Analyze_Unmodified_Or_Unused
;
4605 -----------------------------------
4606 -- Analyze_Unreference_Or_Unused --
4607 -----------------------------------
4609 procedure Analyze_Unreferenced_Or_Unused
4610 (Is_Unused
: Boolean := False)
4617 Ghost_Error_Posted
: Boolean := False;
4618 -- Flag set when an error concerning the illegal mix of Ghost and
4619 -- non-Ghost names is emitted.
4621 Ghost_Id
: Entity_Id
:= Empty
;
4622 -- The entity of the first Ghost name encountered while processing
4623 -- the arguments of the pragma.
4627 Check_At_Least_N_Arguments
(1);
4629 -- Check case of appearing within context clause
4631 if not Is_Unused
and then Is_In_Context_Clause
then
4633 -- The arguments must all be units mentioned in a with clause in
4634 -- the same context clause. Note that Par.Prag already checked
4635 -- that the arguments are either identifiers or selected
4639 while Present
(Arg
) loop
4640 Citem
:= First
(List_Containing
(N
));
4641 while Citem
/= N
loop
4642 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4644 if Nkind
(Citem
) = N_With_Clause
4645 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4647 Set_Has_Pragma_Unreferenced
4650 (Library_Unit
(Citem
))));
4651 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4660 ("argument of pragma% is not withed unit", Arg
);
4666 -- Case of not in list of context items
4670 while Present
(Arg
) loop
4671 Check_No_Identifier
(Arg
);
4673 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4674 -- in fact generate reference, so that the entity will have a
4675 -- reference, which will inhibit any warnings about it not
4676 -- being referenced, and also properly show up in the ali file
4677 -- as a reference. But this reference is recorded before the
4678 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4679 -- generated for this reference.
4681 Check_Arg_Is_Local_Name
(Arg
);
4682 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4684 if Is_Entity_Name
(Arg_Expr
) then
4685 Arg_Id
:= Entity
(Arg_Expr
);
4687 -- Warn if already flagged as Unused or Unreferenced and
4688 -- skip processing the argument.
4690 if Has_Pragma_Unreferenced
(Arg_Id
) then
4691 if Has_Pragma_Unused
(Arg_Id
) then
4693 ("??pragma Unused already given for &!", Arg_Expr
,
4697 ("??pragma Unreferenced already given for &!",
4701 -- Apply Unreferenced to the entity
4704 -- If the entity is overloaded, the pragma applies to the
4705 -- most recent overloading, as documented. In this case,
4706 -- name resolution does not generate a reference, so it
4707 -- must be done here explicitly.
4709 if Is_Overloaded
(Arg_Expr
) then
4710 Generate_Reference
(Arg_Id
, N
);
4713 Set_Has_Pragma_Unreferenced
(Arg_Id
);
4716 Set_Has_Pragma_Unused
(Arg_Id
);
4719 -- A pragma that applies to a Ghost entity becomes Ghost
4720 -- for the purposes of legality checks and removal of
4721 -- ignored Ghost code.
4723 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
4725 -- Capture the entity of the first Ghost name being
4726 -- processed for error detection purposes.
4728 if Is_Ghost_Entity
(Arg_Id
) then
4729 if No
(Ghost_Id
) then
4733 -- Otherwise the name is non-Ghost. It is illegal to mix
4734 -- references to Ghost and non-Ghost entities
4737 elsif Present
(Ghost_Id
)
4738 and then not Ghost_Error_Posted
4740 Ghost_Error_Posted
:= True;
4742 Error_Msg_Name_1
:= Pname
;
4744 ("pragma % cannot mention ghost and non-ghost "
4747 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4749 ("\& # declared as ghost", N
, Ghost_Id
);
4751 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4753 ("\& # declared as non-ghost", N
, Arg_Id
);
4761 end Analyze_Unreferenced_Or_Unused
;
4763 --------------------------
4764 -- Check_Ada_83_Warning --
4765 --------------------------
4767 procedure Check_Ada_83_Warning
is
4769 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4770 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4772 end Check_Ada_83_Warning
;
4774 ---------------------
4775 -- Check_Arg_Count --
4776 ---------------------
4778 procedure Check_Arg_Count
(Required
: Nat
) is
4780 if Arg_Count
/= Required
then
4781 Error_Pragma
("wrong number of arguments for pragma%");
4783 end Check_Arg_Count
;
4785 --------------------------------
4786 -- Check_Arg_Is_External_Name --
4787 --------------------------------
4789 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4790 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4793 if Nkind
(Argx
) = N_Identifier
then
4797 Analyze_And_Resolve
(Argx
, Standard_String
);
4799 if Is_OK_Static_Expression
(Argx
) then
4802 elsif Etype
(Argx
) = Any_Type
then
4805 -- An interesting special case, if we have a string literal and
4806 -- we are in Ada 83 mode, then we allow it even though it will
4807 -- not be flagged as static. This allows expected Ada 83 mode
4808 -- use of external names which are string literals, even though
4809 -- technically these are not static in Ada 83.
4811 elsif Ada_Version
= Ada_83
4812 and then Nkind
(Argx
) = N_String_Literal
4816 -- Static expression that raises Constraint_Error. This has
4817 -- already been flagged, so just exit from pragma processing.
4819 elsif Is_OK_Static_Expression
(Argx
) then
4822 -- Here we have a real error (non-static expression)
4825 Error_Msg_Name_1
:= Pname
;
4828 Msg
: constant String :=
4829 "argument for pragma% must be a identifier or "
4830 & "static string expression!";
4832 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
4837 end Check_Arg_Is_External_Name
;
4839 -----------------------------
4840 -- Check_Arg_Is_Identifier --
4841 -----------------------------
4843 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
4844 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4846 if Nkind
(Argx
) /= N_Identifier
then
4848 ("argument for pragma% must be identifier", Argx
);
4850 end Check_Arg_Is_Identifier
;
4852 ----------------------------------
4853 -- Check_Arg_Is_Integer_Literal --
4854 ----------------------------------
4856 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
4857 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4859 if Nkind
(Argx
) /= N_Integer_Literal
then
4861 ("argument for pragma% must be integer literal", Argx
);
4863 end Check_Arg_Is_Integer_Literal
;
4865 -------------------------------------------
4866 -- Check_Arg_Is_Library_Level_Local_Name --
4867 -------------------------------------------
4871 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4872 -- | library_unit_NAME
4874 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
4876 Check_Arg_Is_Local_Name
(Arg
);
4878 -- If it came from an aspect, we want to give the error just as if it
4879 -- came from source.
4881 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
4882 and then (Comes_From_Source
(N
)
4883 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
4886 ("argument for pragma% must be library level entity", Arg
);
4888 end Check_Arg_Is_Library_Level_Local_Name
;
4890 -----------------------------
4891 -- Check_Arg_Is_Local_Name --
4892 -----------------------------
4896 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4897 -- | library_unit_NAME
4899 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
4900 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4903 -- If this pragma came from an aspect specification, we don't want to
4904 -- check for this error, because that would cause spurious errors, in
4905 -- case a type is frozen in a scope more nested than the type. The
4906 -- aspect itself of course can't be anywhere but on the declaration
4909 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
4910 if From_Aspect_Specification
(Parent
(Arg
)) then
4914 -- Arg is the Expression of an N_Pragma_Argument_Association
4917 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
4924 if Nkind
(Argx
) not in N_Direct_Name
4925 and then (Nkind
(Argx
) /= N_Attribute_Reference
4926 or else Present
(Expressions
(Argx
))
4927 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
4928 and then (not Is_Entity_Name
(Argx
)
4929 or else not Is_Compilation_Unit
(Entity
(Argx
)))
4931 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
4934 -- No further check required if not an entity name
4936 if not Is_Entity_Name
(Argx
) then
4942 Ent
: constant Entity_Id
:= Entity
(Argx
);
4943 Scop
: constant Entity_Id
:= Scope
(Ent
);
4946 -- Case of a pragma applied to a compilation unit: pragma must
4947 -- occur immediately after the program unit in the compilation.
4949 if Is_Compilation_Unit
(Ent
) then
4951 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
4954 -- Case of pragma placed immediately after spec
4956 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
4959 -- Case of pragma placed immediately after body
4961 elsif Nkind
(Decl
) = N_Subprogram_Declaration
4962 and then Present
(Corresponding_Body
(Decl
))
4966 (Parent
(Unit_Declaration_Node
4967 (Corresponding_Body
(Decl
))));
4969 -- All other cases are illegal
4976 -- Special restricted placement rule from 10.2.1(11.8/2)
4978 elsif Is_Generic_Formal
(Ent
)
4979 and then Prag_Id
= Pragma_Preelaborable_Initialization
4981 OK
:= List_Containing
(N
) =
4982 Generic_Formal_Declarations
4983 (Unit_Declaration_Node
(Scop
));
4985 -- If this is an aspect applied to a subprogram body, the
4986 -- pragma is inserted in its declarative part.
4988 elsif From_Aspect_Specification
(N
)
4989 and then Ent
= Current_Scope
4991 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
4995 -- If the aspect is a predicate (possibly others ???) and the
4996 -- context is a record type, this is a discriminant expression
4997 -- within a type declaration, that freezes the predicated
5000 elsif From_Aspect_Specification
(N
)
5001 and then Prag_Id
= Pragma_Predicate
5002 and then Ekind
(Current_Scope
) = E_Record_Type
5003 and then Scop
= Scope
(Current_Scope
)
5007 -- Default case, just check that the pragma occurs in the scope
5008 -- of the entity denoted by the name.
5011 OK
:= Current_Scope
= Scop
;
5016 ("pragma% argument must be in same declarative part", Arg
);
5020 end Check_Arg_Is_Local_Name
;
5022 ---------------------------------
5023 -- Check_Arg_Is_Locking_Policy --
5024 ---------------------------------
5026 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5027 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5030 Check_Arg_Is_Identifier
(Argx
);
5032 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5033 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5035 end Check_Arg_Is_Locking_Policy
;
5037 -----------------------------------------------
5038 -- Check_Arg_Is_Partition_Elaboration_Policy --
5039 -----------------------------------------------
5041 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5042 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5045 Check_Arg_Is_Identifier
(Argx
);
5047 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5049 ("& is not a valid partition elaboration policy name", Argx
);
5051 end Check_Arg_Is_Partition_Elaboration_Policy
;
5053 -------------------------
5054 -- Check_Arg_Is_One_Of --
5055 -------------------------
5057 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5058 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5061 Check_Arg_Is_Identifier
(Argx
);
5063 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5064 Error_Msg_Name_2
:= N1
;
5065 Error_Msg_Name_3
:= N2
;
5066 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5068 end Check_Arg_Is_One_Of
;
5070 procedure Check_Arg_Is_One_Of
5072 N1
, N2
, N3
: Name_Id
)
5074 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5077 Check_Arg_Is_Identifier
(Argx
);
5079 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5080 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5082 end Check_Arg_Is_One_Of
;
5084 procedure Check_Arg_Is_One_Of
5086 N1
, N2
, N3
, N4
: Name_Id
)
5088 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5091 Check_Arg_Is_Identifier
(Argx
);
5093 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5094 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5096 end Check_Arg_Is_One_Of
;
5098 procedure Check_Arg_Is_One_Of
5100 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5102 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5105 Check_Arg_Is_Identifier
(Argx
);
5107 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5108 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5110 end Check_Arg_Is_One_Of
;
5112 ---------------------------------
5113 -- Check_Arg_Is_Queuing_Policy --
5114 ---------------------------------
5116 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5117 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5120 Check_Arg_Is_Identifier
(Argx
);
5122 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5123 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5125 end Check_Arg_Is_Queuing_Policy
;
5127 ---------------------------------------
5128 -- Check_Arg_Is_OK_Static_Expression --
5129 ---------------------------------------
5131 procedure Check_Arg_Is_OK_Static_Expression
5133 Typ
: Entity_Id
:= Empty
)
5136 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5137 end Check_Arg_Is_OK_Static_Expression
;
5139 ------------------------------------------
5140 -- Check_Arg_Is_Task_Dispatching_Policy --
5141 ------------------------------------------
5143 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5144 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5147 Check_Arg_Is_Identifier
(Argx
);
5149 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5151 ("& is not an allowed task dispatching policy name", Argx
);
5153 end Check_Arg_Is_Task_Dispatching_Policy
;
5155 ---------------------
5156 -- Check_Arg_Order --
5157 ---------------------
5159 procedure Check_Arg_Order
(Names
: Name_List
) is
5162 Highest_So_Far
: Natural := 0;
5163 -- Highest index in Names seen do far
5167 for J
in 1 .. Arg_Count
loop
5168 if Chars
(Arg
) /= No_Name
then
5169 for K
in Names
'Range loop
5170 if Chars
(Arg
) = Names
(K
) then
5171 if K
< Highest_So_Far
then
5172 Error_Msg_Name_1
:= Pname
;
5174 ("parameters out of order for pragma%", Arg
);
5175 Error_Msg_Name_1
:= Names
(K
);
5176 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5177 Error_Msg_N
("\% must appear before %", Arg
);
5181 Highest_So_Far
:= K
;
5189 end Check_Arg_Order
;
5191 --------------------------------
5192 -- Check_At_Least_N_Arguments --
5193 --------------------------------
5195 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5197 if Arg_Count
< N
then
5198 Error_Pragma
("too few arguments for pragma%");
5200 end Check_At_Least_N_Arguments
;
5202 -------------------------------
5203 -- Check_At_Most_N_Arguments --
5204 -------------------------------
5206 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5209 if Arg_Count
> N
then
5211 for J
in 1 .. N
loop
5213 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5216 end Check_At_Most_N_Arguments
;
5218 ---------------------
5219 -- Check_Component --
5220 ---------------------
5222 procedure Check_Component
5225 In_Variant_Part
: Boolean := False)
5227 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5228 Sindic
: constant Node_Id
:=
5229 Subtype_Indication
(Component_Definition
(Comp
));
5230 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5233 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5234 -- object constraint, then the component type shall be an Unchecked_
5237 if Nkind
(Sindic
) = N_Subtype_Indication
5238 and then Has_Per_Object_Constraint
(Comp_Id
)
5239 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5242 ("component subtype subject to per-object constraint "
5243 & "must be an Unchecked_Union", Comp
);
5245 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5246 -- the body of a generic unit, or within the body of any of its
5247 -- descendant library units, no part of the type of a component
5248 -- declared in a variant_part of the unchecked union type shall be of
5249 -- a formal private type or formal private extension declared within
5250 -- the formal part of the generic unit.
5252 elsif Ada_Version
>= Ada_2012
5253 and then In_Generic_Body
(UU_Typ
)
5254 and then In_Variant_Part
5255 and then Is_Private_Type
(Typ
)
5256 and then Is_Generic_Type
(Typ
)
5259 ("component of unchecked union cannot be of generic type", Comp
);
5261 elsif Needs_Finalization
(Typ
) then
5263 ("component of unchecked union cannot be controlled", Comp
);
5265 elsif Has_Task
(Typ
) then
5267 ("component of unchecked union cannot have tasks", Comp
);
5269 end Check_Component
;
5271 ----------------------------
5272 -- Check_Duplicate_Pragma --
5273 ----------------------------
5275 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5276 Id
: Entity_Id
:= E
;
5280 -- Nothing to do if this pragma comes from an aspect specification,
5281 -- since we could not be duplicating a pragma, and we dealt with the
5282 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5284 if From_Aspect_Specification
(N
) then
5288 -- Otherwise current pragma may duplicate previous pragma or a
5289 -- previously given aspect specification or attribute definition
5290 -- clause for the same pragma.
5292 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5296 -- If the entity is a type, then we have to make sure that the
5297 -- ostensible duplicate is not for a parent type from which this
5301 if Nkind
(P
) = N_Pragma
then
5303 Args
: constant List_Id
:=
5304 Pragma_Argument_Associations
(P
);
5307 and then Is_Entity_Name
(Expression
(First
(Args
)))
5308 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5309 and then Entity
(Expression
(First
(Args
))) /= E
5315 elsif Nkind
(P
) = N_Aspect_Specification
5316 and then Is_Type
(Entity
(P
))
5317 and then Entity
(P
) /= E
5323 -- Here we have a definite duplicate
5325 Error_Msg_Name_1
:= Pragma_Name
(N
);
5326 Error_Msg_Sloc
:= Sloc
(P
);
5328 -- For a single protected or a single task object, the error is
5329 -- issued on the original entity.
5331 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5332 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5335 if Nkind
(P
) = N_Aspect_Specification
5336 or else From_Aspect_Specification
(P
)
5338 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5340 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5345 end Check_Duplicate_Pragma
;
5347 ----------------------------------
5348 -- Check_Duplicated_Export_Name --
5349 ----------------------------------
5351 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5352 String_Val
: constant String_Id
:= Strval
(Nam
);
5355 -- We are only interested in the export case, and in the case of
5356 -- generics, it is the instance, not the template, that is the
5357 -- problem (the template will generate a warning in any case).
5359 if not Inside_A_Generic
5360 and then (Prag_Id
= Pragma_Export
5362 Prag_Id
= Pragma_Export_Procedure
5364 Prag_Id
= Pragma_Export_Valued_Procedure
5366 Prag_Id
= Pragma_Export_Function
)
5368 for J
in Externals
.First
.. Externals
.Last
loop
5369 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5370 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5371 Error_Msg_N
("external name duplicates name given#", Nam
);
5376 Externals
.Append
(Nam
);
5378 end Check_Duplicated_Export_Name
;
5380 ----------------------------------------
5381 -- Check_Expr_Is_OK_Static_Expression --
5382 ----------------------------------------
5384 procedure Check_Expr_Is_OK_Static_Expression
5386 Typ
: Entity_Id
:= Empty
)
5389 if Present
(Typ
) then
5390 Analyze_And_Resolve
(Expr
, Typ
);
5392 Analyze_And_Resolve
(Expr
);
5395 -- An expression cannot be considered static if its resolution failed
5396 -- or if it's erroneous. Stop the analysis of the related pragma.
5398 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5401 elsif Is_OK_Static_Expression
(Expr
) then
5404 -- An interesting special case, if we have a string literal and we
5405 -- are in Ada 83 mode, then we allow it even though it will not be
5406 -- flagged as static. This allows the use of Ada 95 pragmas like
5407 -- Import in Ada 83 mode. They will of course be flagged with
5408 -- warnings as usual, but will not cause errors.
5410 elsif Ada_Version
= Ada_83
5411 and then Nkind
(Expr
) = N_String_Literal
5415 -- Finally, we have a real error
5418 Error_Msg_Name_1
:= Pname
;
5419 Flag_Non_Static_Expr
5420 (Fix_Error
("argument for pragma% must be a static expression!"),
5424 end Check_Expr_Is_OK_Static_Expression
;
5426 -------------------------
5427 -- Check_First_Subtype --
5428 -------------------------
5430 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5431 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5432 Ent
: constant Entity_Id
:= Entity
(Argx
);
5435 if Is_First_Subtype
(Ent
) then
5438 elsif Is_Type
(Ent
) then
5440 ("pragma% cannot apply to subtype", Argx
);
5442 elsif Is_Object
(Ent
) then
5444 ("pragma% cannot apply to object, requires a type", Argx
);
5448 ("pragma% cannot apply to&, requires a type", Argx
);
5450 end Check_First_Subtype
;
5452 ----------------------
5453 -- Check_Identifier --
5454 ----------------------
5456 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5459 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5461 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5462 Error_Msg_Name_1
:= Pname
;
5463 Error_Msg_Name_2
:= Id
;
5464 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5468 end Check_Identifier
;
5470 --------------------------------
5471 -- Check_Identifier_Is_One_Of --
5472 --------------------------------
5474 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5477 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5479 if Chars
(Arg
) = No_Name
then
5480 Error_Msg_Name_1
:= Pname
;
5481 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5484 elsif Chars
(Arg
) /= N1
5485 and then Chars
(Arg
) /= N2
5487 Error_Msg_Name_1
:= Pname
;
5488 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5492 end Check_Identifier_Is_One_Of
;
5494 ---------------------------
5495 -- Check_In_Main_Program --
5496 ---------------------------
5498 procedure Check_In_Main_Program
is
5499 P
: constant Node_Id
:= Parent
(N
);
5502 -- Must be in subprogram body
5504 if Nkind
(P
) /= N_Subprogram_Body
then
5505 Error_Pragma
("% pragma allowed only in subprogram");
5507 -- Otherwise warn if obviously not main program
5509 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5510 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5512 Error_Msg_Name_1
:= Pname
;
5514 ("??pragma% is only effective in main program", N
);
5516 end Check_In_Main_Program
;
5518 ---------------------------------------
5519 -- Check_Interrupt_Or_Attach_Handler --
5520 ---------------------------------------
5522 procedure Check_Interrupt_Or_Attach_Handler
is
5523 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5524 Handler_Proc
, Proc_Scope
: Entity_Id
;
5529 if Prag_Id
= Pragma_Interrupt_Handler
then
5530 Check_Restriction
(No_Dynamic_Attachment
, N
);
5533 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5534 Proc_Scope
:= Scope
(Handler_Proc
);
5536 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5538 ("argument of pragma% must be protected procedure", Arg1
);
5541 -- For pragma case (as opposed to access case), check placement.
5542 -- We don't need to do that for aspects, because we have the
5543 -- check that they aspect applies an appropriate procedure.
5545 if not From_Aspect_Specification
(N
)
5546 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5548 Error_Pragma
("pragma% must be in protected definition");
5551 if not Is_Library_Level_Entity
(Proc_Scope
) then
5553 ("argument for pragma% must be library level entity", Arg1
);
5556 -- AI05-0033: A pragma cannot appear within a generic body, because
5557 -- instance can be in a nested scope. The check that protected type
5558 -- is itself a library-level declaration is done elsewhere.
5560 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5561 -- handle code prior to AI-0033. Analysis tools typically are not
5562 -- interested in this pragma in any case, so no need to worry too
5563 -- much about its placement.
5565 if Inside_A_Generic
then
5566 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5567 and then In_Package_Body
(Scope
(Current_Scope
))
5568 and then not Relaxed_RM_Semantics
5570 Error_Pragma
("pragma% cannot be used inside a generic");
5573 end Check_Interrupt_Or_Attach_Handler
;
5575 ---------------------------------
5576 -- Check_Loop_Pragma_Placement --
5577 ---------------------------------
5579 procedure Check_Loop_Pragma_Placement
is
5580 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5581 -- Verify whether the current pragma is properly grouped with other
5582 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5583 -- related loop where the pragma appears.
5585 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5586 -- Determine whether an arbitrary statement Stmt denotes pragma
5587 -- Loop_Invariant or Loop_Variant.
5589 procedure Placement_Error
(Constr
: Node_Id
);
5590 pragma No_Return
(Placement_Error
);
5591 -- Node Constr denotes the last loop restricted construct before we
5592 -- encountered an illegal relation between enclosing constructs. Emit
5593 -- an error depending on what Constr was.
5595 --------------------------------
5596 -- Check_Loop_Pragma_Grouping --
5597 --------------------------------
5599 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5600 Stop_Search
: exception;
5601 -- This exception is used to terminate the recursive descent of
5602 -- routine Check_Grouping.
5604 procedure Check_Grouping
(L
: List_Id
);
5605 -- Find the first group of pragmas in list L and if successful,
5606 -- ensure that the current pragma is part of that group. The
5607 -- routine raises Stop_Search once such a check is performed to
5608 -- halt the recursive descent.
5610 procedure Grouping_Error
(Prag
: Node_Id
);
5611 pragma No_Return
(Grouping_Error
);
5612 -- Emit an error concerning the current pragma indicating that it
5613 -- should be placed after pragma Prag.
5615 --------------------
5616 -- Check_Grouping --
5617 --------------------
5619 procedure Check_Grouping
(L
: List_Id
) is
5625 -- Inspect the list of declarations or statements looking for
5626 -- the first grouping of pragmas:
5629 -- pragma Loop_Invariant ...;
5630 -- pragma Loop_Variant ...;
5632 -- pragma Loop_Variant ...; -- current pragma
5634 -- If the current pragma is not in the grouping, then it must
5635 -- either appear in a different declarative or statement list
5636 -- or the construct at (1) is separating the pragma from the
5640 while Present
(Stmt
) loop
5642 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5643 -- inside a loop or a block housed inside a loop. Inspect
5644 -- the declarations and statements of the block as they may
5645 -- contain the first grouping.
5647 if Nkind
(Stmt
) = N_Block_Statement
then
5648 HSS
:= Handled_Statement_Sequence
(Stmt
);
5650 Check_Grouping
(Declarations
(Stmt
));
5652 if Present
(HSS
) then
5653 Check_Grouping
(Statements
(HSS
));
5656 -- First pragma of the first topmost grouping has been found
5658 elsif Is_Loop_Pragma
(Stmt
) then
5660 -- The group and the current pragma are not in the same
5661 -- declarative or statement list.
5663 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5664 Grouping_Error
(Stmt
);
5666 -- Try to reach the current pragma from the first pragma
5667 -- of the grouping while skipping other members:
5669 -- pragma Loop_Invariant ...; -- first pragma
5670 -- pragma Loop_Variant ...; -- member
5672 -- pragma Loop_Variant ...; -- current pragma
5675 while Present
(Stmt
) loop
5677 -- The current pragma is either the first pragma
5678 -- of the group or is a member of the group. Stop
5679 -- the search as the placement is legal.
5684 -- Skip group members, but keep track of the last
5685 -- pragma in the group.
5687 elsif Is_Loop_Pragma
(Stmt
) then
5690 -- Skip declarations and statements generated by
5691 -- the compiler during expansion.
5693 elsif not Comes_From_Source
(Stmt
) then
5696 -- A non-pragma is separating the group from the
5697 -- current pragma, the placement is illegal.
5700 Grouping_Error
(Prag
);
5706 -- If the traversal did not reach the current pragma,
5707 -- then the list must be malformed.
5709 raise Program_Error
;
5717 --------------------
5718 -- Grouping_Error --
5719 --------------------
5721 procedure Grouping_Error
(Prag
: Node_Id
) is
5723 Error_Msg_Sloc
:= Sloc
(Prag
);
5724 Error_Pragma
("pragma% must appear next to pragma#");
5727 -- Start of processing for Check_Loop_Pragma_Grouping
5730 -- Inspect the statements of the loop or nested blocks housed
5731 -- within to determine whether the current pragma is part of the
5732 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5734 Check_Grouping
(Statements
(Loop_Stmt
));
5737 when Stop_Search
=> null;
5738 end Check_Loop_Pragma_Grouping
;
5740 --------------------
5741 -- Is_Loop_Pragma --
5742 --------------------
5744 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5746 -- Inspect the original node as Loop_Invariant and Loop_Variant
5747 -- pragmas are rewritten to null when assertions are disabled.
5749 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5751 Nam_In
(Pragma_Name
(Original_Node
(Stmt
)),
5752 Name_Loop_Invariant
,
5759 ---------------------
5760 -- Placement_Error --
5761 ---------------------
5763 procedure Placement_Error
(Constr
: Node_Id
) is
5764 LA
: constant String := " with Loop_Entry";
5767 if Prag_Id
= Pragma_Assert
then
5768 Error_Msg_String
(1 .. LA
'Length) := LA
;
5769 Error_Msg_Strlen
:= LA
'Length;
5771 Error_Msg_Strlen
:= 0;
5774 if Nkind
(Constr
) = N_Pragma
then
5776 ("pragma %~ must appear immediately within the statements "
5780 ("block containing pragma %~ must appear immediately within "
5781 & "the statements of a loop", Constr
);
5783 end Placement_Error
;
5785 -- Local declarations
5790 -- Start of processing for Check_Loop_Pragma_Placement
5793 -- Check that pragma appears immediately within a loop statement,
5794 -- ignoring intervening block statements.
5798 while Present
(Stmt
) loop
5800 -- The pragma or previous block must appear immediately within the
5801 -- current block's declarative or statement part.
5803 if Nkind
(Stmt
) = N_Block_Statement
then
5804 if (No
(Declarations
(Stmt
))
5805 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
5807 List_Containing
(Prev
) /=
5808 Statements
(Handled_Statement_Sequence
(Stmt
))
5810 Placement_Error
(Prev
);
5813 -- Keep inspecting the parents because we are now within a
5814 -- chain of nested blocks.
5818 Stmt
:= Parent
(Stmt
);
5821 -- The pragma or previous block must appear immediately within the
5822 -- statements of the loop.
5824 elsif Nkind
(Stmt
) = N_Loop_Statement
then
5825 if List_Containing
(Prev
) /= Statements
(Stmt
) then
5826 Placement_Error
(Prev
);
5829 -- Stop the traversal because we reached the innermost loop
5830 -- regardless of whether we encountered an error or not.
5834 -- Ignore a handled statement sequence. Note that this node may
5835 -- be related to a subprogram body in which case we will emit an
5836 -- error on the next iteration of the search.
5838 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
5839 Stmt
:= Parent
(Stmt
);
5841 -- Any other statement breaks the chain from the pragma to the
5845 Placement_Error
(Prev
);
5850 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5851 -- grouped together with other such pragmas.
5853 if Is_Loop_Pragma
(N
) then
5855 -- The previous check should have located the related loop
5857 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
5858 Check_Loop_Pragma_Grouping
(Stmt
);
5860 end Check_Loop_Pragma_Placement
;
5862 -------------------------------------------
5863 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5864 -------------------------------------------
5866 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
5875 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
5878 elsif Nkind_In
(P
, N_Package_Specification
,
5883 -- Note: the following tests seem a little peculiar, because
5884 -- they test for bodies, but if we were in the statement part
5885 -- of the body, we would already have hit the handled statement
5886 -- sequence, so the only way we get here is by being in the
5887 -- declarative part of the body.
5889 elsif Nkind_In
(P
, N_Subprogram_Body
,
5900 Error_Pragma
("pragma% is not in declarative part or package spec");
5901 end Check_Is_In_Decl_Part_Or_Package_Spec
;
5903 -------------------------
5904 -- Check_No_Identifier --
5905 -------------------------
5907 procedure Check_No_Identifier
(Arg
: Node_Id
) is
5909 if Nkind
(Arg
) = N_Pragma_Argument_Association
5910 and then Chars
(Arg
) /= No_Name
5912 Error_Pragma_Arg_Ident
5913 ("pragma% does not permit identifier& here", Arg
);
5915 end Check_No_Identifier
;
5917 --------------------------
5918 -- Check_No_Identifiers --
5919 --------------------------
5921 procedure Check_No_Identifiers
is
5925 for J
in 1 .. Arg_Count
loop
5926 Check_No_Identifier
(Arg_Node
);
5929 end Check_No_Identifiers
;
5931 ------------------------
5932 -- Check_No_Link_Name --
5933 ------------------------
5935 procedure Check_No_Link_Name
is
5937 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
5941 if Present
(Arg4
) then
5943 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
5945 end Check_No_Link_Name
;
5947 -------------------------------
5948 -- Check_Optional_Identifier --
5949 -------------------------------
5951 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5954 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5955 and then Chars
(Arg
) /= No_Name
5957 if Chars
(Arg
) /= Id
then
5958 Error_Msg_Name_1
:= Pname
;
5959 Error_Msg_Name_2
:= Id
;
5960 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5964 end Check_Optional_Identifier
;
5966 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
5968 Name_Buffer
(1 .. Id
'Length) := Id
;
5969 Name_Len
:= Id
'Length;
5970 Check_Optional_Identifier
(Arg
, Name_Find
);
5971 end Check_Optional_Identifier
;
5973 -------------------------------------
5974 -- Check_Static_Boolean_Expression --
5975 -------------------------------------
5977 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
5979 if Present
(Expr
) then
5980 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
5982 if not Is_OK_Static_Expression
(Expr
) then
5984 ("expression of pragma % must be static", Expr
);
5987 end Check_Static_Boolean_Expression
;
5989 -----------------------------
5990 -- Check_Static_Constraint --
5991 -----------------------------
5993 -- Note: for convenience in writing this procedure, in addition to
5994 -- the officially (i.e. by spec) allowed argument which is always a
5995 -- constraint, it also allows ranges and discriminant associations.
5996 -- Above is not clear ???
5998 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6000 procedure Require_Static
(E
: Node_Id
);
6001 -- Require given expression to be static expression
6003 --------------------
6004 -- Require_Static --
6005 --------------------
6007 procedure Require_Static
(E
: Node_Id
) is
6009 if not Is_OK_Static_Expression
(E
) then
6010 Flag_Non_Static_Expr
6011 ("non-static constraint not allowed in Unchecked_Union!", E
);
6016 -- Start of processing for Check_Static_Constraint
6019 case Nkind
(Constr
) is
6020 when N_Discriminant_Association
=>
6021 Require_Static
(Expression
(Constr
));
6024 Require_Static
(Low_Bound
(Constr
));
6025 Require_Static
(High_Bound
(Constr
));
6027 when N_Attribute_Reference
=>
6028 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6029 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6031 when N_Range_Constraint
=>
6032 Check_Static_Constraint
(Range_Expression
(Constr
));
6034 when N_Index_Or_Discriminant_Constraint
=>
6038 IDC
:= First
(Constraints
(Constr
));
6039 while Present
(IDC
) loop
6040 Check_Static_Constraint
(IDC
);
6048 end Check_Static_Constraint
;
6050 --------------------------------------
6051 -- Check_Valid_Configuration_Pragma --
6052 --------------------------------------
6054 -- A configuration pragma must appear in the context clause of a
6055 -- compilation unit, and only other pragmas may precede it. Note that
6056 -- the test also allows use in a configuration pragma file.
6058 procedure Check_Valid_Configuration_Pragma
is
6060 if not Is_Configuration_Pragma
then
6061 Error_Pragma
("incorrect placement for configuration pragma%");
6063 end Check_Valid_Configuration_Pragma
;
6065 -------------------------------------
6066 -- Check_Valid_Library_Unit_Pragma --
6067 -------------------------------------
6069 procedure Check_Valid_Library_Unit_Pragma
is
6071 Parent_Node
: Node_Id
;
6072 Unit_Name
: Entity_Id
;
6073 Unit_Kind
: Node_Kind
;
6074 Unit_Node
: Node_Id
;
6075 Sindex
: Source_File_Index
;
6078 if not Is_List_Member
(N
) then
6082 Plist
:= List_Containing
(N
);
6083 Parent_Node
:= Parent
(Plist
);
6085 if Parent_Node
= Empty
then
6088 -- Case of pragma appearing after a compilation unit. In this case
6089 -- it must have an argument with the corresponding name and must
6090 -- be part of the following pragmas of its parent.
6092 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6093 if Plist
/= Pragmas_After
(Parent_Node
) then
6096 elsif Arg_Count
= 0 then
6098 ("argument required if outside compilation unit");
6101 Check_No_Identifiers
;
6102 Check_Arg_Count
(1);
6103 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6104 Unit_Kind
:= Nkind
(Unit_Node
);
6106 Analyze
(Get_Pragma_Arg
(Arg1
));
6108 if Unit_Kind
= N_Generic_Subprogram_Declaration
6109 or else Unit_Kind
= N_Subprogram_Declaration
6111 Unit_Name
:= Defining_Entity
(Unit_Node
);
6113 elsif Unit_Kind
in N_Generic_Instantiation
then
6114 Unit_Name
:= Defining_Entity
(Unit_Node
);
6117 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6120 if Chars
(Unit_Name
) /=
6121 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6124 ("pragma% argument is not current unit name", Arg1
);
6127 if Ekind
(Unit_Name
) = E_Package
6128 and then Present
(Renamed_Entity
(Unit_Name
))
6130 Error_Pragma
("pragma% not allowed for renamed package");
6134 -- Pragma appears other than after a compilation unit
6137 -- Here we check for the generic instantiation case and also
6138 -- for the case of processing a generic formal package. We
6139 -- detect these cases by noting that the Sloc on the node
6140 -- does not belong to the current compilation unit.
6142 Sindex
:= Source_Index
(Current_Sem_Unit
);
6144 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6145 Rewrite
(N
, Make_Null_Statement
(Loc
));
6148 -- If before first declaration, the pragma applies to the
6149 -- enclosing unit, and the name if present must be this name.
6151 elsif Is_Before_First_Decl
(N
, Plist
) then
6152 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6153 Unit_Kind
:= Nkind
(Unit_Node
);
6155 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6158 elsif Unit_Kind
= N_Subprogram_Body
6159 and then not Acts_As_Spec
(Unit_Node
)
6163 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6166 elsif Nkind
(Parent_Node
) = N_Package_Specification
6167 and then Plist
= Private_Declarations
(Parent_Node
)
6171 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6172 or else Nkind
(Parent_Node
) =
6173 N_Generic_Subprogram_Declaration
)
6174 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6178 elsif Arg_Count
> 0 then
6179 Analyze
(Get_Pragma_Arg
(Arg1
));
6181 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6183 ("name in pragma% must be enclosing unit", Arg1
);
6186 -- It is legal to have no argument in this context
6192 -- Error if not before first declaration. This is because a
6193 -- library unit pragma argument must be the name of a library
6194 -- unit (RM 10.1.5(7)), but the only names permitted in this
6195 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6196 -- generic subprogram declarations or generic instantiations.
6200 ("pragma% misplaced, must be before first declaration");
6204 end Check_Valid_Library_Unit_Pragma
;
6210 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6211 Clist
: constant Node_Id
:= Component_List
(Variant
);
6215 Comp
:= First
(Component_Items
(Clist
));
6216 while Present
(Comp
) loop
6217 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6222 ---------------------------
6223 -- Ensure_Aggregate_Form --
6224 ---------------------------
6226 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6227 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6228 Expr
: constant Node_Id
:= Expression
(Arg
);
6229 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6230 Comps
: List_Id
:= No_List
;
6231 Exprs
: List_Id
:= No_List
;
6232 Nam
: Name_Id
:= No_Name
;
6233 Nam_Loc
: Source_Ptr
;
6236 -- The pragma argument is in positional form:
6238 -- pragma Depends (Nam => ...)
6242 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6243 -- argument association.
6245 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6247 Nam_Loc
:= Sloc
(Arg
);
6249 -- Remove the pragma argument name as this will be captured in the
6252 Set_Chars
(Arg
, No_Name
);
6255 -- The argument is already in aggregate form, but the presence of a
6256 -- name causes this to be interpreted as named association which in
6257 -- turn must be converted into an aggregate.
6259 -- pragma Global (In_Out => (A, B, C))
6263 -- pragma Global ((In_Out => (A, B, C)))
6265 -- aggregate aggregate
6267 if Nkind
(Expr
) = N_Aggregate
then
6268 if Nam
= No_Name
then
6272 -- Do not transform a null argument into an aggregate as N_Null has
6273 -- special meaning in formal verification pragmas.
6275 elsif Nkind
(Expr
) = N_Null
then
6279 -- Everything comes from source if the original comes from source
6281 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6283 -- Positional argument is transformed into an aggregate with an
6284 -- Expressions list.
6286 if Nam
= No_Name
then
6287 Exprs
:= New_List
(Relocate_Node
(Expr
));
6289 -- An associative argument is transformed into an aggregate with
6290 -- Component_Associations.
6294 Make_Component_Association
(Loc
,
6295 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6296 Expression
=> Relocate_Node
(Expr
)));
6299 Set_Expression
(Arg
,
6300 Make_Aggregate
(Loc
,
6301 Component_Associations
=> Comps
,
6302 Expressions
=> Exprs
));
6304 -- Restore Comes_From_Source default
6306 Set_Comes_From_Source_Default
(CFSD
);
6307 end Ensure_Aggregate_Form
;
6313 procedure Error_Pragma
(Msg
: String) is
6315 Error_Msg_Name_1
:= Pname
;
6316 Error_Msg_N
(Fix_Error
(Msg
), N
);
6320 ----------------------
6321 -- Error_Pragma_Arg --
6322 ----------------------
6324 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6326 Error_Msg_Name_1
:= Pname
;
6327 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6329 end Error_Pragma_Arg
;
6331 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6333 Error_Msg_Name_1
:= Pname
;
6334 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6335 Error_Pragma_Arg
(Msg2
, Arg
);
6336 end Error_Pragma_Arg
;
6338 ----------------------------
6339 -- Error_Pragma_Arg_Ident --
6340 ----------------------------
6342 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6344 Error_Msg_Name_1
:= Pname
;
6345 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6347 end Error_Pragma_Arg_Ident
;
6349 ----------------------
6350 -- Error_Pragma_Ref --
6351 ----------------------
6353 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6355 Error_Msg_Name_1
:= Pname
;
6356 Error_Msg_Sloc
:= Sloc
(Ref
);
6357 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6359 end Error_Pragma_Ref
;
6361 ------------------------
6362 -- Find_Lib_Unit_Name --
6363 ------------------------
6365 function Find_Lib_Unit_Name
return Entity_Id
is
6367 -- Return inner compilation unit entity, for case of nested
6368 -- categorization pragmas. This happens in generic unit.
6370 if Nkind
(Parent
(N
)) = N_Package_Specification
6371 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6373 return Defining_Entity
(Parent
(N
));
6375 return Current_Scope
;
6377 end Find_Lib_Unit_Name
;
6379 ----------------------------
6380 -- Find_Program_Unit_Name --
6381 ----------------------------
6383 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6384 Unit_Name
: Entity_Id
;
6385 Unit_Kind
: Node_Kind
;
6386 P
: constant Node_Id
:= Parent
(N
);
6389 if Nkind
(P
) = N_Compilation_Unit
then
6390 Unit_Kind
:= Nkind
(Unit
(P
));
6392 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6393 N_Package_Declaration
)
6394 or else Unit_Kind
in N_Generic_Declaration
6396 Unit_Name
:= Defining_Entity
(Unit
(P
));
6398 if Chars
(Id
) = Chars
(Unit_Name
) then
6399 Set_Entity
(Id
, Unit_Name
);
6400 Set_Etype
(Id
, Etype
(Unit_Name
));
6402 Set_Etype
(Id
, Any_Type
);
6404 ("cannot find program unit referenced by pragma%");
6408 Set_Etype
(Id
, Any_Type
);
6409 Error_Pragma
("pragma% inapplicable to this unit");
6415 end Find_Program_Unit_Name
;
6417 -----------------------------------------
6418 -- Find_Unique_Parameterless_Procedure --
6419 -----------------------------------------
6421 function Find_Unique_Parameterless_Procedure
6423 Arg
: Node_Id
) return Entity_Id
6425 Proc
: Entity_Id
:= Empty
;
6428 -- The body of this procedure needs some comments ???
6430 if not Is_Entity_Name
(Name
) then
6432 ("argument of pragma% must be entity name", Arg
);
6434 elsif not Is_Overloaded
(Name
) then
6435 Proc
:= Entity
(Name
);
6437 if Ekind
(Proc
) /= E_Procedure
6438 or else Present
(First_Formal
(Proc
))
6441 ("argument of pragma% must be parameterless procedure", Arg
);
6446 Found
: Boolean := False;
6448 Index
: Interp_Index
;
6451 Get_First_Interp
(Name
, Index
, It
);
6452 while Present
(It
.Nam
) loop
6455 if Ekind
(Proc
) = E_Procedure
6456 and then No
(First_Formal
(Proc
))
6460 Set_Entity
(Name
, Proc
);
6461 Set_Is_Overloaded
(Name
, False);
6464 ("ambiguous handler name for pragma% ", Arg
);
6468 Get_Next_Interp
(Index
, It
);
6473 ("argument of pragma% must be parameterless procedure",
6476 Proc
:= Entity
(Name
);
6482 end Find_Unique_Parameterless_Procedure
;
6488 function Fix_Error
(Msg
: String) return String is
6489 Res
: String (Msg
'Range) := Msg
;
6490 Res_Last
: Natural := Msg
'Last;
6494 -- If we have a rewriting of another pragma, go to that pragma
6496 if Is_Rewrite_Substitution
(N
)
6497 and then Nkind
(Original_Node
(N
)) = N_Pragma
6499 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6502 -- Case where pragma comes from an aspect specification
6504 if From_Aspect_Specification
(N
) then
6506 -- Change appearence of "pragma" in message to "aspect"
6509 while J
<= Res_Last
- 5 loop
6510 if Res
(J
.. J
+ 5) = "pragma" then
6511 Res
(J
.. J
+ 5) := "aspect";
6519 -- Change "argument of" at start of message to "entity for"
6522 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6524 Res
(Res
'First .. Res
'First + 9) := "entity for";
6525 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6526 Res
(Res
'First + 11 .. Res_Last
);
6527 Res_Last
:= Res_Last
- 1;
6530 -- Change "argument" at start of message to "entity"
6533 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6535 Res
(Res
'First .. Res
'First + 5) := "entity";
6536 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6537 Res
(Res
'First + 8 .. Res_Last
);
6538 Res_Last
:= Res_Last
- 2;
6541 -- Get name from corresponding aspect
6543 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6546 -- Return possibly modified message
6548 return Res
(Res
'First .. Res_Last
);
6551 -------------------------
6552 -- Gather_Associations --
6553 -------------------------
6555 procedure Gather_Associations
6557 Args
: out Args_List
)
6562 -- Initialize all parameters to Empty
6564 for J
in Args
'Range loop
6568 -- That's all we have to do if there are no argument associations
6570 if No
(Pragma_Argument_Associations
(N
)) then
6574 -- Otherwise first deal with any positional parameters present
6576 Arg
:= First
(Pragma_Argument_Associations
(N
));
6577 for Index
in Args
'Range loop
6578 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6579 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6583 -- Positional parameters all processed, if any left, then we
6584 -- have too many positional parameters.
6586 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6588 ("too many positional associations for pragma%", Arg
);
6591 -- Process named parameters if any are present
6593 while Present
(Arg
) loop
6594 if Chars
(Arg
) = No_Name
then
6596 ("positional association cannot follow named association",
6600 for Index
in Names
'Range loop
6601 if Names
(Index
) = Chars
(Arg
) then
6602 if Present
(Args
(Index
)) then
6604 ("duplicate argument association for pragma%", Arg
);
6606 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6611 if Index
= Names
'Last then
6612 Error_Msg_Name_1
:= Pname
;
6613 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6615 -- Check for possible misspelling
6617 for Index1
in Names
'Range loop
6618 if Is_Bad_Spelling_Of
6619 (Chars
(Arg
), Names
(Index1
))
6621 Error_Msg_Name_1
:= Names
(Index1
);
6622 Error_Msg_N
-- CODEFIX
6623 ("\possible misspelling of%", Arg
);
6635 end Gather_Associations
;
6641 procedure GNAT_Pragma
is
6643 -- We need to check the No_Implementation_Pragmas restriction for
6644 -- the case of a pragma from source. Note that the case of aspects
6645 -- generating corresponding pragmas marks these pragmas as not being
6646 -- from source, so this test also catches that case.
6648 if Comes_From_Source
(N
) then
6649 Check_Restriction
(No_Implementation_Pragmas
, N
);
6653 --------------------------
6654 -- Is_Before_First_Decl --
6655 --------------------------
6657 function Is_Before_First_Decl
6658 (Pragma_Node
: Node_Id
;
6659 Decls
: List_Id
) return Boolean
6661 Item
: Node_Id
:= First
(Decls
);
6664 -- Only other pragmas can come before this pragma
6667 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6670 elsif Item
= Pragma_Node
then
6676 end Is_Before_First_Decl
;
6678 -----------------------------
6679 -- Is_Configuration_Pragma --
6680 -----------------------------
6682 -- A configuration pragma must appear in the context clause of a
6683 -- compilation unit, and only other pragmas may precede it. Note that
6684 -- the test below also permits use in a configuration pragma file.
6686 function Is_Configuration_Pragma
return Boolean is
6687 Lis
: constant List_Id
:= List_Containing
(N
);
6688 Par
: constant Node_Id
:= Parent
(N
);
6692 -- If no parent, then we are in the configuration pragma file,
6693 -- so the placement is definitely appropriate.
6698 -- Otherwise we must be in the context clause of a compilation unit
6699 -- and the only thing allowed before us in the context list is more
6700 -- configuration pragmas.
6702 elsif Nkind
(Par
) = N_Compilation_Unit
6703 and then Context_Items
(Par
) = Lis
6710 elsif Nkind
(Prg
) /= N_Pragma
then
6720 end Is_Configuration_Pragma
;
6722 --------------------------
6723 -- Is_In_Context_Clause --
6724 --------------------------
6726 function Is_In_Context_Clause
return Boolean is
6728 Parent_Node
: Node_Id
;
6731 if not Is_List_Member
(N
) then
6735 Plist
:= List_Containing
(N
);
6736 Parent_Node
:= Parent
(Plist
);
6738 if Parent_Node
= Empty
6739 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6740 or else Context_Items
(Parent_Node
) /= Plist
6747 end Is_In_Context_Clause
;
6749 ---------------------------------
6750 -- Is_Static_String_Expression --
6751 ---------------------------------
6753 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6754 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6755 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6758 Analyze_And_Resolve
(Argx
);
6760 -- Special case Ada 83, where the expression will never be static,
6761 -- but we will return true if we had a string literal to start with.
6763 if Ada_Version
= Ada_83
then
6766 -- Normal case, true only if we end up with a string literal that
6767 -- is marked as being the result of evaluating a static expression.
6770 return Is_OK_Static_Expression
(Argx
)
6771 and then Nkind
(Argx
) = N_String_Literal
;
6774 end Is_Static_String_Expression
;
6776 ----------------------
6777 -- Pragma_Misplaced --
6778 ----------------------
6780 procedure Pragma_Misplaced
is
6782 Error_Pragma
("incorrect placement of pragma%");
6783 end Pragma_Misplaced
;
6785 ------------------------------------------------
6786 -- Process_Atomic_Independent_Shared_Volatile --
6787 ------------------------------------------------
6789 procedure Process_Atomic_Independent_Shared_Volatile
is
6790 procedure Set_Atomic_VFA
(E
: Entity_Id
);
6791 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6792 -- no explicit alignment was given, set alignment to unknown, since
6793 -- back end knows what the alignment requirements are for atomic and
6794 -- full access arrays. Note: this is necessary for derived types.
6796 --------------------
6797 -- Set_Atomic_VFA --
6798 --------------------
6800 procedure Set_Atomic_VFA
(E
: Entity_Id
) is
6802 if Prag_Id
= Pragma_Volatile_Full_Access
then
6803 Set_Is_Volatile_Full_Access
(E
);
6808 if not Has_Alignment_Clause
(E
) then
6809 Set_Alignment
(E
, Uint_0
);
6819 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6822 Check_Ada_83_Warning
;
6823 Check_No_Identifiers
;
6824 Check_Arg_Count
(1);
6825 Check_Arg_Is_Local_Name
(Arg1
);
6826 E_Arg
:= Get_Pragma_Arg
(Arg1
);
6828 if Etype
(E_Arg
) = Any_Type
then
6832 E
:= Entity
(E_Arg
);
6833 Decl
:= Declaration_Node
(E
);
6835 -- A pragma that applies to a Ghost entity becomes Ghost for the
6836 -- purposes of legality checks and removal of ignored Ghost code.
6838 Mark_Pragma_As_Ghost
(N
, E
);
6840 -- Check duplicate before we chain ourselves
6842 Check_Duplicate_Pragma
(E
);
6844 -- Check Atomic and VFA used together
6846 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
6847 or else (Is_Volatile_Full_Access
(E
)
6848 and then (Prag_Id
= Pragma_Atomic
6850 Prag_Id
= Pragma_Shared
))
6853 ("cannot have Volatile_Full_Access and Atomic for same entity");
6856 -- Check for applying VFA to an entity which has aliased component
6858 if Prag_Id
= Pragma_Volatile_Full_Access
then
6861 Aliased_Comp
: Boolean := False;
6862 -- Set True if aliased component present
6865 if Is_Array_Type
(Etype
(E
)) then
6866 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
6868 -- Record case, too bad Has_Aliased_Components is not also
6869 -- set for records, should it be ???
6871 elsif Is_Record_Type
(Etype
(E
)) then
6872 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
6873 while Present
(Comp
) loop
6874 if Is_Aliased
(Comp
)
6875 or else Is_Aliased
(Etype
(Comp
))
6877 Aliased_Comp
:= True;
6881 Next_Component_Or_Discriminant
(Comp
);
6885 if Aliased_Comp
then
6887 ("cannot apply Volatile_Full_Access (aliased component "
6893 -- Now check appropriateness of the entity
6896 if Rep_Item_Too_Early
(E
, N
)
6898 Rep_Item_Too_Late
(E
, N
)
6902 Check_First_Subtype
(Arg1
);
6905 -- Attribute belongs on the base type. If the view of the type is
6906 -- currently private, it also belongs on the underlying type.
6908 if Prag_Id
= Pragma_Atomic
6910 Prag_Id
= Pragma_Shared
6912 Prag_Id
= Pragma_Volatile_Full_Access
6915 Set_Atomic_VFA
(Base_Type
(E
));
6916 Set_Atomic_VFA
(Underlying_Type
(E
));
6919 -- Atomic/Shared/Volatile_Full_Access imply Independent
6921 if Prag_Id
/= Pragma_Volatile
then
6922 Set_Is_Independent
(E
);
6923 Set_Is_Independent
(Base_Type
(E
));
6924 Set_Is_Independent
(Underlying_Type
(E
));
6926 if Prag_Id
= Pragma_Independent
then
6927 Record_Independence_Check
(N
, Base_Type
(E
));
6931 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6933 if Prag_Id
/= Pragma_Independent
then
6934 Set_Is_Volatile
(E
);
6935 Set_Is_Volatile
(Base_Type
(E
));
6936 Set_Is_Volatile
(Underlying_Type
(E
));
6938 Set_Treat_As_Volatile
(E
);
6939 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6942 elsif Nkind
(Decl
) = N_Object_Declaration
6943 or else (Nkind
(Decl
) = N_Component_Declaration
6944 and then Original_Record_Component
(E
) = E
)
6946 if Rep_Item_Too_Late
(E
, N
) then
6950 if Prag_Id
= Pragma_Atomic
6952 Prag_Id
= Pragma_Shared
6954 Prag_Id
= Pragma_Volatile_Full_Access
6956 if Prag_Id
= Pragma_Volatile_Full_Access
then
6957 Set_Is_Volatile_Full_Access
(E
);
6962 -- If the object declaration has an explicit initialization, a
6963 -- temporary may have to be created to hold the expression, to
6964 -- ensure that access to the object remain atomic.
6966 if Nkind
(Parent
(E
)) = N_Object_Declaration
6967 and then Present
(Expression
(Parent
(E
)))
6969 Set_Has_Delayed_Freeze
(E
);
6973 -- Atomic/Shared/Volatile_Full_Access imply Independent
6975 if Prag_Id
/= Pragma_Volatile
then
6976 Set_Is_Independent
(E
);
6978 if Prag_Id
= Pragma_Independent
then
6979 Record_Independence_Check
(N
, E
);
6983 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6985 if Prag_Id
/= Pragma_Independent
then
6986 Set_Is_Volatile
(E
);
6987 Set_Treat_As_Volatile
(E
);
6991 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6994 -- The following check is only relevant when SPARK_Mode is on as
6995 -- this is not a standard Ada legality rule. Pragma Volatile can
6996 -- only apply to a full type declaration or an object declaration
6997 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6998 -- untagged derived types that are rewritten as subtypes of their
6999 -- respective root types.
7002 and then Prag_Id
= Pragma_Volatile
7004 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
7005 N_Object_Declaration
)
7008 ("argument of pragma % must denote a full type or object "
7009 & "declaration", Arg1
);
7011 end Process_Atomic_Independent_Shared_Volatile
;
7013 -------------------------------------------
7014 -- Process_Compile_Time_Warning_Or_Error --
7015 -------------------------------------------
7017 procedure Process_Compile_Time_Warning_Or_Error
is
7018 Validation_Needed
: Boolean := False;
7020 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7021 -- Tree visitor that checks if N is an attribute reference that can
7022 -- be statically computed by the back end. Validation_Needed is set
7023 -- to True if found.
7029 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7031 if Nkind
(N
) = N_Attribute_Reference
7032 and then Is_Entity_Name
(Prefix
(N
))
7035 Attr_Id
: constant Attribute_Id
:=
7036 Get_Attribute_Id
(Attribute_Name
(N
));
7038 if Attr_Id
= Attribute_Alignment
7039 or else Attr_Id
= Attribute_Size
7041 Validation_Needed
:= True;
7049 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7053 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7055 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7058 Check_Arg_Count
(2);
7059 Check_No_Identifiers
;
7060 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7061 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7063 if Compile_Time_Known_Value
(Arg1x
) then
7064 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7066 -- Register the expression for its validation after the back end has
7067 -- been called if it has occurrences of attributes Size or Alignment
7068 -- (because they may be statically computed by the back end and hence
7069 -- the whole expression needs to be reevaluated).
7072 Check_Expression
(Arg1x
);
7074 if Validation_Needed
then
7075 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7078 end Process_Compile_Time_Warning_Or_Error
;
7080 ------------------------
7081 -- Process_Convention --
7082 ------------------------
7084 procedure Process_Convention
7085 (C
: out Convention_Id
;
7086 Ent
: out Entity_Id
)
7090 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7091 -- Called if we have more than one Export/Import/Convention pragma.
7092 -- This is generally illegal, but we have a special case of allowing
7093 -- Import and Interface to coexist if they specify the convention in
7094 -- a consistent manner. We are allowed to do this, since Interface is
7095 -- an implementation defined pragma, and we choose to do it since we
7096 -- know Rational allows this combination. S is the entity id of the
7097 -- subprogram in question. This procedure also sets the special flag
7098 -- Import_Interface_Present in both pragmas in the case where we do
7099 -- have matching Import and Interface pragmas.
7101 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7102 -- Set convention in entity E, and also flag that the entity has a
7103 -- convention pragma. If entity is for a private or incomplete type,
7104 -- also set convention and flag on underlying type. This procedure
7105 -- also deals with the special case of C_Pass_By_Copy convention,
7106 -- and error checks for inappropriate convention specification.
7108 -------------------------------
7109 -- Diagnose_Multiple_Pragmas --
7110 -------------------------------
7112 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7113 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7117 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7118 -- Decl is a pragma node. This function returns True if this
7119 -- pragma has a first argument that is an identifier with a
7120 -- Chars field corresponding to the Convention_Id C.
7122 function Same_Name
(Decl
: Node_Id
) return Boolean;
7123 -- Decl is a pragma node. This function returns True if this
7124 -- pragma has a second argument that is an identifier with a
7125 -- Chars field that matches the Chars of the current subprogram.
7127 ---------------------
7128 -- Same_Convention --
7129 ---------------------
7131 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7132 Arg1
: constant Node_Id
:=
7133 First
(Pragma_Argument_Associations
(Decl
));
7136 if Present
(Arg1
) then
7138 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7140 if Nkind
(Arg
) = N_Identifier
7141 and then Is_Convention_Name
(Chars
(Arg
))
7142 and then Get_Convention_Id
(Chars
(Arg
)) = C
7150 end Same_Convention
;
7156 function Same_Name
(Decl
: Node_Id
) return Boolean is
7157 Arg1
: constant Node_Id
:=
7158 First
(Pragma_Argument_Associations
(Decl
));
7166 Arg2
:= Next
(Arg1
);
7173 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7175 if Nkind
(Arg
) = N_Identifier
7176 and then Chars
(Arg
) = Chars
(S
)
7185 -- Start of processing for Diagnose_Multiple_Pragmas
7190 -- Definitely give message if we have Convention/Export here
7192 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7195 -- If we have an Import or Export, scan back from pragma to
7196 -- find any previous pragma applying to the same procedure.
7197 -- The scan will be terminated by the start of the list, or
7198 -- hitting the subprogram declaration. This won't allow one
7199 -- pragma to appear in the public part and one in the private
7200 -- part, but that seems very unlikely in practice.
7204 while Present
(Decl
) and then Decl
/= Pdec
loop
7206 -- Look for pragma with same name as us
7208 if Nkind
(Decl
) = N_Pragma
7209 and then Same_Name
(Decl
)
7211 -- Give error if same as our pragma or Export/Convention
7213 if Nam_In
(Pragma_Name
(Decl
), Name_Export
,
7219 -- Case of Import/Interface or the other way round
7221 elsif Nam_In
(Pragma_Name
(Decl
), Name_Interface
,
7224 -- Here we know that we have Import and Interface. It
7225 -- doesn't matter which way round they are. See if
7226 -- they specify the same convention. If so, all OK,
7227 -- and set special flags to stop other messages
7229 if Same_Convention
(Decl
) then
7230 Set_Import_Interface_Present
(N
);
7231 Set_Import_Interface_Present
(Decl
);
7234 -- If different conventions, special message
7237 Error_Msg_Sloc
:= Sloc
(Decl
);
7239 ("convention differs from that given#", Arg1
);
7249 -- Give message if needed if we fall through those tests
7250 -- except on Relaxed_RM_Semantics where we let go: either this
7251 -- is a case accepted/ignored by other Ada compilers (e.g.
7252 -- a mix of Convention and Import), or another error will be
7253 -- generated later (e.g. using both Import and Export).
7255 if Err
and not Relaxed_RM_Semantics
then
7257 ("at most one Convention/Export/Import pragma is allowed",
7260 end Diagnose_Multiple_Pragmas
;
7262 --------------------------------
7263 -- Set_Convention_From_Pragma --
7264 --------------------------------
7266 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7268 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7269 -- for an overridden dispatching operation. Technically this is
7270 -- an amendment and should only be done in Ada 2005 mode. However,
7271 -- this is clearly a mistake, since the problem that is addressed
7272 -- by this AI is that there is a clear gap in the RM.
7274 if Is_Dispatching_Operation
(E
)
7275 and then Present
(Overridden_Operation
(E
))
7276 and then C
/= Convention
(Overridden_Operation
(E
))
7279 ("cannot change convention for overridden dispatching "
7280 & "operation", Arg1
);
7283 -- Special checks for Convention_Stdcall
7285 if C
= Convention_Stdcall
then
7287 -- A dispatching call is not allowed. A dispatching subprogram
7288 -- cannot be used to interface to the Win32 API, so in fact
7289 -- this check does not impose any effective restriction.
7291 if Is_Dispatching_Operation
(E
) then
7292 Error_Msg_Sloc
:= Sloc
(E
);
7294 -- Note: make this unconditional so that if there is more
7295 -- than one call to which the pragma applies, we get a
7296 -- message for each call. Also don't use Error_Pragma,
7297 -- so that we get multiple messages.
7300 ("dispatching subprogram# cannot use Stdcall convention!",
7303 -- Subprograms are not allowed
7305 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
7309 and then Ekind
(E
) /= E_Variable
7311 -- An access to subprogram is also allowed
7315 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7317 -- Allow internal call to set convention of subprogram type
7319 and then not (Ekind
(E
) = E_Subprogram_Type
)
7322 ("second argument of pragma% must be subprogram (type)",
7327 -- Set the convention
7329 Set_Convention
(E
, C
);
7330 Set_Has_Convention_Pragma
(E
);
7332 -- For the case of a record base type, also set the convention of
7333 -- any anonymous access types declared in the record which do not
7334 -- currently have a specified convention.
7336 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7341 Comp
:= First_Component
(E
);
7342 while Present
(Comp
) loop
7343 if Present
(Etype
(Comp
))
7344 and then Ekind_In
(Etype
(Comp
),
7345 E_Anonymous_Access_Type
,
7346 E_Anonymous_Access_Subprogram_Type
)
7347 and then not Has_Convention_Pragma
(Comp
)
7349 Set_Convention
(Comp
, C
);
7352 Next_Component
(Comp
);
7357 -- Deal with incomplete/private type case, where underlying type
7358 -- is available, so set convention of that underlying type.
7360 if Is_Incomplete_Or_Private_Type
(E
)
7361 and then Present
(Underlying_Type
(E
))
7363 Set_Convention
(Underlying_Type
(E
), C
);
7364 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7367 -- A class-wide type should inherit the convention of the specific
7368 -- root type (although this isn't specified clearly by the RM).
7370 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7371 Set_Convention
(Class_Wide_Type
(E
), C
);
7374 -- If the entity is a record type, then check for special case of
7375 -- C_Pass_By_Copy, which is treated the same as C except that the
7376 -- special record flag is set. This convention is only permitted
7377 -- on record types (see AI95-00131).
7379 if Cname
= Name_C_Pass_By_Copy
then
7380 if Is_Record_Type
(E
) then
7381 Set_C_Pass_By_Copy
(Base_Type
(E
));
7382 elsif Is_Incomplete_Or_Private_Type
(E
)
7383 and then Is_Record_Type
(Underlying_Type
(E
))
7385 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7388 ("C_Pass_By_Copy convention allowed only for record type",
7393 -- If the entity is a derived boolean type, check for the special
7394 -- case of convention C, C++, or Fortran, where we consider any
7395 -- nonzero value to represent true.
7397 if Is_Discrete_Type
(E
)
7398 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7404 C
= Convention_Fortran
)
7406 Set_Nonzero_Is_True
(Base_Type
(E
));
7408 end Set_Convention_From_Pragma
;
7412 Comp_Unit
: Unit_Number_Type
;
7417 -- Start of processing for Process_Convention
7420 Check_At_Least_N_Arguments
(2);
7421 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7422 Check_Arg_Is_Identifier
(Arg1
);
7423 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7425 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7426 -- tested again below to set the critical flag).
7428 if Cname
= Name_C_Pass_By_Copy
then
7431 -- Otherwise we must have something in the standard convention list
7433 elsif Is_Convention_Name
(Cname
) then
7434 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7436 -- Otherwise warn on unrecognized convention
7439 if Warn_On_Export_Import
then
7441 ("??unrecognized convention name, C assumed",
7442 Get_Pragma_Arg
(Arg1
));
7448 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7449 Check_Arg_Is_Local_Name
(Arg2
);
7451 Id
:= Get_Pragma_Arg
(Arg2
);
7454 if not Is_Entity_Name
(Id
) then
7455 Error_Pragma_Arg
("entity name required", Arg2
);
7460 -- Set entity to return
7464 -- Ada_Pass_By_Copy special checking
7466 if C
= Convention_Ada_Pass_By_Copy
then
7467 if not Is_First_Subtype
(E
) then
7469 ("convention `Ada_Pass_By_Copy` only allowed for types",
7473 if Is_By_Reference_Type
(E
) then
7475 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7479 -- Ada_Pass_By_Reference special checking
7481 elsif C
= Convention_Ada_Pass_By_Reference
then
7482 if not Is_First_Subtype
(E
) then
7484 ("convention `Ada_Pass_By_Reference` only allowed for types",
7488 if Is_By_Copy_Type
(E
) then
7490 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7495 -- Go to renamed subprogram if present, since convention applies to
7496 -- the actual renamed entity, not to the renaming entity. If the
7497 -- subprogram is inherited, go to parent subprogram.
7499 if Is_Subprogram
(E
)
7500 and then Present
(Alias
(E
))
7502 if Nkind
(Parent
(Declaration_Node
(E
))) =
7503 N_Subprogram_Renaming_Declaration
7505 if Scope
(E
) /= Scope
(Alias
(E
)) then
7507 ("cannot apply pragma% to non-local entity&#", E
);
7512 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7513 N_Private_Extension_Declaration
)
7514 and then Scope
(E
) = Scope
(Alias
(E
))
7518 -- Return the parent subprogram the entity was inherited from
7524 -- Check that we are not applying this to a specless body. Relax this
7525 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7527 if Is_Subprogram
(E
)
7528 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7529 and then not Relaxed_RM_Semantics
7532 ("pragma% requires separate spec and must come before body");
7535 -- Check that we are not applying this to a named constant
7537 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7538 Error_Msg_Name_1
:= Pname
;
7540 ("cannot apply pragma% to named constant!",
7541 Get_Pragma_Arg
(Arg2
));
7543 ("\supply appropriate type for&!", Arg2
);
7546 if Ekind
(E
) = E_Enumeration_Literal
then
7547 Error_Pragma
("enumeration literal not allowed for pragma%");
7550 -- Check for rep item appearing too early or too late
7552 if Etype
(E
) = Any_Type
7553 or else Rep_Item_Too_Early
(E
, N
)
7557 elsif Present
(Underlying_Type
(E
)) then
7558 E
:= Underlying_Type
(E
);
7561 if Rep_Item_Too_Late
(E
, N
) then
7565 if Has_Convention_Pragma
(E
) then
7566 Diagnose_Multiple_Pragmas
(E
);
7568 elsif Convention
(E
) = Convention_Protected
7569 or else Ekind
(Scope
(E
)) = E_Protected_Type
7572 ("a protected operation cannot be given a different convention",
7576 -- For Intrinsic, a subprogram is required
7578 if C
= Convention_Intrinsic
7579 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7581 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7583 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7585 ("second argument of pragma% must be a subprogram", Arg2
);
7589 -- Deal with non-subprogram cases
7591 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7592 Set_Convention_From_Pragma
(E
);
7596 -- The pragma must apply to a first subtype, but it can also
7597 -- apply to a generic type in a generic formal part, in which
7598 -- case it will also appear in the corresponding instance.
7600 if Is_Generic_Type
(E
) or else In_Instance
then
7603 Check_First_Subtype
(Arg2
);
7606 Set_Convention_From_Pragma
(Base_Type
(E
));
7608 -- For access subprograms, we must set the convention on the
7609 -- internally generated directly designated type as well.
7611 if Ekind
(E
) = E_Access_Subprogram_Type
then
7612 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7616 -- For the subprogram case, set proper convention for all homonyms
7617 -- in same scope and the same declarative part, i.e. the same
7618 -- compilation unit.
7621 Comp_Unit
:= Get_Source_Unit
(E
);
7622 Set_Convention_From_Pragma
(E
);
7624 -- Treat a pragma Import as an implicit body, and pragma import
7625 -- as implicit reference (for navigation in GPS).
7627 if Prag_Id
= Pragma_Import
then
7628 Generate_Reference
(E
, Id
, 'b');
7630 -- For exported entities we restrict the generation of references
7631 -- to entities exported to foreign languages since entities
7632 -- exported to Ada do not provide further information to GPS and
7633 -- add undesired references to the output of the gnatxref tool.
7635 elsif Prag_Id
= Pragma_Export
7636 and then Convention
(E
) /= Convention_Ada
7638 Generate_Reference
(E
, Id
, 'i');
7641 -- If the pragma comes from an aspect, it only applies to the
7642 -- given entity, not its homonyms.
7644 if From_Aspect_Specification
(N
) then
7648 -- Otherwise Loop through the homonyms of the pragma argument's
7649 -- entity, an apply convention to those in the current scope.
7655 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7657 -- Ignore entry for which convention is already set
7659 if Has_Convention_Pragma
(E1
) then
7663 -- Do not set the pragma on inherited operations or on formal
7666 if Comes_From_Source
(E1
)
7667 and then Comp_Unit
= Get_Source_Unit
(E1
)
7668 and then not Is_Formal_Subprogram
(E1
)
7669 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7670 N_Full_Type_Declaration
7672 if Present
(Alias
(E1
))
7673 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7676 ("cannot apply pragma% to non-local entity& declared#",
7680 Set_Convention_From_Pragma
(E1
);
7682 if Prag_Id
= Pragma_Import
then
7683 Generate_Reference
(E1
, Id
, 'b');
7691 end Process_Convention
;
7693 ----------------------------------------
7694 -- Process_Disable_Enable_Atomic_Sync --
7695 ----------------------------------------
7697 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7699 Check_No_Identifiers
;
7700 Check_At_Most_N_Arguments
(1);
7702 -- Modeled internally as
7703 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7707 Pragma_Identifier
=>
7708 Make_Identifier
(Loc
, Nam
),
7709 Pragma_Argument_Associations
=> New_List
(
7710 Make_Pragma_Argument_Association
(Loc
,
7712 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7714 if Present
(Arg1
) then
7715 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7719 end Process_Disable_Enable_Atomic_Sync
;
7721 -------------------------------------------------
7722 -- Process_Extended_Import_Export_Internal_Arg --
7723 -------------------------------------------------
7725 procedure Process_Extended_Import_Export_Internal_Arg
7726 (Arg_Internal
: Node_Id
:= Empty
)
7729 if No
(Arg_Internal
) then
7730 Error_Pragma
("Internal parameter required for pragma%");
7733 if Nkind
(Arg_Internal
) = N_Identifier
then
7736 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7737 and then (Prag_Id
= Pragma_Import_Function
7739 Prag_Id
= Pragma_Export_Function
)
7745 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7748 Check_Arg_Is_Local_Name
(Arg_Internal
);
7749 end Process_Extended_Import_Export_Internal_Arg
;
7751 --------------------------------------------------
7752 -- Process_Extended_Import_Export_Object_Pragma --
7753 --------------------------------------------------
7755 procedure Process_Extended_Import_Export_Object_Pragma
7756 (Arg_Internal
: Node_Id
;
7757 Arg_External
: Node_Id
;
7763 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7764 Def_Id
:= Entity
(Arg_Internal
);
7766 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7768 ("pragma% must designate an object", Arg_Internal
);
7771 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7773 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7776 ("previous Common/Psect_Object applies, pragma % not permitted",
7780 if Rep_Item_Too_Late
(Def_Id
, N
) then
7784 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7786 if Present
(Arg_Size
) then
7787 Check_Arg_Is_External_Name
(Arg_Size
);
7790 -- Export_Object case
7792 if Prag_Id
= Pragma_Export_Object
then
7793 if not Is_Library_Level_Entity
(Def_Id
) then
7795 ("argument for pragma% must be library level entity",
7799 if Ekind
(Current_Scope
) = E_Generic_Package
then
7800 Error_Pragma
("pragma& cannot appear in a generic unit");
7803 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7805 ("exported object must have compile time known size",
7809 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7810 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7812 Set_Exported
(Def_Id
, Arg_Internal
);
7815 -- Import_Object case
7818 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7820 ("cannot use pragma% for task/protected object",
7824 if Ekind
(Def_Id
) = E_Constant
then
7826 ("cannot import a constant", Arg_Internal
);
7829 if Warn_On_Export_Import
7830 and then Has_Discriminants
(Etype
(Def_Id
))
7833 ("imported value must be initialized??", Arg_Internal
);
7836 if Warn_On_Export_Import
7837 and then Is_Access_Type
(Etype
(Def_Id
))
7840 ("cannot import object of an access type??", Arg_Internal
);
7843 if Warn_On_Export_Import
7844 and then Is_Imported
(Def_Id
)
7846 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7848 -- Check for explicit initialization present. Note that an
7849 -- initialization generated by the code generator, e.g. for an
7850 -- access type, does not count here.
7852 elsif Present
(Expression
(Parent
(Def_Id
)))
7855 (Original_Node
(Expression
(Parent
(Def_Id
))))
7857 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7859 ("imported entities cannot be initialized (RM B.1(24))",
7860 "\no initialization allowed for & declared#", Arg1
);
7862 Set_Imported
(Def_Id
);
7863 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7866 end Process_Extended_Import_Export_Object_Pragma
;
7868 ------------------------------------------------------
7869 -- Process_Extended_Import_Export_Subprogram_Pragma --
7870 ------------------------------------------------------
7872 procedure Process_Extended_Import_Export_Subprogram_Pragma
7873 (Arg_Internal
: Node_Id
;
7874 Arg_External
: Node_Id
;
7875 Arg_Parameter_Types
: Node_Id
;
7876 Arg_Result_Type
: Node_Id
:= Empty
;
7877 Arg_Mechanism
: Node_Id
;
7878 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7884 Ambiguous
: Boolean;
7887 function Same_Base_Type
7889 Formal
: Entity_Id
) return Boolean;
7890 -- Determines if Ptype references the type of Formal. Note that only
7891 -- the base types need to match according to the spec. Ptype here is
7892 -- the argument from the pragma, which is either a type name, or an
7893 -- access attribute.
7895 --------------------
7896 -- Same_Base_Type --
7897 --------------------
7899 function Same_Base_Type
7901 Formal
: Entity_Id
) return Boolean
7903 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7907 -- Case where pragma argument is typ'Access
7909 if Nkind
(Ptype
) = N_Attribute_Reference
7910 and then Attribute_Name
(Ptype
) = Name_Access
7912 Pref
:= Prefix
(Ptype
);
7915 if not Is_Entity_Name
(Pref
)
7916 or else Entity
(Pref
) = Any_Type
7921 -- We have a match if the corresponding argument is of an
7922 -- anonymous access type, and its designated type matches the
7923 -- type of the prefix of the access attribute
7925 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7926 and then Base_Type
(Entity
(Pref
)) =
7927 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7929 -- Case where pragma argument is a type name
7934 if not Is_Entity_Name
(Ptype
)
7935 or else Entity
(Ptype
) = Any_Type
7940 -- We have a match if the corresponding argument is of the type
7941 -- given in the pragma (comparing base types)
7943 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7947 -- Start of processing for
7948 -- Process_Extended_Import_Export_Subprogram_Pragma
7951 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7955 -- Loop through homonyms (overloadings) of the entity
7957 Hom_Id
:= Entity
(Arg_Internal
);
7958 while Present
(Hom_Id
) loop
7959 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7961 -- We need a subprogram in the current scope
7963 if not Is_Subprogram
(Def_Id
)
7964 or else Scope
(Def_Id
) /= Current_Scope
7971 -- Pragma cannot apply to subprogram body
7973 if Is_Subprogram
(Def_Id
)
7974 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7978 ("pragma% requires separate spec"
7979 & " and must come before body");
7982 -- Test result type if given, note that the result type
7983 -- parameter can only be present for the function cases.
7985 if Present
(Arg_Result_Type
)
7986 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7990 elsif Etype
(Def_Id
) /= Standard_Void_Type
7992 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7996 -- Test parameter types if given. Note that this parameter
7997 -- has not been analyzed (and must not be, since it is
7998 -- semantic nonsense), so we get it as the parser left it.
8000 elsif Present
(Arg_Parameter_Types
) then
8001 Check_Matching_Types
: declare
8006 Formal
:= First_Formal
(Def_Id
);
8008 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8009 if Present
(Formal
) then
8013 -- A list of one type, e.g. (List) is parsed as
8014 -- a parenthesized expression.
8016 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8017 and then Paren_Count
(Arg_Parameter_Types
) = 1
8020 or else Present
(Next_Formal
(Formal
))
8025 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8028 -- A list of more than one type is parsed as a aggregate
8030 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8031 and then Paren_Count
(Arg_Parameter_Types
) = 0
8033 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8034 while Present
(Ptype
) or else Present
(Formal
) loop
8037 or else not Same_Base_Type
(Ptype
, Formal
)
8042 Next_Formal
(Formal
);
8047 -- Anything else is of the wrong form
8051 ("wrong form for Parameter_Types parameter",
8052 Arg_Parameter_Types
);
8054 end Check_Matching_Types
;
8057 -- Match is now False if the entry we found did not match
8058 -- either a supplied Parameter_Types or Result_Types argument
8064 -- Ambiguous case, the flag Ambiguous shows if we already
8065 -- detected this and output the initial messages.
8068 if not Ambiguous
then
8070 Error_Msg_Name_1
:= Pname
;
8072 ("pragma% does not uniquely identify subprogram!",
8074 Error_Msg_Sloc
:= Sloc
(Ent
);
8075 Error_Msg_N
("matching subprogram #!", N
);
8079 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8080 Error_Msg_N
("matching subprogram #!", N
);
8085 Hom_Id
:= Homonym
(Hom_Id
);
8088 -- See if we found an entry
8091 if not Ambiguous
then
8092 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8094 ("pragma% cannot be given for generic subprogram");
8097 ("pragma% does not identify local subprogram");
8104 -- Import pragmas must be for imported entities
8106 if Prag_Id
= Pragma_Import_Function
8108 Prag_Id
= Pragma_Import_Procedure
8110 Prag_Id
= Pragma_Import_Valued_Procedure
8112 if not Is_Imported
(Ent
) then
8114 ("pragma Import or Interface must precede pragma%");
8117 -- Here we have the Export case which can set the entity as exported
8119 -- But does not do so if the specified external name is null, since
8120 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8121 -- compatible) to request no external name.
8123 elsif Nkind
(Arg_External
) = N_String_Literal
8124 and then String_Length
(Strval
(Arg_External
)) = 0
8128 -- In all other cases, set entity as exported
8131 Set_Exported
(Ent
, Arg_Internal
);
8134 -- Special processing for Valued_Procedure cases
8136 if Prag_Id
= Pragma_Import_Valued_Procedure
8138 Prag_Id
= Pragma_Export_Valued_Procedure
8140 Formal
:= First_Formal
(Ent
);
8143 Error_Pragma
("at least one parameter required for pragma%");
8145 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8146 Error_Pragma
("first parameter must have mode out for pragma%");
8149 Set_Is_Valued_Procedure
(Ent
);
8153 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8155 -- Process Result_Mechanism argument if present. We have already
8156 -- checked that this is only allowed for the function case.
8158 if Present
(Arg_Result_Mechanism
) then
8159 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8162 -- Process Mechanism parameter if present. Note that this parameter
8163 -- is not analyzed, and must not be analyzed since it is semantic
8164 -- nonsense, so we get it in exactly as the parser left it.
8166 if Present
(Arg_Mechanism
) then
8174 -- A single mechanism association without a formal parameter
8175 -- name is parsed as a parenthesized expression. All other
8176 -- cases are parsed as aggregates, so we rewrite the single
8177 -- parameter case as an aggregate for consistency.
8179 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8180 and then Paren_Count
(Arg_Mechanism
) = 1
8182 Rewrite
(Arg_Mechanism
,
8183 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8184 Expressions
=> New_List
(
8185 Relocate_Node
(Arg_Mechanism
))));
8188 -- Case of only mechanism name given, applies to all formals
8190 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8191 Formal
:= First_Formal
(Ent
);
8192 while Present
(Formal
) loop
8193 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8194 Next_Formal
(Formal
);
8197 -- Case of list of mechanism associations given
8200 if Null_Record_Present
(Arg_Mechanism
) then
8202 ("inappropriate form for Mechanism parameter",
8206 -- Deal with positional ones first
8208 Formal
:= First_Formal
(Ent
);
8210 if Present
(Expressions
(Arg_Mechanism
)) then
8211 Mname
:= First
(Expressions
(Arg_Mechanism
));
8212 while Present
(Mname
) loop
8215 ("too many mechanism associations", Mname
);
8218 Set_Mechanism_Value
(Formal
, Mname
);
8219 Next_Formal
(Formal
);
8224 -- Deal with named entries
8226 if Present
(Component_Associations
(Arg_Mechanism
)) then
8227 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8228 while Present
(Massoc
) loop
8229 Choice
:= First
(Choices
(Massoc
));
8231 if Nkind
(Choice
) /= N_Identifier
8232 or else Present
(Next
(Choice
))
8235 ("incorrect form for mechanism association",
8239 Formal
:= First_Formal
(Ent
);
8243 ("parameter name & not present", Choice
);
8246 if Chars
(Choice
) = Chars
(Formal
) then
8248 (Formal
, Expression
(Massoc
));
8250 -- Set entity on identifier (needed by ASIS)
8252 Set_Entity
(Choice
, Formal
);
8257 Next_Formal
(Formal
);
8266 end Process_Extended_Import_Export_Subprogram_Pragma
;
8268 --------------------------
8269 -- Process_Generic_List --
8270 --------------------------
8272 procedure Process_Generic_List
is
8277 Check_No_Identifiers
;
8278 Check_At_Least_N_Arguments
(1);
8280 -- Check all arguments are names of generic units or instances
8283 while Present
(Arg
) loop
8284 Exp
:= Get_Pragma_Arg
(Arg
);
8287 if not Is_Entity_Name
(Exp
)
8289 (not Is_Generic_Instance
(Entity
(Exp
))
8291 not Is_Generic_Unit
(Entity
(Exp
)))
8294 ("pragma% argument must be name of generic unit/instance",
8300 end Process_Generic_List
;
8302 ------------------------------------
8303 -- Process_Import_Predefined_Type --
8304 ------------------------------------
8306 procedure Process_Import_Predefined_Type
is
8307 Loc
: constant Source_Ptr
:= Sloc
(N
);
8309 Ftyp
: Node_Id
:= Empty
;
8315 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
8318 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8319 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8323 Ftyp
:= Node
(Elmt
);
8325 if Present
(Ftyp
) then
8327 -- Don't build a derived type declaration, because predefined C
8328 -- types have no declaration anywhere, so cannot really be named.
8329 -- Instead build a full type declaration, starting with an
8330 -- appropriate type definition is built
8332 if Is_Floating_Point_Type
(Ftyp
) then
8333 Def
:= Make_Floating_Point_Definition
(Loc
,
8334 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8335 Make_Real_Range_Specification
(Loc
,
8336 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8337 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8339 -- Should never have a predefined type we cannot handle
8342 raise Program_Error
;
8345 -- Build and insert a Full_Type_Declaration, which will be
8346 -- analyzed as soon as this list entry has been analyzed.
8348 Decl
:= Make_Full_Type_Declaration
(Loc
,
8349 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8350 Type_Definition
=> Def
);
8352 Insert_After
(N
, Decl
);
8353 Mark_Rewrite_Insertion
(Decl
);
8356 Error_Pragma_Arg
("no matching type found for pragma%",
8359 end Process_Import_Predefined_Type
;
8361 ---------------------------------
8362 -- Process_Import_Or_Interface --
8363 ---------------------------------
8365 procedure Process_Import_Or_Interface
is
8371 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8372 -- pragma Import (Entity, "external name");
8374 if Relaxed_RM_Semantics
8375 and then Arg_Count
= 2
8376 and then Prag_Id
= Pragma_Import
8377 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8380 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8383 if not Is_Entity_Name
(Def_Id
) then
8384 Error_Pragma_Arg
("entity name required", Arg1
);
8387 Def_Id
:= Entity
(Def_Id
);
8388 Kill_Size_Check_Code
(Def_Id
);
8389 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8392 Process_Convention
(C
, Def_Id
);
8394 -- A pragma that applies to a Ghost entity becomes Ghost for the
8395 -- purposes of legality checks and removal of ignored Ghost code.
8397 Mark_Pragma_As_Ghost
(N
, Def_Id
);
8398 Kill_Size_Check_Code
(Def_Id
);
8399 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8402 -- Various error checks
8404 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8406 -- We do not permit Import to apply to a renaming declaration
8408 if Present
(Renamed_Object
(Def_Id
)) then
8410 ("pragma% not allowed for object renaming", Arg2
);
8412 -- User initialization is not allowed for imported object, but
8413 -- the object declaration may contain a default initialization,
8414 -- that will be discarded. Note that an explicit initialization
8415 -- only counts if it comes from source, otherwise it is simply
8416 -- the code generator making an implicit initialization explicit.
8418 elsif Present
(Expression
(Parent
(Def_Id
)))
8419 and then Comes_From_Source
8420 (Original_Node
(Expression
(Parent
(Def_Id
))))
8422 -- Set imported flag to prevent cascaded errors
8424 Set_Is_Imported
(Def_Id
);
8426 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8428 ("no initialization allowed for declaration of& #",
8429 "\imported entities cannot be initialized (RM B.1(24))",
8433 -- If the pragma comes from an aspect specification the
8434 -- Is_Imported flag has already been set.
8436 if not From_Aspect_Specification
(N
) then
8437 Set_Imported
(Def_Id
);
8440 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8442 -- Note that we do not set Is_Public here. That's because we
8443 -- only want to set it if there is no address clause, and we
8444 -- don't know that yet, so we delay that processing till
8447 -- pragma Import completes deferred constants
8449 if Ekind
(Def_Id
) = E_Constant
then
8450 Set_Has_Completion
(Def_Id
);
8453 -- It is not possible to import a constant of an unconstrained
8454 -- array type (e.g. string) because there is no simple way to
8455 -- write a meaningful subtype for it.
8457 if Is_Array_Type
(Etype
(Def_Id
))
8458 and then not Is_Constrained
(Etype
(Def_Id
))
8461 ("imported constant& must have a constrained subtype",
8466 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8468 -- If the name is overloaded, pragma applies to all of the denoted
8469 -- entities in the same declarative part, unless the pragma comes
8470 -- from an aspect specification or was generated by the compiler
8471 -- (such as for pragma Provide_Shift_Operators).
8474 while Present
(Hom_Id
) loop
8476 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8478 -- Ignore inherited subprograms because the pragma will apply
8479 -- to the parent operation, which is the one called.
8481 if Is_Overloadable
(Def_Id
)
8482 and then Present
(Alias
(Def_Id
))
8486 -- If it is not a subprogram, it must be in an outer scope and
8487 -- pragma does not apply.
8489 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8492 -- The pragma does not apply to primitives of interfaces
8494 elsif Is_Dispatching_Operation
(Def_Id
)
8495 and then Present
(Find_Dispatching_Type
(Def_Id
))
8496 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8500 -- Verify that the homonym is in the same declarative part (not
8501 -- just the same scope). If the pragma comes from an aspect
8502 -- specification we know that it is part of the declaration.
8504 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8505 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8506 and then not From_Aspect_Specification
(N
)
8511 -- If the pragma comes from an aspect specification the
8512 -- Is_Imported flag has already been set.
8514 if not From_Aspect_Specification
(N
) then
8515 Set_Imported
(Def_Id
);
8518 -- Reject an Import applied to an abstract subprogram
8520 if Is_Subprogram
(Def_Id
)
8521 and then Is_Abstract_Subprogram
(Def_Id
)
8523 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8525 ("cannot import abstract subprogram& declared#",
8529 -- Special processing for Convention_Intrinsic
8531 if C
= Convention_Intrinsic
then
8533 -- Link_Name argument not allowed for intrinsic
8537 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8539 -- If no external name is present, then check that this
8540 -- is a valid intrinsic subprogram. If an external name
8541 -- is present, then this is handled by the back end.
8544 Check_Intrinsic_Subprogram
8545 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8549 -- Verify that the subprogram does not have a completion
8550 -- through a renaming declaration. For other completions the
8551 -- pragma appears as a too late representation.
8554 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8558 and then Nkind
(Decl
) = N_Subprogram_Declaration
8559 and then Present
(Corresponding_Body
(Decl
))
8560 and then Nkind
(Unit_Declaration_Node
8561 (Corresponding_Body
(Decl
))) =
8562 N_Subprogram_Renaming_Declaration
8564 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8566 ("cannot import&, renaming already provided for "
8567 & "declaration #", N
, Def_Id
);
8571 -- If the pragma comes from an aspect specification, there
8572 -- must be an Import aspect specified as well. In the rare
8573 -- case where Import is set to False, the suprogram needs to
8574 -- have a local completion.
8577 Imp_Aspect
: constant Node_Id
:=
8578 Find_Aspect
(Def_Id
, Aspect_Import
);
8582 if Present
(Imp_Aspect
)
8583 and then Present
(Expression
(Imp_Aspect
))
8585 Expr
:= Expression
(Imp_Aspect
);
8586 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8588 if Is_Entity_Name
(Expr
)
8589 and then Entity
(Expr
) = Standard_True
8591 Set_Has_Completion
(Def_Id
);
8594 -- If there is no expression, the default is True, as for
8595 -- all boolean aspects. Same for the older pragma.
8598 Set_Has_Completion
(Def_Id
);
8602 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8605 if Is_Compilation_Unit
(Hom_Id
) then
8607 -- Its possible homonyms are not affected by the pragma.
8608 -- Such homonyms might be present in the context of other
8609 -- units being compiled.
8613 elsif From_Aspect_Specification
(N
) then
8616 -- If the pragma was created by the compiler, then we don't
8617 -- want it to apply to other homonyms. This kind of case can
8618 -- occur when using pragma Provide_Shift_Operators, which
8619 -- generates implicit shift and rotate operators with Import
8620 -- pragmas that might apply to earlier explicit or implicit
8621 -- declarations marked with Import (for example, coming from
8622 -- an earlier pragma Provide_Shift_Operators for another type),
8623 -- and we don't generally want other homonyms being treated
8624 -- as imported or the pragma flagged as an illegal duplicate.
8626 elsif not Comes_From_Source
(N
) then
8630 Hom_Id
:= Homonym
(Hom_Id
);
8634 -- Import a CPP class
8636 elsif C
= Convention_CPP
8637 and then (Is_Record_Type
(Def_Id
)
8638 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8640 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8641 if Present
(Full_View
(Def_Id
)) then
8642 Def_Id
:= Full_View
(Def_Id
);
8646 ("cannot import 'C'P'P type before full declaration seen",
8647 Get_Pragma_Arg
(Arg2
));
8649 -- Although we have reported the error we decorate it as
8650 -- CPP_Class to avoid reporting spurious errors
8652 Set_Is_CPP_Class
(Def_Id
);
8657 -- Types treated as CPP classes must be declared limited (note:
8658 -- this used to be a warning but there is no real benefit to it
8659 -- since we did effectively intend to treat the type as limited
8662 if not Is_Limited_Type
(Def_Id
) then
8664 ("imported 'C'P'P type must be limited",
8665 Get_Pragma_Arg
(Arg2
));
8668 if Etype
(Def_Id
) /= Def_Id
8669 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8671 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8674 Set_Is_CPP_Class
(Def_Id
);
8676 -- Imported CPP types must not have discriminants (because C++
8677 -- classes do not have discriminants).
8679 if Has_Discriminants
(Def_Id
) then
8681 ("imported 'C'P'P type cannot have discriminants",
8682 First
(Discriminant_Specifications
8683 (Declaration_Node
(Def_Id
))));
8686 -- Check that components of imported CPP types do not have default
8687 -- expressions. For private types this check is performed when the
8688 -- full view is analyzed (see Process_Full_View).
8690 if not Is_Private_Type
(Def_Id
) then
8691 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8694 -- Import a CPP exception
8696 elsif C
= Convention_CPP
8697 and then Ekind
(Def_Id
) = E_Exception
8701 ("'External_'Name arguments is required for 'Cpp exception",
8704 -- As only a string is allowed, Check_Arg_Is_External_Name
8707 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8710 if Present
(Arg4
) then
8712 ("Link_Name argument not allowed for imported Cpp exception",
8716 -- Do not call Set_Interface_Name as the name of the exception
8717 -- shouldn't be modified (and in particular it shouldn't be
8718 -- the External_Name). For exceptions, the External_Name is the
8719 -- name of the RTTI structure.
8721 -- ??? Emit an error if pragma Import/Export_Exception is present
8723 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8725 Check_Arg_Count
(3);
8726 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8728 Process_Import_Predefined_Type
;
8732 ("second argument of pragma% must be object, subprogram "
8733 & "or incomplete type",
8737 -- If this pragma applies to a compilation unit, then the unit, which
8738 -- is a subprogram, does not require (or allow) a body. We also do
8739 -- not need to elaborate imported procedures.
8741 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8743 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8745 Set_Body_Required
(Cunit
, False);
8748 end Process_Import_Or_Interface
;
8750 --------------------
8751 -- Process_Inline --
8752 --------------------
8754 procedure Process_Inline
(Status
: Inline_Status
) is
8761 Ghost_Error_Posted
: Boolean := False;
8762 -- Flag set when an error concerning the illegal mix of Ghost and
8763 -- non-Ghost subprograms is emitted.
8765 Ghost_Id
: Entity_Id
:= Empty
;
8766 -- The entity of the first Ghost subprogram encountered while
8767 -- processing the arguments of the pragma.
8769 procedure Make_Inline
(Subp
: Entity_Id
);
8770 -- Subp is the defining unit name of the subprogram declaration. If
8771 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8772 -- the corresponding body, if there is one present.
8774 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8775 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8776 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8778 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8779 -- Returns True if it can be determined at this stage that inlining
8780 -- is not possible, for example if the body is available and contains
8781 -- exception handlers, we prevent inlining, since otherwise we can
8782 -- get undefined symbols at link time. This function also emits a
8783 -- warning if the pragma appears too late.
8785 -- ??? is business with link symbols still valid, or does it relate
8786 -- to front end ZCX which is being phased out ???
8788 ---------------------------
8789 -- Inlining_Not_Possible --
8790 ---------------------------
8792 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8793 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8797 if Nkind
(Decl
) = N_Subprogram_Body
then
8798 Stats
:= Handled_Statement_Sequence
(Decl
);
8799 return Present
(Exception_Handlers
(Stats
))
8800 or else Present
(At_End_Proc
(Stats
));
8802 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8803 and then Present
(Corresponding_Body
(Decl
))
8805 if Analyzed
(Corresponding_Body
(Decl
)) then
8806 Error_Msg_N
("pragma appears too late, ignored??", N
);
8809 -- If the subprogram is a renaming as body, the body is just a
8810 -- call to the renamed subprogram, and inlining is trivially
8814 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8815 N_Subprogram_Renaming_Declaration
8821 Handled_Statement_Sequence
8822 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8825 Present
(Exception_Handlers
(Stats
))
8826 or else Present
(At_End_Proc
(Stats
));
8830 -- If body is not available, assume the best, the check is
8831 -- performed again when compiling enclosing package bodies.
8835 end Inlining_Not_Possible
;
8841 procedure Make_Inline
(Subp
: Entity_Id
) is
8842 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8843 Inner_Subp
: Entity_Id
:= Subp
;
8846 -- Ignore if bad type, avoid cascaded error
8848 if Etype
(Subp
) = Any_Type
then
8852 -- If inlining is not possible, for now do not treat as an error
8854 elsif Status
/= Suppressed
8855 and then Front_End_Inlining
8856 and then Inlining_Not_Possible
(Subp
)
8861 -- Here we have a candidate for inlining, but we must exclude
8862 -- derived operations. Otherwise we would end up trying to inline
8863 -- a phantom declaration, and the result would be to drag in a
8864 -- body which has no direct inlining associated with it. That
8865 -- would not only be inefficient but would also result in the
8866 -- backend doing cross-unit inlining in cases where it was
8867 -- definitely inappropriate to do so.
8869 -- However, a simple Comes_From_Source test is insufficient, since
8870 -- we do want to allow inlining of generic instances which also do
8871 -- not come from source. We also need to recognize specs generated
8872 -- by the front-end for bodies that carry the pragma. Finally,
8873 -- predefined operators do not come from source but are not
8874 -- inlineable either.
8876 elsif Is_Generic_Instance
(Subp
)
8877 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8881 elsif not Comes_From_Source
(Subp
)
8882 and then Scope
(Subp
) /= Standard_Standard
8888 -- The referenced entity must either be the enclosing entity, or
8889 -- an entity declared within the current open scope.
8891 if Present
(Scope
(Subp
))
8892 and then Scope
(Subp
) /= Current_Scope
8893 and then Subp
/= Current_Scope
8896 ("argument of% must be entity in current scope", Assoc
);
8900 -- Processing for procedure, operator or function. If subprogram
8901 -- is aliased (as for an instance) indicate that the renamed
8902 -- entity (if declared in the same unit) is inlined.
8903 -- If this is the anonymous subprogram created for a subprogram
8904 -- instance, the inlining applies to it directly. Otherwise we
8905 -- retrieve it as the alias of the visible subprogram instance.
8907 if Is_Subprogram
(Subp
) then
8908 if Is_Wrapper_Package
(Scope
(Subp
)) then
8911 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8914 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8915 Set_Inline_Flags
(Inner_Subp
);
8917 Decl
:= Parent
(Parent
(Inner_Subp
));
8919 if Nkind
(Decl
) = N_Subprogram_Declaration
8920 and then Present
(Corresponding_Body
(Decl
))
8922 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8924 elsif Is_Generic_Instance
(Subp
)
8925 and then Comes_From_Source
(Subp
)
8927 -- Indicate that the body needs to be created for
8928 -- inlining subsequent calls. The instantiation node
8929 -- follows the declaration of the wrapper package
8930 -- created for it. The subprogram that requires the
8931 -- body is the anonymous one in the wrapper package.
8933 if Scope
(Subp
) /= Standard_Standard
8935 Need_Subprogram_Instance_Body
8936 (Next
(Unit_Declaration_Node
8937 (Scope
(Alias
(Subp
)))), Subp
)
8942 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8943 -- appear in a formal part to apply to a formal subprogram.
8944 -- Do not apply check within an instance or a formal package
8945 -- the test will have been applied to the original generic.
8947 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8948 and then List_Containing
(Decl
) = List_Containing
(N
)
8949 and then not In_Instance
8952 ("Inline cannot apply to a formal subprogram", N
);
8954 -- If Subp is a renaming, it is the renamed entity that
8955 -- will appear in any call, and be inlined. However, for
8956 -- ASIS uses it is convenient to indicate that the renaming
8957 -- itself is an inlined subprogram, so that some gnatcheck
8958 -- rules can be applied in the absence of expansion.
8960 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8961 Set_Inline_Flags
(Subp
);
8967 -- For a generic subprogram set flag as well, for use at the point
8968 -- of instantiation, to determine whether the body should be
8971 elsif Is_Generic_Subprogram
(Subp
) then
8972 Set_Inline_Flags
(Subp
);
8975 -- Literals are by definition inlined
8977 elsif Kind
= E_Enumeration_Literal
then
8980 -- Anything else is an error
8984 ("expect subprogram name for pragma%", Assoc
);
8988 ----------------------
8989 -- Set_Inline_Flags --
8990 ----------------------
8992 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8994 -- First set the Has_Pragma_XXX flags and issue the appropriate
8995 -- errors and warnings for suspicious combinations.
8997 if Prag_Id
= Pragma_No_Inline
then
8998 if Has_Pragma_Inline_Always
(Subp
) then
9000 ("Inline_Always and No_Inline are mutually exclusive", N
);
9001 elsif Has_Pragma_Inline
(Subp
) then
9003 ("Inline and No_Inline both specified for& ??",
9004 N
, Entity
(Subp_Id
));
9007 Set_Has_Pragma_No_Inline
(Subp
);
9009 if Prag_Id
= Pragma_Inline_Always
then
9010 if Has_Pragma_No_Inline
(Subp
) then
9012 ("Inline_Always and No_Inline are mutually exclusive",
9016 Set_Has_Pragma_Inline_Always
(Subp
);
9018 if Has_Pragma_No_Inline
(Subp
) then
9020 ("Inline and No_Inline both specified for& ??",
9021 N
, Entity
(Subp_Id
));
9025 Set_Has_Pragma_Inline
(Subp
);
9028 -- Then adjust the Is_Inlined flag. It can never be set if the
9029 -- subprogram is subject to pragma No_Inline.
9033 Set_Is_Inlined
(Subp
, False);
9037 if not Has_Pragma_No_Inline
(Subp
) then
9038 Set_Is_Inlined
(Subp
, True);
9042 -- A pragma that applies to a Ghost entity becomes Ghost for the
9043 -- purposes of legality checks and removal of ignored Ghost code.
9045 Mark_Pragma_As_Ghost
(N
, Subp
);
9047 -- Capture the entity of the first Ghost subprogram being
9048 -- processed for error detection purposes.
9050 if Is_Ghost_Entity
(Subp
) then
9051 if No
(Ghost_Id
) then
9055 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9056 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9058 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9059 Ghost_Error_Posted
:= True;
9061 Error_Msg_Name_1
:= Pname
;
9063 ("pragma % cannot mention ghost and non-ghost subprograms",
9066 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9067 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9069 Error_Msg_Sloc
:= Sloc
(Subp
);
9070 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9072 end Set_Inline_Flags
;
9074 -- Start of processing for Process_Inline
9077 Check_No_Identifiers
;
9078 Check_At_Least_N_Arguments
(1);
9080 if Status
= Enabled
then
9081 Inline_Processing_Required
:= True;
9085 while Present
(Assoc
) loop
9086 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9090 if Is_Entity_Name
(Subp_Id
) then
9091 Subp
:= Entity
(Subp_Id
);
9093 if Subp
= Any_Id
then
9095 -- If previous error, avoid cascaded errors
9097 Check_Error_Detected
;
9103 -- For the pragma case, climb homonym chain. This is
9104 -- what implements allowing the pragma in the renaming
9105 -- case, with the result applying to the ancestors, and
9106 -- also allows Inline to apply to all previous homonyms.
9108 if not From_Aspect_Specification
(N
) then
9109 while Present
(Homonym
(Subp
))
9110 and then Scope
(Homonym
(Subp
)) = Current_Scope
9112 Make_Inline
(Homonym
(Subp
));
9113 Subp
:= Homonym
(Subp
);
9120 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9127 ----------------------------
9128 -- Process_Interface_Name --
9129 ----------------------------
9131 procedure Process_Interface_Name
9132 (Subprogram_Def
: Entity_Id
;
9138 String_Val
: String_Id
;
9140 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9141 -- SN is a string literal node for an interface name. This routine
9142 -- performs some minimal checks that the name is reasonable. In
9143 -- particular that no spaces or other obviously incorrect characters
9144 -- appear. This is only a warning, since any characters are allowed.
9146 ----------------------------------
9147 -- Check_Form_Of_Interface_Name --
9148 ----------------------------------
9150 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9151 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9152 SL
: constant Nat
:= String_Length
(S
);
9157 Error_Msg_N
("interface name cannot be null string", SN
);
9160 for J
in 1 .. SL
loop
9161 C
:= Get_String_Char
(S
, J
);
9163 -- Look for dubious character and issue unconditional warning.
9164 -- Definitely dubious if not in character range.
9166 if not In_Character_Range
(C
)
9168 -- Commas, spaces and (back)slashes are dubious
9170 or else Get_Character
(C
) = ','
9171 or else Get_Character
(C
) = '\'
9172 or else Get_Character
(C
) = ' '
9173 or else Get_Character
(C
) = '/'
9176 ("??interface name contains illegal character",
9177 Sloc
(SN
) + Source_Ptr
(J
));
9180 end Check_Form_Of_Interface_Name
;
9182 -- Start of processing for Process_Interface_Name
9185 if No
(Link_Arg
) then
9186 if No
(Ext_Arg
) then
9189 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9191 Link_Nam
:= Expression
(Ext_Arg
);
9194 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9195 Ext_Nam
:= Expression
(Ext_Arg
);
9200 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9201 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9202 Ext_Nam
:= Expression
(Ext_Arg
);
9203 Link_Nam
:= Expression
(Link_Arg
);
9206 -- Check expressions for external name and link name are static
9208 if Present
(Ext_Nam
) then
9209 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9210 Check_Form_Of_Interface_Name
(Ext_Nam
);
9212 -- Verify that external name is not the name of a local entity,
9213 -- which would hide the imported one and could lead to run-time
9214 -- surprises. The problem can only arise for entities declared in
9215 -- a package body (otherwise the external name is fully qualified
9216 -- and will not conflict).
9224 if Prag_Id
= Pragma_Import
then
9225 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
9227 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9229 if Nam
/= Chars
(Subprogram_Def
)
9230 and then Present
(E
)
9231 and then not Is_Overloadable
(E
)
9232 and then Is_Immediately_Visible
(E
)
9233 and then not Is_Imported
(E
)
9234 and then Ekind
(Scope
(E
)) = E_Package
9237 while Present
(Par
) loop
9238 if Nkind
(Par
) = N_Package_Body
then
9239 Error_Msg_Sloc
:= Sloc
(E
);
9241 ("imported entity is hidden by & declared#",
9246 Par
:= Parent
(Par
);
9253 if Present
(Link_Nam
) then
9254 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9255 Check_Form_Of_Interface_Name
(Link_Nam
);
9258 -- If there is no link name, just set the external name
9260 if No
(Link_Nam
) then
9261 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9263 -- For the Link_Name case, the given literal is preceded by an
9264 -- asterisk, which indicates to GCC that the given name should be
9265 -- taken literally, and in particular that no prepending of
9266 -- underlines should occur, even in systems where this is the
9271 Store_String_Char
(Get_Char_Code
('*'));
9272 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9273 Store_String_Chars
(String_Val
);
9275 Make_String_Literal
(Sloc
(Link_Nam
),
9276 Strval
=> End_String
);
9279 -- Set the interface name. If the entity is a generic instance, use
9280 -- its alias, which is the callable entity.
9282 if Is_Generic_Instance
(Subprogram_Def
) then
9283 Set_Encoded_Interface_Name
9284 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9286 Set_Encoded_Interface_Name
9287 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9290 Check_Duplicated_Export_Name
(Link_Nam
);
9291 end Process_Interface_Name
;
9293 -----------------------------------------
9294 -- Process_Interrupt_Or_Attach_Handler --
9295 -----------------------------------------
9297 procedure Process_Interrupt_Or_Attach_Handler
is
9298 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9299 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9302 -- A pragma that applies to a Ghost entity becomes Ghost for the
9303 -- purposes of legality checks and removal of ignored Ghost code.
9305 Mark_Pragma_As_Ghost
(N
, Handler
);
9306 Set_Is_Interrupt_Handler
(Handler
);
9308 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
9310 Record_Rep_Item
(Prot_Typ
, N
);
9312 -- Chain the pragma on the contract for completeness
9314 Add_Contract_Item
(N
, Handler
);
9315 end Process_Interrupt_Or_Attach_Handler
;
9317 --------------------------------------------------
9318 -- Process_Restrictions_Or_Restriction_Warnings --
9319 --------------------------------------------------
9321 -- Note: some of the simple identifier cases were handled in par-prag,
9322 -- but it is harmless (and more straightforward) to simply handle all
9323 -- cases here, even if it means we repeat a bit of work in some cases.
9325 procedure Process_Restrictions_Or_Restriction_Warnings
9329 R_Id
: Restriction_Id
;
9335 -- Ignore all Restrictions pragmas in CodePeer mode
9337 if CodePeer_Mode
then
9341 Check_Ada_83_Warning
;
9342 Check_At_Least_N_Arguments
(1);
9343 Check_Valid_Configuration_Pragma
;
9346 while Present
(Arg
) loop
9348 Expr
:= Get_Pragma_Arg
(Arg
);
9350 -- Case of no restriction identifier present
9352 if Id
= No_Name
then
9353 if Nkind
(Expr
) /= N_Identifier
then
9355 ("invalid form for restriction", Arg
);
9360 (Process_Restriction_Synonyms
(Expr
));
9362 if R_Id
not in All_Boolean_Restrictions
then
9363 Error_Msg_Name_1
:= Pname
;
9365 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9367 -- Check for possible misspelling
9369 for J
in Restriction_Id
loop
9371 Rnm
: constant String := Restriction_Id
'Image (J
);
9374 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9375 Name_Len
:= Rnm
'Length;
9376 Set_Casing
(All_Lower_Case
);
9378 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9380 (Identifier_Casing
(Current_Source_File
));
9381 Error_Msg_String
(1 .. Rnm
'Length) :=
9382 Name_Buffer
(1 .. Name_Len
);
9383 Error_Msg_Strlen
:= Rnm
'Length;
9384 Error_Msg_N
-- CODEFIX
9385 ("\possible misspelling of ""~""",
9386 Get_Pragma_Arg
(Arg
));
9395 if Implementation_Restriction
(R_Id
) then
9396 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
9399 -- Special processing for No_Elaboration_Code restriction
9401 if R_Id
= No_Elaboration_Code
then
9403 -- Restriction is only recognized within a configuration
9404 -- pragma file, or within a unit of the main extended
9405 -- program. Note: the test for Main_Unit is needed to
9406 -- properly include the case of configuration pragma files.
9408 if not (Current_Sem_Unit
= Main_Unit
9409 or else In_Extended_Main_Source_Unit
(N
))
9413 -- Don't allow in a subunit unless already specified in
9416 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
9417 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
9418 and then not Restriction_Active
(No_Elaboration_Code
)
9421 ("invalid specification of ""No_Elaboration_Code""",
9424 ("\restriction cannot be specified in a subunit", N
);
9426 ("\unless also specified in body or spec", N
);
9429 -- If we accept a No_Elaboration_Code restriction, then it
9430 -- needs to be added to the configuration restriction set so
9431 -- that we get proper application to other units in the main
9432 -- extended source as required.
9435 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9439 -- If this is a warning, then set the warning unless we already
9440 -- have a real restriction active (we never want a warning to
9441 -- override a real restriction).
9444 if not Restriction_Active
(R_Id
) then
9445 Set_Restriction
(R_Id
, N
);
9446 Restriction_Warnings
(R_Id
) := True;
9449 -- If real restriction case, then set it and make sure that the
9450 -- restriction warning flag is off, since a real restriction
9451 -- always overrides a warning.
9454 Set_Restriction
(R_Id
, N
);
9455 Restriction_Warnings
(R_Id
) := False;
9458 -- Check for obsolescent restrictions in Ada 2005 mode
9461 and then Ada_Version
>= Ada_2005
9462 and then (R_Id
= No_Asynchronous_Control
9464 R_Id
= No_Unchecked_Deallocation
9466 R_Id
= No_Unchecked_Conversion
)
9468 Check_Restriction
(No_Obsolescent_Features
, N
);
9471 -- A very special case that must be processed here: pragma
9472 -- Restrictions (No_Exceptions) turns off all run-time
9473 -- checking. This is a bit dubious in terms of the formal
9474 -- language definition, but it is what is intended by RM
9475 -- H.4(12). Restriction_Warnings never affects generated code
9476 -- so this is done only in the real restriction case.
9478 -- Atomic_Synchronization is not a real check, so it is not
9479 -- affected by this processing).
9481 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9482 -- run-time checks in CodePeer and GNATprove modes: we want to
9483 -- generate checks for analysis purposes, as set respectively
9484 -- by -gnatC and -gnatd.F
9487 and then not (CodePeer_Mode
or GNATprove_Mode
)
9488 and then R_Id
= No_Exceptions
9490 for J
in Scope_Suppress
.Suppress
'Range loop
9491 if J
/= Atomic_Synchronization
then
9492 Scope_Suppress
.Suppress
(J
) := True;
9497 -- Case of No_Dependence => unit-name. Note that the parser
9498 -- already made the necessary entry in the No_Dependence table.
9500 elsif Id
= Name_No_Dependence
then
9501 if not OK_No_Dependence_Unit_Name
(Expr
) then
9505 -- Case of No_Specification_Of_Aspect => aspect-identifier
9507 elsif Id
= Name_No_Specification_Of_Aspect
then
9512 if Nkind
(Expr
) /= N_Identifier
then
9515 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9518 if A_Id
= No_Aspect
then
9519 Error_Pragma_Arg
("invalid restriction name", Arg
);
9521 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9525 -- Case of No_Use_Of_Attribute => attribute-identifier
9527 elsif Id
= Name_No_Use_Of_Attribute
then
9528 if Nkind
(Expr
) /= N_Identifier
9529 or else not Is_Attribute_Name
(Chars
(Expr
))
9531 Error_Msg_N
("unknown attribute name??", Expr
);
9534 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9537 -- Case of No_Use_Of_Entity => fully-qualified-name
9539 elsif Id
= Name_No_Use_Of_Entity
then
9541 -- Restriction is only recognized within a configuration
9542 -- pragma file, or within a unit of the main extended
9543 -- program. Note: the test for Main_Unit is needed to
9544 -- properly include the case of configuration pragma files.
9546 if Current_Sem_Unit
= Main_Unit
9547 or else In_Extended_Main_Source_Unit
(N
)
9549 if not OK_No_Dependence_Unit_Name
(Expr
) then
9550 Error_Msg_N
("wrong form for entity name", Expr
);
9552 Set_Restriction_No_Use_Of_Entity
9553 (Expr
, Warn
, No_Profile
);
9557 -- Case of No_Use_Of_Pragma => pragma-identifier
9559 elsif Id
= Name_No_Use_Of_Pragma
then
9560 if Nkind
(Expr
) /= N_Identifier
9561 or else not Is_Pragma_Name
(Chars
(Expr
))
9563 Error_Msg_N
("unknown pragma name??", Expr
);
9565 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9568 -- All other cases of restriction identifier present
9571 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9572 Analyze_And_Resolve
(Expr
, Any_Integer
);
9574 if R_Id
not in All_Parameter_Restrictions
then
9576 ("invalid restriction parameter identifier", Arg
);
9578 elsif not Is_OK_Static_Expression
(Expr
) then
9579 Flag_Non_Static_Expr
9580 ("value must be static expression!", Expr
);
9583 elsif not Is_Integer_Type
(Etype
(Expr
))
9584 or else Expr_Value
(Expr
) < 0
9587 ("value must be non-negative integer", Arg
);
9590 -- Restriction pragma is active
9592 Val
:= Expr_Value
(Expr
);
9594 if not UI_Is_In_Int_Range
(Val
) then
9596 ("pragma ignored, value too large??", Arg
);
9599 -- Warning case. If the real restriction is active, then we
9600 -- ignore the request, since warning never overrides a real
9601 -- restriction. Otherwise we set the proper warning. Note that
9602 -- this circuit sets the warning again if it is already set,
9603 -- which is what we want, since the constant may have changed.
9606 if not Restriction_Active
(R_Id
) then
9608 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9609 Restriction_Warnings
(R_Id
) := True;
9612 -- Real restriction case, set restriction and make sure warning
9613 -- flag is off since real restriction always overrides warning.
9616 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9617 Restriction_Warnings
(R_Id
) := False;
9623 end Process_Restrictions_Or_Restriction_Warnings
;
9625 ---------------------------------
9626 -- Process_Suppress_Unsuppress --
9627 ---------------------------------
9629 -- Note: this procedure makes entries in the check suppress data
9630 -- structures managed by Sem. See spec of package Sem for full
9631 -- details on how we handle recording of check suppression.
9633 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9638 In_Package_Spec
: constant Boolean :=
9639 Is_Package_Or_Generic_Package
(Current_Scope
)
9640 and then not In_Package_Body
(Current_Scope
);
9642 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9643 -- Used to suppress a single check on the given entity
9645 --------------------------------
9646 -- Suppress_Unsuppress_Echeck --
9647 --------------------------------
9649 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9651 -- Check for error of trying to set atomic synchronization for
9652 -- a non-atomic variable.
9654 if C
= Atomic_Synchronization
9655 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9658 ("pragma & requires atomic type or variable",
9659 Pragma_Identifier
(Original_Node
(N
)));
9662 Set_Checks_May_Be_Suppressed
(E
);
9664 if In_Package_Spec
then
9665 Push_Global_Suppress_Stack_Entry
9668 Suppress
=> Suppress_Case
);
9670 Push_Local_Suppress_Stack_Entry
9673 Suppress
=> Suppress_Case
);
9676 -- If this is a first subtype, and the base type is distinct,
9677 -- then also set the suppress flags on the base type.
9679 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9680 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9682 end Suppress_Unsuppress_Echeck
;
9684 -- Start of processing for Process_Suppress_Unsuppress
9687 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9688 -- on user code: we want to generate checks for analysis purposes, as
9689 -- set respectively by -gnatC and -gnatd.F
9691 if Comes_From_Source
(N
)
9692 and then (CodePeer_Mode
or GNATprove_Mode
)
9697 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9698 -- declarative part or a package spec (RM 11.5(5)).
9700 if not Is_Configuration_Pragma
then
9701 Check_Is_In_Decl_Part_Or_Package_Spec
;
9704 Check_At_Least_N_Arguments
(1);
9705 Check_At_Most_N_Arguments
(2);
9706 Check_No_Identifier
(Arg1
);
9707 Check_Arg_Is_Identifier
(Arg1
);
9709 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9711 if C
= No_Check_Id
then
9713 ("argument of pragma% is not valid check name", Arg1
);
9716 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9718 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9720 ("Suppress of Elaboration_Check ignored in SPARK??",
9721 "\elaboration checking rules are statically enforced "
9722 & "(SPARK RM 7.7)", Arg1
);
9725 -- One-argument case
9727 if Arg_Count
= 1 then
9729 -- Make an entry in the local scope suppress table. This is the
9730 -- table that directly shows the current value of the scope
9731 -- suppress check for any check id value.
9733 if C
= All_Checks
then
9735 -- For All_Checks, we set all specific predefined checks with
9736 -- the exception of Elaboration_Check, which is handled
9737 -- specially because of not wanting All_Checks to have the
9738 -- effect of deactivating static elaboration order processing.
9739 -- Atomic_Synchronization is also not affected, since this is
9740 -- not a real check.
9742 for J
in Scope_Suppress
.Suppress
'Range loop
9743 if J
/= Elaboration_Check
9745 J
/= Atomic_Synchronization
9747 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9751 -- If not All_Checks, and predefined check, then set appropriate
9752 -- scope entry. Note that we will set Elaboration_Check if this
9753 -- is explicitly specified. Atomic_Synchronization is allowed
9754 -- only if internally generated and entity is atomic.
9756 elsif C
in Predefined_Check_Id
9757 and then (not Comes_From_Source
(N
)
9758 or else C
/= Atomic_Synchronization
)
9760 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9763 -- Also make an entry in the Local_Entity_Suppress table
9765 Push_Local_Suppress_Stack_Entry
9768 Suppress
=> Suppress_Case
);
9770 -- Case of two arguments present, where the check is suppressed for
9771 -- a specified entity (given as the second argument of the pragma)
9774 -- This is obsolescent in Ada 2005 mode
9776 if Ada_Version
>= Ada_2005
then
9777 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9780 Check_Optional_Identifier
(Arg2
, Name_On
);
9781 E_Id
:= Get_Pragma_Arg
(Arg2
);
9784 if not Is_Entity_Name
(E_Id
) then
9786 ("second argument of pragma% must be entity name", Arg2
);
9795 -- A pragma that applies to a Ghost entity becomes Ghost for the
9796 -- purposes of legality checks and removal of ignored Ghost code.
9798 Mark_Pragma_As_Ghost
(N
, E
);
9800 -- Enforce RM 11.5(7) which requires that for a pragma that
9801 -- appears within a package spec, the named entity must be
9802 -- within the package spec. We allow the package name itself
9803 -- to be mentioned since that makes sense, although it is not
9804 -- strictly allowed by 11.5(7).
9807 and then E
/= Current_Scope
9808 and then Scope
(E
) /= Current_Scope
9811 ("entity in pragma% is not in package spec (RM 11.5(7))",
9815 -- Loop through homonyms. As noted below, in the case of a package
9816 -- spec, only homonyms within the package spec are considered.
9819 Suppress_Unsuppress_Echeck
(E
, C
);
9821 if Is_Generic_Instance
(E
)
9822 and then Is_Subprogram
(E
)
9823 and then Present
(Alias
(E
))
9825 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9828 -- Move to next homonym if not aspect spec case
9830 exit when From_Aspect_Specification
(N
);
9834 -- If we are within a package specification, the pragma only
9835 -- applies to homonyms in the same scope.
9837 exit when In_Package_Spec
9838 and then Scope
(E
) /= Current_Scope
;
9841 end Process_Suppress_Unsuppress
;
9843 -------------------------------
9844 -- Record_Independence_Check --
9845 -------------------------------
9847 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
9849 -- For GCC back ends the validation is done a priori
9851 if not AAMP_On_Target
then
9855 Independence_Checks
.Append
((N
, E
));
9856 end Record_Independence_Check
;
9862 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9864 if Is_Imported
(E
) then
9866 ("cannot export entity& that was previously imported", Arg
);
9868 elsif Present
(Address_Clause
(E
))
9869 and then not Relaxed_RM_Semantics
9872 ("cannot export entity& that has an address clause", Arg
);
9875 Set_Is_Exported
(E
);
9877 -- Generate a reference for entity explicitly, because the
9878 -- identifier may be overloaded and name resolution will not
9881 Generate_Reference
(E
, Arg
);
9883 -- Deal with exporting non-library level entity
9885 if not Is_Library_Level_Entity
(E
) then
9887 -- Not allowed at all for subprograms
9889 if Is_Subprogram
(E
) then
9890 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9892 -- Otherwise set public and statically allocated
9896 Set_Is_Statically_Allocated
(E
);
9898 -- Warn if the corresponding W flag is set
9900 if Warn_On_Export_Import
9902 -- Only do this for something that was in the source. Not
9903 -- clear if this can be False now (there used for sure to be
9904 -- cases on some systems where it was False), but anyway the
9905 -- test is harmless if not needed, so it is retained.
9907 and then Comes_From_Source
(Arg
)
9910 ("?x?& has been made static as a result of Export",
9913 ("\?x?this usage is non-standard and non-portable",
9919 if Warn_On_Export_Import
and then Is_Type
(E
) then
9920 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9923 if Warn_On_Export_Import
and Inside_A_Generic
then
9925 ("all instances of& will have the same external name?x?",
9930 ----------------------------------------------
9931 -- Set_Extended_Import_Export_External_Name --
9932 ----------------------------------------------
9934 procedure Set_Extended_Import_Export_External_Name
9935 (Internal_Ent
: Entity_Id
;
9936 Arg_External
: Node_Id
)
9938 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9942 if No
(Arg_External
) then
9946 Check_Arg_Is_External_Name
(Arg_External
);
9948 if Nkind
(Arg_External
) = N_String_Literal
then
9949 if String_Length
(Strval
(Arg_External
)) = 0 then
9952 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9955 elsif Nkind
(Arg_External
) = N_Identifier
then
9956 New_Name
:= Get_Default_External_Name
(Arg_External
);
9958 -- Check_Arg_Is_External_Name should let through only identifiers and
9959 -- string literals or static string expressions (which are folded to
9960 -- string literals).
9963 raise Program_Error
;
9966 -- If we already have an external name set (by a prior normal Import
9967 -- or Export pragma), then the external names must match
9969 if Present
(Interface_Name
(Internal_Ent
)) then
9971 -- Ignore mismatching names in CodePeer mode, to support some
9972 -- old compilers which would export the same procedure under
9973 -- different names, e.g:
9975 -- pragma Export_Procedure (P, "a");
9976 -- pragma Export_Procedure (P, "b");
9978 if CodePeer_Mode
then
9982 Check_Matching_Internal_Names
: declare
9983 S1
: constant String_Id
:= Strval
(Old_Name
);
9984 S2
: constant String_Id
:= Strval
(New_Name
);
9987 pragma No_Return
(Mismatch
);
9988 -- Called if names do not match
9994 procedure Mismatch
is
9996 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9998 ("external name does not match that given #",
10002 -- Start of processing for Check_Matching_Internal_Names
10005 if String_Length
(S1
) /= String_Length
(S2
) then
10009 for J
in 1 .. String_Length
(S1
) loop
10010 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10015 end Check_Matching_Internal_Names
;
10017 -- Otherwise set the given name
10020 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10021 Check_Duplicated_Export_Name
(New_Name
);
10023 end Set_Extended_Import_Export_External_Name
;
10029 procedure Set_Imported
(E
: Entity_Id
) is
10031 -- Error message if already imported or exported
10033 if Is_Exported
(E
) or else Is_Imported
(E
) then
10035 -- Error if being set Exported twice
10037 if Is_Exported
(E
) then
10038 Error_Msg_NE
("entity& was previously exported", N
, E
);
10040 -- Ignore error in CodePeer mode where we treat all imported
10041 -- subprograms as unknown.
10043 elsif CodePeer_Mode
then
10046 -- OK if Import/Interface case
10048 elsif Import_Interface_Present
(N
) then
10051 -- Error if being set Imported twice
10054 Error_Msg_NE
("entity& was previously imported", N
, E
);
10057 Error_Msg_Name_1
:= Pname
;
10059 ("\(pragma% applies to all previous entities)", N
);
10061 Error_Msg_Sloc
:= Sloc
(E
);
10062 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10064 -- Here if not previously imported or exported, OK to import
10067 Set_Is_Imported
(E
);
10069 -- For subprogram, set Import_Pragma field
10071 if Is_Subprogram
(E
) then
10072 Set_Import_Pragma
(E
, N
);
10075 -- If the entity is an object that is not at the library level,
10076 -- then it is statically allocated. We do not worry about objects
10077 -- with address clauses in this context since they are not really
10078 -- imported in the linker sense.
10081 and then not Is_Library_Level_Entity
(E
)
10082 and then No
(Address_Clause
(E
))
10084 Set_Is_Statically_Allocated
(E
);
10091 -------------------------
10092 -- Set_Mechanism_Value --
10093 -------------------------
10095 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10096 -- analyzed, since it is semantic nonsense), so we get it in the exact
10097 -- form created by the parser.
10099 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10100 procedure Bad_Mechanism
;
10101 pragma No_Return
(Bad_Mechanism
);
10102 -- Signal bad mechanism name
10104 -------------------------
10105 -- Bad_Mechanism_Value --
10106 -------------------------
10108 procedure Bad_Mechanism
is
10110 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10113 -- Start of processing for Set_Mechanism_Value
10116 if Mechanism
(Ent
) /= Default_Mechanism
then
10118 ("mechanism for & has already been set", Mech_Name
, Ent
);
10121 -- MECHANISM_NAME ::= value | reference
10123 if Nkind
(Mech_Name
) = N_Identifier
then
10124 if Chars
(Mech_Name
) = Name_Value
then
10125 Set_Mechanism
(Ent
, By_Copy
);
10128 elsif Chars
(Mech_Name
) = Name_Reference
then
10129 Set_Mechanism
(Ent
, By_Reference
);
10132 elsif Chars
(Mech_Name
) = Name_Copy
then
10134 ("bad mechanism name, Value assumed", Mech_Name
);
10143 end Set_Mechanism_Value
;
10145 --------------------------
10146 -- Set_Rational_Profile --
10147 --------------------------
10149 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10150 -- extension to the semantics of renaming declarations.
10152 procedure Set_Rational_Profile
is
10154 Implicit_Packing
:= True;
10155 Overriding_Renamings
:= True;
10156 Use_VADS_Size
:= True;
10157 end Set_Rational_Profile
;
10159 ---------------------------
10160 -- Set_Ravenscar_Profile --
10161 ---------------------------
10163 -- The tasks to be done here are
10165 -- Set required policies
10167 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10168 -- pragma Locking_Policy (Ceiling_Locking)
10170 -- Set Detect_Blocking mode
10172 -- Set required restrictions (see System.Rident for detailed list)
10174 -- Set the No_Dependence rules
10175 -- No_Dependence => Ada.Asynchronous_Task_Control
10176 -- No_Dependence => Ada.Calendar
10177 -- No_Dependence => Ada.Execution_Time.Group_Budget
10178 -- No_Dependence => Ada.Execution_Time.Timers
10179 -- No_Dependence => Ada.Task_Attributes
10180 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10182 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10183 procedure Set_Error_Msg_To_Profile_Name
;
10184 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10187 -----------------------------------
10188 -- Set_Error_Msg_To_Profile_Name --
10189 -----------------------------------
10191 procedure Set_Error_Msg_To_Profile_Name
is
10192 Prof_Nam
: constant Node_Id
:=
10194 (First
(Pragma_Argument_Associations
(N
)));
10197 Get_Name_String
(Chars
(Prof_Nam
));
10198 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10199 Error_Msg_Strlen
:= Name_Len
;
10200 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10201 end Set_Error_Msg_To_Profile_Name
;
10210 -- Start of processing for Set_Ravenscar_Profile
10213 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10215 if Task_Dispatching_Policy
/= ' '
10216 and then Task_Dispatching_Policy
/= 'F'
10218 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10219 Set_Error_Msg_To_Profile_Name
;
10220 Error_Pragma
("Profile (~) incompatible with policy#");
10222 -- Set the FIFO_Within_Priorities policy, but always preserve
10223 -- System_Location since we like the error message with the run time
10227 Task_Dispatching_Policy
:= 'F';
10229 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10230 Task_Dispatching_Policy_Sloc
:= Loc
;
10234 -- pragma Locking_Policy (Ceiling_Locking)
10236 if Locking_Policy
/= ' '
10237 and then Locking_Policy
/= 'C'
10239 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10240 Set_Error_Msg_To_Profile_Name
;
10241 Error_Pragma
("Profile (~) incompatible with policy#");
10243 -- Set the Ceiling_Locking policy, but preserve System_Location since
10244 -- we like the error message with the run time name.
10247 Locking_Policy
:= 'C';
10249 if Locking_Policy_Sloc
/= System_Location
then
10250 Locking_Policy_Sloc
:= Loc
;
10254 -- pragma Detect_Blocking
10256 Detect_Blocking
:= True;
10258 -- Set the corresponding restrictions
10260 Set_Profile_Restrictions
10261 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10263 -- Set the No_Dependence restrictions
10265 -- The following No_Dependence restrictions:
10266 -- No_Dependence => Ada.Asynchronous_Task_Control
10267 -- No_Dependence => Ada.Calendar
10268 -- No_Dependence => Ada.Task_Attributes
10269 -- are already set by previous call to Set_Profile_Restrictions.
10271 -- Set the following restrictions which were added to Ada 2005:
10272 -- No_Dependence => Ada.Execution_Time.Group_Budget
10273 -- No_Dependence => Ada.Execution_Time.Timers
10275 -- ??? The use of Name_Buffer here is suspicious. The names should
10276 -- be registered in snames.ads-tmpl and used to build the qualified
10279 if Ada_Version
>= Ada_2005
then
10280 Name_Buffer
(1 .. 3) := "ada";
10283 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
10285 Name_Buffer
(1 .. 14) := "execution_time";
10288 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10291 Make_Selected_Component
10294 Selector_Name
=> Sel_Id
);
10296 Name_Buffer
(1 .. 13) := "group_budgets";
10299 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10302 Make_Selected_Component
10305 Selector_Name
=> Sel_Id
);
10307 Set_Restriction_No_Dependence
10309 Warn
=> Treat_Restrictions_As_Warnings
,
10310 Profile
=> Ravenscar
);
10312 Name_Buffer
(1 .. 6) := "timers";
10315 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10318 Make_Selected_Component
10321 Selector_Name
=> Sel_Id
);
10323 Set_Restriction_No_Dependence
10325 Warn
=> Treat_Restrictions_As_Warnings
,
10326 Profile
=> Ravenscar
);
10329 -- Set the following restriction which was added to Ada 2012 (see
10331 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10333 if Ada_Version
>= Ada_2012
then
10334 Name_Buffer
(1 .. 6) := "system";
10337 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
10339 Name_Buffer
(1 .. 15) := "multiprocessors";
10342 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10345 Make_Selected_Component
10348 Selector_Name
=> Sel_Id
);
10350 Name_Buffer
(1 .. 19) := "dispatching_domains";
10353 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10356 Make_Selected_Component
10359 Selector_Name
=> Sel_Id
);
10361 Set_Restriction_No_Dependence
10363 Warn
=> Treat_Restrictions_As_Warnings
,
10364 Profile
=> Ravenscar
);
10366 end Set_Ravenscar_Profile
;
10368 -- Start of processing for Analyze_Pragma
10371 -- The following code is a defense against recursion. Not clear that
10372 -- this can happen legitimately, but perhaps some error situations can
10373 -- cause it, and we did see this recursion during testing.
10375 if Analyzed
(N
) then
10381 Check_Restriction_No_Use_Of_Pragma
(N
);
10383 -- Deal with unrecognized pragma
10385 Pname
:= Pragma_Name
(N
);
10387 if not Is_Pragma_Name
(Pname
) then
10388 if Warn_On_Unrecognized_Pragma
then
10389 Error_Msg_Name_1
:= Pname
;
10390 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10392 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10393 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10394 Error_Msg_Name_1
:= PN
;
10395 Error_Msg_N
-- CODEFIX
10396 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
10405 -- Ignore pragma if Ignore_Pragma applies
10407 if Get_Name_Table_Boolean3
(Pname
) then
10411 -- Here to start processing for recognized pragma
10413 Prag_Id
:= Get_Pragma_Id
(Pname
);
10414 Pname
:= Original_Aspect_Pragma_Name
(N
);
10416 -- Capture setting of Opt.Uneval_Old
10418 case Opt
.Uneval_Old
is
10420 Set_Uneval_Old_Accept
(N
);
10424 Set_Uneval_Old_Warn
(N
);
10426 raise Program_Error
;
10429 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10430 -- is already set, indicating that we have already checked the policy
10431 -- at the right point. This happens for example in the case of a pragma
10432 -- that is derived from an Aspect.
10434 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10437 -- For a pragma that is a rewriting of another pragma, copy the
10438 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10440 elsif Is_Rewrite_Substitution
(N
)
10441 and then Nkind
(Original_Node
(N
)) = N_Pragma
10442 and then Original_Node
(N
) /= N
10444 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10445 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10447 -- Otherwise query the applicable policy at this point
10450 Check_Applicable_Policy
(N
);
10452 -- If pragma is disabled, rewrite as NULL and skip analysis
10454 if Is_Disabled
(N
) then
10455 Rewrite
(N
, Make_Null_Statement
(Loc
));
10461 -- Preset arguments
10469 if Present
(Pragma_Argument_Associations
(N
)) then
10470 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10471 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10473 if Present
(Arg1
) then
10474 Arg2
:= Next
(Arg1
);
10476 if Present
(Arg2
) then
10477 Arg3
:= Next
(Arg2
);
10479 if Present
(Arg3
) then
10480 Arg4
:= Next
(Arg3
);
10486 -- An enumeration type defines the pragmas that are supported by the
10487 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10488 -- into the corresponding enumeration value for the following case.
10496 -- pragma Abort_Defer;
10498 when Pragma_Abort_Defer
=>
10500 Check_Arg_Count
(0);
10502 -- The only required semantic processing is to check the
10503 -- placement. This pragma must appear at the start of the
10504 -- statement sequence of a handled sequence of statements.
10506 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10507 or else N
/= First
(Statements
(Parent
(N
)))
10512 --------------------
10513 -- Abstract_State --
10514 --------------------
10516 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10518 -- ABSTRACT_STATE_LIST ::=
10520 -- | STATE_NAME_WITH_OPTIONS
10521 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10523 -- STATE_NAME_WITH_OPTIONS ::=
10525 -- | (STATE_NAME with OPTION_LIST)
10527 -- OPTION_LIST ::= OPTION {, OPTION}
10531 -- | NAME_VALUE_OPTION
10533 -- SIMPLE_OPTION ::= Ghost | Synchronous
10535 -- NAME_VALUE_OPTION ::=
10536 -- Part_Of => ABSTRACT_STATE
10537 -- | External [=> EXTERNAL_PROPERTY_LIST]
10539 -- EXTERNAL_PROPERTY_LIST ::=
10540 -- EXTERNAL_PROPERTY
10541 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10543 -- EXTERNAL_PROPERTY ::=
10544 -- Async_Readers [=> boolean_EXPRESSION]
10545 -- | Async_Writers [=> boolean_EXPRESSION]
10546 -- | Effective_Reads [=> boolean_EXPRESSION]
10547 -- | Effective_Writes [=> boolean_EXPRESSION]
10548 -- others => boolean_EXPRESSION
10550 -- STATE_NAME ::= defining_identifier
10552 -- ABSTRACT_STATE ::= name
10554 -- Characteristics:
10556 -- * Analysis - The annotation is fully analyzed immediately upon
10557 -- elaboration as it cannot forward reference entities.
10559 -- * Expansion - None.
10561 -- * Template - The annotation utilizes the generic template of the
10562 -- related package declaration.
10564 -- * Globals - The annotation cannot reference global entities.
10566 -- * Instance - The annotation is instantiated automatically when
10567 -- the related generic package is instantiated.
10569 when Pragma_Abstract_State
=> Abstract_State
: declare
10570 Missing_Parentheses
: Boolean := False;
10571 -- Flag set when a state declaration with options is not properly
10574 -- Flags used to verify the consistency of states
10576 Non_Null_Seen
: Boolean := False;
10577 Null_Seen
: Boolean := False;
10579 procedure Analyze_Abstract_State
10581 Pack_Id
: Entity_Id
);
10582 -- Verify the legality of a single state declaration. Create and
10583 -- decorate a state abstraction entity and introduce it into the
10584 -- visibility chain. Pack_Id denotes the entity or the related
10585 -- package where pragma Abstract_State appears.
10587 procedure Malformed_State_Error
(State
: Node_Id
);
10588 -- Emit an error concerning the illegal declaration of abstract
10589 -- state State. This routine diagnoses syntax errors that lead to
10590 -- a different parse tree. The error is issued regardless of the
10591 -- SPARK mode in effect.
10593 ----------------------------
10594 -- Analyze_Abstract_State --
10595 ----------------------------
10597 procedure Analyze_Abstract_State
10599 Pack_Id
: Entity_Id
)
10601 -- Flags used to verify the consistency of options
10603 AR_Seen
: Boolean := False;
10604 AW_Seen
: Boolean := False;
10605 ER_Seen
: Boolean := False;
10606 EW_Seen
: Boolean := False;
10607 External_Seen
: Boolean := False;
10608 Ghost_Seen
: Boolean := False;
10609 Others_Seen
: Boolean := False;
10610 Part_Of_Seen
: Boolean := False;
10611 Synchronous_Seen
: Boolean := False;
10613 -- Flags used to store the static value of all external states'
10616 AR_Val
: Boolean := False;
10617 AW_Val
: Boolean := False;
10618 ER_Val
: Boolean := False;
10619 EW_Val
: Boolean := False;
10621 State_Id
: Entity_Id
:= Empty
;
10622 -- The entity to be generated for the current state declaration
10624 procedure Analyze_External_Option
(Opt
: Node_Id
);
10625 -- Verify the legality of option External
10627 procedure Analyze_External_Property
10629 Expr
: Node_Id
:= Empty
);
10630 -- Verify the legailty of a single external property. Prop
10631 -- denotes the external property. Expr is the expression used
10632 -- to set the property.
10634 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10635 -- Verify the legality of option Part_Of
10637 procedure Check_Duplicate_Option
10639 Status
: in out Boolean);
10640 -- Flag Status denotes whether a particular option has been
10641 -- seen while processing a state. This routine verifies that
10642 -- Opt is not a duplicate option and sets the flag Status
10643 -- (SPARK RM 7.1.4(1)).
10645 procedure Check_Duplicate_Property
10647 Status
: in out Boolean);
10648 -- Flag Status denotes whether a particular property has been
10649 -- seen while processing option External. This routine verifies
10650 -- that Prop is not a duplicate property and sets flag Status.
10651 -- Opt is not a duplicate property and sets the flag Status.
10652 -- (SPARK RM 7.1.4(2))
10654 procedure Check_Ghost_Synchronous
;
10655 -- Ensure that the abstract state is not subject to both Ghost
10656 -- and Synchronous simple options. Emit an error if this is the
10659 procedure Create_Abstract_State
10663 Is_Null
: Boolean);
10664 -- Generate an abstract state entity with name Nam and enter it
10665 -- into visibility. Decl is the "declaration" of the state as
10666 -- it appears in pragma Abstract_State. Loc is the location of
10667 -- the related state "declaration". Flag Is_Null should be set
10668 -- when the associated Abstract_State pragma defines a null
10671 -----------------------------
10672 -- Analyze_External_Option --
10673 -----------------------------
10675 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10676 Errors
: constant Nat
:= Serious_Errors_Detected
;
10678 Props
: Node_Id
:= Empty
;
10681 if Nkind
(Opt
) = N_Component_Association
then
10682 Props
:= Expression
(Opt
);
10685 -- External state with properties
10687 if Present
(Props
) then
10689 -- Multiple properties appear as an aggregate
10691 if Nkind
(Props
) = N_Aggregate
then
10693 -- Simple property form
10695 Prop
:= First
(Expressions
(Props
));
10696 while Present
(Prop
) loop
10697 Analyze_External_Property
(Prop
);
10701 -- Property with expression form
10703 Prop
:= First
(Component_Associations
(Props
));
10704 while Present
(Prop
) loop
10705 Analyze_External_Property
10706 (Prop
=> First
(Choices
(Prop
)),
10707 Expr
=> Expression
(Prop
));
10715 Analyze_External_Property
(Props
);
10718 -- An external state defined without any properties defaults
10719 -- all properties to True.
10728 -- Once all external properties have been processed, verify
10729 -- their mutual interaction. Do not perform the check when
10730 -- at least one of the properties is illegal as this will
10731 -- produce a bogus error.
10733 if Errors
= Serious_Errors_Detected
then
10734 Check_External_Properties
10735 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10737 end Analyze_External_Option
;
10739 -------------------------------
10740 -- Analyze_External_Property --
10741 -------------------------------
10743 procedure Analyze_External_Property
10745 Expr
: Node_Id
:= Empty
)
10747 Expr_Val
: Boolean;
10750 -- Check the placement of "others" (if available)
10752 if Nkind
(Prop
) = N_Others_Choice
then
10753 if Others_Seen
then
10755 ("only one others choice allowed in option External",
10758 Others_Seen
:= True;
10761 elsif Others_Seen
then
10763 ("others must be the last property in option External",
10766 -- The only remaining legal options are the four predefined
10767 -- external properties.
10769 elsif Nkind
(Prop
) = N_Identifier
10770 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10771 Name_Async_Writers
,
10772 Name_Effective_Reads
,
10773 Name_Effective_Writes
)
10777 -- Otherwise the construct is not a valid property
10780 SPARK_Msg_N
("invalid external state property", Prop
);
10784 -- Ensure that the expression of the external state property
10785 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10787 if Present
(Expr
) then
10788 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10790 if Is_OK_Static_Expression
(Expr
) then
10791 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10794 ("expression of external state property must be "
10798 -- The lack of expression defaults the property to True
10804 -- Named properties
10806 if Nkind
(Prop
) = N_Identifier
then
10807 if Chars
(Prop
) = Name_Async_Readers
then
10808 Check_Duplicate_Property
(Prop
, AR_Seen
);
10809 AR_Val
:= Expr_Val
;
10811 elsif Chars
(Prop
) = Name_Async_Writers
then
10812 Check_Duplicate_Property
(Prop
, AW_Seen
);
10813 AW_Val
:= Expr_Val
;
10815 elsif Chars
(Prop
) = Name_Effective_Reads
then
10816 Check_Duplicate_Property
(Prop
, ER_Seen
);
10817 ER_Val
:= Expr_Val
;
10820 Check_Duplicate_Property
(Prop
, EW_Seen
);
10821 EW_Val
:= Expr_Val
;
10824 -- The handling of property "others" must take into account
10825 -- all other named properties that have been encountered so
10826 -- far. Only those that have not been seen are affected by
10830 if not AR_Seen
then
10831 AR_Val
:= Expr_Val
;
10834 if not AW_Seen
then
10835 AW_Val
:= Expr_Val
;
10838 if not ER_Seen
then
10839 ER_Val
:= Expr_Val
;
10842 if not EW_Seen
then
10843 EW_Val
:= Expr_Val
;
10846 end Analyze_External_Property
;
10848 ----------------------------
10849 -- Analyze_Part_Of_Option --
10850 ----------------------------
10852 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10853 Encap
: constant Node_Id
:= Expression
(Opt
);
10854 Constits
: Elist_Id
;
10855 Encap_Id
: Entity_Id
;
10859 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10862 (Indic
=> First
(Choices
(Opt
)),
10863 Item_Id
=> State_Id
,
10865 Encap_Id
=> Encap_Id
,
10868 -- The Part_Of indicator transforms the abstract state into
10869 -- a constituent of the encapsulating state or single
10870 -- concurrent type.
10873 pragma Assert
(Present
(Encap_Id
));
10874 Constits
:= Part_Of_Constituents
(Encap_Id
);
10876 if No
(Constits
) then
10877 Constits
:= New_Elmt_List
;
10878 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
10881 Append_Elmt
(State_Id
, Constits
);
10882 Set_Encapsulating_State
(State_Id
, Encap_Id
);
10884 end Analyze_Part_Of_Option
;
10886 ----------------------------
10887 -- Check_Duplicate_Option --
10888 ----------------------------
10890 procedure Check_Duplicate_Option
10892 Status
: in out Boolean)
10896 SPARK_Msg_N
("duplicate state option", Opt
);
10900 end Check_Duplicate_Option
;
10902 ------------------------------
10903 -- Check_Duplicate_Property --
10904 ------------------------------
10906 procedure Check_Duplicate_Property
10908 Status
: in out Boolean)
10912 SPARK_Msg_N
("duplicate external property", Prop
);
10916 end Check_Duplicate_Property
;
10918 -----------------------------
10919 -- Check_Ghost_Synchronous --
10920 -----------------------------
10922 procedure Check_Ghost_Synchronous
is
10924 -- A synchronized abstract state cannot be Ghost and vice
10925 -- versa (SPARK RM 6.9(19)).
10927 if Ghost_Seen
and Synchronous_Seen
then
10928 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
10930 end Check_Ghost_Synchronous
;
10932 ---------------------------
10933 -- Create_Abstract_State --
10934 ---------------------------
10936 procedure Create_Abstract_State
10943 -- The abstract state may be semi-declared when the related
10944 -- package was withed through a limited with clause. In that
10945 -- case reuse the entity to fully declare the state.
10947 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10948 State_Id
:= Entity
(Decl
);
10950 -- Otherwise the elaboration of pragma Abstract_State
10951 -- declares the state.
10954 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10956 if Present
(Decl
) then
10957 Set_Entity
(Decl
, State_Id
);
10961 -- Null states never come from source
10963 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10964 Set_Parent
(State_Id
, State
);
10965 Set_Ekind
(State_Id
, E_Abstract_State
);
10966 Set_Etype
(State_Id
, Standard_Void_Type
);
10967 Set_Encapsulating_State
(State_Id
, Empty
);
10969 -- An abstract state declared within a Ghost region becomes
10970 -- Ghost (SPARK RM 6.9(2)).
10972 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
10973 Set_Is_Ghost_Entity
(State_Id
);
10976 -- Establish a link between the state declaration and the
10977 -- abstract state entity. Note that a null state remains as
10978 -- N_Null and does not carry any linkages.
10980 if not Is_Null
then
10981 if Present
(Decl
) then
10982 Set_Entity
(Decl
, State_Id
);
10983 Set_Etype
(Decl
, Standard_Void_Type
);
10986 -- Every non-null state must be defined, nameable and
10989 Push_Scope
(Pack_Id
);
10990 Generate_Definition
(State_Id
);
10991 Enter_Name
(State_Id
);
10994 end Create_Abstract_State
;
11001 -- Start of processing for Analyze_Abstract_State
11004 -- A package with a null abstract state is not allowed to
11005 -- declare additional states.
11009 ("package & has null abstract state", State
, Pack_Id
);
11011 -- Null states appear as internally generated entities
11013 elsif Nkind
(State
) = N_Null
then
11014 Create_Abstract_State
11015 (Nam
=> New_Internal_Name
('S'),
11017 Loc
=> Sloc
(State
),
11021 -- Catch a case where a null state appears in a list of
11022 -- non-null states.
11024 if Non_Null_Seen
then
11026 ("package & has non-null abstract state",
11030 -- Simple state declaration
11032 elsif Nkind
(State
) = N_Identifier
then
11033 Create_Abstract_State
11034 (Nam
=> Chars
(State
),
11036 Loc
=> Sloc
(State
),
11038 Non_Null_Seen
:= True;
11040 -- State declaration with various options. This construct
11041 -- appears as an extension aggregate in the tree.
11043 elsif Nkind
(State
) = N_Extension_Aggregate
then
11044 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11045 Create_Abstract_State
11046 (Nam
=> Chars
(Ancestor_Part
(State
)),
11047 Decl
=> Ancestor_Part
(State
),
11048 Loc
=> Sloc
(Ancestor_Part
(State
)),
11050 Non_Null_Seen
:= True;
11053 ("state name must be an identifier",
11054 Ancestor_Part
(State
));
11057 -- Options External, Ghost and Synchronous appear as
11060 Opt
:= First
(Expressions
(State
));
11061 while Present
(Opt
) loop
11062 if Nkind
(Opt
) = N_Identifier
then
11066 if Chars
(Opt
) = Name_External
then
11067 Check_Duplicate_Option
(Opt
, External_Seen
);
11068 Analyze_External_Option
(Opt
);
11072 elsif Chars
(Opt
) = Name_Ghost
then
11073 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11074 Check_Ghost_Synchronous
;
11076 if Present
(State_Id
) then
11077 Set_Is_Ghost_Entity
(State_Id
);
11082 elsif Chars
(Opt
) = Name_Synchronous
then
11083 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11084 Check_Ghost_Synchronous
;
11086 -- Option Part_Of without an encapsulating state is
11087 -- illegal (SPARK RM 7.1.4(9)).
11089 elsif Chars
(Opt
) = Name_Part_Of
then
11091 ("indicator Part_Of must denote abstract state, "
11092 & "single protected type or single task type",
11095 -- Do not emit an error message when a previous state
11096 -- declaration with options was not parenthesized as
11097 -- the option is actually another state declaration.
11099 -- with Abstract_State
11100 -- (State_1 with ..., -- missing parentheses
11101 -- (State_2 with ...),
11102 -- State_3) -- ok state declaration
11104 elsif Missing_Parentheses
then
11107 -- Otherwise the option is not allowed. Note that it
11108 -- is not possible to distinguish between an option
11109 -- and a state declaration when a previous state with
11110 -- options not properly parentheses.
11112 -- with Abstract_State
11113 -- (State_1 with ..., -- missing parentheses
11114 -- State_2); -- could be an option
11118 ("simple option not allowed in state declaration",
11122 -- Catch a case where missing parentheses around a state
11123 -- declaration with options cause a subsequent state
11124 -- declaration with options to be treated as an option.
11126 -- with Abstract_State
11127 -- (State_1 with ..., -- missing parentheses
11128 -- (State_2 with ...))
11130 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11131 Missing_Parentheses
:= True;
11133 ("state declaration must be parenthesized",
11134 Ancestor_Part
(State
));
11136 -- Otherwise the option is malformed
11139 SPARK_Msg_N
("malformed option", Opt
);
11145 -- Options External and Part_Of appear as component
11148 Opt
:= First
(Component_Associations
(State
));
11149 while Present
(Opt
) loop
11150 Opt_Nam
:= First
(Choices
(Opt
));
11152 if Nkind
(Opt_Nam
) = N_Identifier
then
11153 if Chars
(Opt_Nam
) = Name_External
then
11154 Analyze_External_Option
(Opt
);
11156 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11157 Analyze_Part_Of_Option
(Opt
);
11160 SPARK_Msg_N
("invalid state option", Opt
);
11163 SPARK_Msg_N
("invalid state option", Opt
);
11169 -- Any other attempt to declare a state is illegal
11172 Malformed_State_Error
(State
);
11176 -- Guard against a junk state. In such cases no entity is
11177 -- generated and the subsequent checks cannot be applied.
11179 if Present
(State_Id
) then
11181 -- Verify whether the state does not introduce an illegal
11182 -- hidden state within a package subject to a null abstract
11185 Check_No_Hidden_State
(State_Id
);
11187 -- Check whether the lack of option Part_Of agrees with the
11188 -- placement of the abstract state with respect to the state
11191 if not Part_Of_Seen
then
11192 Check_Missing_Part_Of
(State_Id
);
11195 -- Associate the state with its related package
11197 if No
(Abstract_States
(Pack_Id
)) then
11198 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11201 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11203 end Analyze_Abstract_State
;
11205 ---------------------------
11206 -- Malformed_State_Error --
11207 ---------------------------
11209 procedure Malformed_State_Error
(State
: Node_Id
) is
11211 Error_Msg_N
("malformed abstract state declaration", State
);
11213 -- An abstract state with a simple option is being declared
11214 -- with "=>" rather than the legal "with". The state appears
11215 -- as a component association.
11217 if Nkind
(State
) = N_Component_Association
then
11218 Error_Msg_N
("\use WITH to specify simple option", State
);
11220 end Malformed_State_Error
;
11224 Pack_Decl
: Node_Id
;
11225 Pack_Id
: Entity_Id
;
11229 -- Start of processing for Abstract_State
11233 Check_No_Identifiers
;
11234 Check_Arg_Count
(1);
11236 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11238 -- Ensure the proper placement of the pragma. Abstract states must
11239 -- be associated with a package declaration.
11241 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11242 N_Package_Declaration
)
11246 -- Otherwise the pragma is associated with an illegal construct
11253 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11255 -- Chain the pragma on the contract for completeness
11257 Add_Contract_Item
(N
, Pack_Id
);
11259 -- The legality checks of pragmas Abstract_State, Initializes, and
11260 -- Initial_Condition are affected by the SPARK mode in effect. In
11261 -- addition, these three pragmas are subject to an inherent order:
11263 -- 1) Abstract_State
11265 -- 3) Initial_Condition
11267 -- Analyze all these pragmas in the order outlined above
11269 Analyze_If_Present
(Pragma_SPARK_Mode
);
11271 -- A pragma that applies to a Ghost entity becomes Ghost for the
11272 -- purposes of legality checks and removal of ignored Ghost code.
11274 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
11275 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11277 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11279 -- Multiple non-null abstract states appear as an aggregate
11281 if Nkind
(States
) = N_Aggregate
then
11282 State
:= First
(Expressions
(States
));
11283 while Present
(State
) loop
11284 Analyze_Abstract_State
(State
, Pack_Id
);
11288 -- An abstract state with a simple option is being illegaly
11289 -- declared with "=>" rather than "with". In this case the
11290 -- state declaration appears as a component association.
11292 if Present
(Component_Associations
(States
)) then
11293 State
:= First
(Component_Associations
(States
));
11294 while Present
(State
) loop
11295 Malformed_State_Error
(State
);
11300 -- Various forms of a single abstract state. Note that these may
11301 -- include malformed state declarations.
11304 Analyze_Abstract_State
(States
, Pack_Id
);
11307 Analyze_If_Present
(Pragma_Initializes
);
11308 Analyze_If_Present
(Pragma_Initial_Condition
);
11309 end Abstract_State
;
11317 -- Note: this pragma also has some specific processing in Par.Prag
11318 -- because we want to set the Ada version mode during parsing.
11320 when Pragma_Ada_83
=>
11322 Check_Arg_Count
(0);
11324 -- We really should check unconditionally for proper configuration
11325 -- pragma placement, since we really don't want mixed Ada modes
11326 -- within a single unit, and the GNAT reference manual has always
11327 -- said this was a configuration pragma, but we did not check and
11328 -- are hesitant to add the check now.
11330 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11331 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11332 -- or Ada 2012 mode.
11334 if Ada_Version
>= Ada_2005
then
11335 Check_Valid_Configuration_Pragma
;
11338 -- Now set Ada 83 mode
11340 if not Latest_Ada_Only
then
11341 Ada_Version
:= Ada_83
;
11342 Ada_Version_Explicit
:= Ada_83
;
11343 Ada_Version_Pragma
:= N
;
11352 -- Note: this pragma also has some specific processing in Par.Prag
11353 -- because we want to set the Ada 83 version mode during parsing.
11355 when Pragma_Ada_95
=>
11357 Check_Arg_Count
(0);
11359 -- We really should check unconditionally for proper configuration
11360 -- pragma placement, since we really don't want mixed Ada modes
11361 -- within a single unit, and the GNAT reference manual has always
11362 -- said this was a configuration pragma, but we did not check and
11363 -- are hesitant to add the check now.
11365 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11366 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11368 if Ada_Version
>= Ada_2005
then
11369 Check_Valid_Configuration_Pragma
;
11372 -- Now set Ada 95 mode
11374 if not Latest_Ada_Only
then
11375 Ada_Version
:= Ada_95
;
11376 Ada_Version_Explicit
:= Ada_95
;
11377 Ada_Version_Pragma
:= N
;
11380 ---------------------
11381 -- Ada_05/Ada_2005 --
11382 ---------------------
11385 -- pragma Ada_05 (LOCAL_NAME);
11387 -- pragma Ada_2005;
11388 -- pragma Ada_2005 (LOCAL_NAME):
11390 -- Note: these pragmas also have some specific processing in Par.Prag
11391 -- because we want to set the Ada 2005 version mode during parsing.
11393 -- The one argument form is used for managing the transition from
11394 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11395 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11396 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11397 -- mode, a preference rule is established which does not choose
11398 -- such an entity unless it is unambiguously specified. This avoids
11399 -- extra subprograms marked this way from generating ambiguities in
11400 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11401 -- intended for exclusive use in the GNAT run-time library.
11403 when Pragma_Ada_05 | Pragma_Ada_2005
=> declare
11409 if Arg_Count
= 1 then
11410 Check_Arg_Is_Local_Name
(Arg1
);
11411 E_Id
:= Get_Pragma_Arg
(Arg1
);
11413 if Etype
(E_Id
) = Any_Type
then
11417 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
11418 Record_Rep_Item
(Entity
(E_Id
), N
);
11421 Check_Arg_Count
(0);
11423 -- For Ada_2005 we unconditionally enforce the documented
11424 -- configuration pragma placement, since we do not want to
11425 -- tolerate mixed modes in a unit involving Ada 2005. That
11426 -- would cause real difficulties for those cases where there
11427 -- are incompatibilities between Ada 95 and Ada 2005.
11429 Check_Valid_Configuration_Pragma
;
11431 -- Now set appropriate Ada mode
11433 if not Latest_Ada_Only
then
11434 Ada_Version
:= Ada_2005
;
11435 Ada_Version_Explicit
:= Ada_2005
;
11436 Ada_Version_Pragma
:= N
;
11441 ---------------------
11442 -- Ada_12/Ada_2012 --
11443 ---------------------
11446 -- pragma Ada_12 (LOCAL_NAME);
11448 -- pragma Ada_2012;
11449 -- pragma Ada_2012 (LOCAL_NAME):
11451 -- Note: these pragmas also have some specific processing in Par.Prag
11452 -- because we want to set the Ada 2012 version mode during parsing.
11454 -- The one argument form is used for managing the transition from Ada
11455 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11456 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11457 -- mode will generate a warning. In addition, in any pre-Ada_2012
11458 -- mode, a preference rule is established which does not choose
11459 -- such an entity unless it is unambiguously specified. This avoids
11460 -- extra subprograms marked this way from generating ambiguities in
11461 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11462 -- intended for exclusive use in the GNAT run-time library.
11464 when Pragma_Ada_12 | Pragma_Ada_2012
=> declare
11470 if Arg_Count
= 1 then
11471 Check_Arg_Is_Local_Name
(Arg1
);
11472 E_Id
:= Get_Pragma_Arg
(Arg1
);
11474 if Etype
(E_Id
) = Any_Type
then
11478 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
11479 Record_Rep_Item
(Entity
(E_Id
), N
);
11482 Check_Arg_Count
(0);
11484 -- For Ada_2012 we unconditionally enforce the documented
11485 -- configuration pragma placement, since we do not want to
11486 -- tolerate mixed modes in a unit involving Ada 2012. That
11487 -- would cause real difficulties for those cases where there
11488 -- are incompatibilities between Ada 95 and Ada 2012. We could
11489 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11491 Check_Valid_Configuration_Pragma
;
11493 -- Now set appropriate Ada mode
11495 Ada_Version
:= Ada_2012
;
11496 Ada_Version_Explicit
:= Ada_2012
;
11497 Ada_Version_Pragma
:= N
;
11501 ----------------------
11502 -- All_Calls_Remote --
11503 ----------------------
11505 -- pragma All_Calls_Remote [(library_package_NAME)];
11507 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
11508 Lib_Entity
: Entity_Id
;
11511 Check_Ada_83_Warning
;
11512 Check_Valid_Library_Unit_Pragma
;
11514 if Nkind
(N
) = N_Null_Statement
then
11518 Lib_Entity
:= Find_Lib_Unit_Name
;
11520 -- A pragma that applies to a Ghost entity becomes Ghost for the
11521 -- purposes of legality checks and removal of ignored Ghost code.
11523 Mark_Pragma_As_Ghost
(N
, Lib_Entity
);
11525 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11527 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
11528 if not Is_Remote_Call_Interface
(Lib_Entity
) then
11529 Error_Pragma
("pragma% only apply to rci unit");
11531 -- Set flag for entity of the library unit
11534 Set_Has_All_Calls_Remote
(Lib_Entity
);
11537 end All_Calls_Remote
;
11539 ---------------------------
11540 -- Allow_Integer_Address --
11541 ---------------------------
11543 -- pragma Allow_Integer_Address;
11545 when Pragma_Allow_Integer_Address
=>
11547 Check_Valid_Configuration_Pragma
;
11548 Check_Arg_Count
(0);
11550 -- If Address is a private type, then set the flag to allow
11551 -- integer address values. If Address is not private, then this
11552 -- pragma has no purpose, so it is simply ignored. Not clear if
11553 -- there are any such targets now.
11555 if Opt
.Address_Is_Private
then
11556 Opt
.Allow_Integer_Address
:= True;
11564 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11565 -- ARG ::= NAME | EXPRESSION
11567 -- The first two arguments are by convention intended to refer to an
11568 -- external tool and a tool-specific function. These arguments are
11571 when Pragma_Annotate
=> Annotate
: declare
11578 Check_At_Least_N_Arguments
(1);
11580 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
11582 -- Determine whether the last argument is "Entity => local_NAME"
11583 -- and if it is, perform the required semantic checks. Remove the
11584 -- argument from further processing.
11586 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
11587 and then Chars
(Nam_Arg
) = Name_Entity
11589 Check_Arg_Is_Local_Name
(Nam_Arg
);
11590 Arg_Count
:= Arg_Count
- 1;
11592 -- A pragma that applies to a Ghost entity becomes Ghost for
11593 -- the purposes of legality checks and removal of ignored Ghost
11596 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
11597 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
11599 Mark_Pragma_As_Ghost
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
11602 -- Not allowed in compiler units (bootstrap issues)
11604 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
11607 -- Continue the processing with last argument removed for now
11609 Check_Arg_Is_Identifier
(Arg1
);
11610 Check_No_Identifiers
;
11613 -- The second parameter is optional, it is never analyzed
11618 -- Otherwise there is a second parameter
11621 -- The second parameter must be an identifier
11623 Check_Arg_Is_Identifier
(Arg2
);
11625 -- Process the remaining parameters (if any)
11627 Arg
:= Next
(Arg2
);
11628 while Present
(Arg
) loop
11629 Expr
:= Get_Pragma_Arg
(Arg
);
11632 if Is_Entity_Name
(Expr
) then
11635 -- For string literals, we assume Standard_String as the
11636 -- type, unless the string contains wide or wide_wide
11639 elsif Nkind
(Expr
) = N_String_Literal
then
11640 if Has_Wide_Wide_Character
(Expr
) then
11641 Resolve
(Expr
, Standard_Wide_Wide_String
);
11642 elsif Has_Wide_Character
(Expr
) then
11643 Resolve
(Expr
, Standard_Wide_String
);
11645 Resolve
(Expr
, Standard_String
);
11648 elsif Is_Overloaded
(Expr
) then
11649 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
11660 -------------------------------------------------
11661 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11662 -------------------------------------------------
11665 -- ( [Check => ] Boolean_EXPRESSION
11666 -- [, [Message =>] Static_String_EXPRESSION]);
11668 -- pragma Assert_And_Cut
11669 -- ( [Check => ] Boolean_EXPRESSION
11670 -- [, [Message =>] Static_String_EXPRESSION]);
11673 -- ( [Check => ] Boolean_EXPRESSION
11674 -- [, [Message =>] Static_String_EXPRESSION]);
11676 -- pragma Loop_Invariant
11677 -- ( [Check => ] Boolean_EXPRESSION
11678 -- [, [Message =>] Static_String_EXPRESSION]);
11680 when Pragma_Assert |
11681 Pragma_Assert_And_Cut |
11683 Pragma_Loop_Invariant
=>
11685 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
11686 -- Determine whether expression Expr contains a Loop_Entry
11687 -- attribute reference.
11689 -------------------------
11690 -- Contains_Loop_Entry --
11691 -------------------------
11693 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
11694 Has_Loop_Entry
: Boolean := False;
11696 function Process
(N
: Node_Id
) return Traverse_Result
;
11697 -- Process function for traversal to look for Loop_Entry
11703 function Process
(N
: Node_Id
) return Traverse_Result
is
11705 if Nkind
(N
) = N_Attribute_Reference
11706 and then Attribute_Name
(N
) = Name_Loop_Entry
11708 Has_Loop_Entry
:= True;
11715 procedure Traverse
is new Traverse_Proc
(Process
);
11717 -- Start of processing for Contains_Loop_Entry
11721 return Has_Loop_Entry
;
11722 end Contains_Loop_Entry
;
11727 New_Args
: List_Id
;
11729 -- Start of processing for Assert
11732 -- Assert is an Ada 2005 RM-defined pragma
11734 if Prag_Id
= Pragma_Assert
then
11737 -- The remaining ones are GNAT pragmas
11743 Check_At_Least_N_Arguments
(1);
11744 Check_At_Most_N_Arguments
(2);
11745 Check_Arg_Order
((Name_Check
, Name_Message
));
11746 Check_Optional_Identifier
(Arg1
, Name_Check
);
11747 Expr
:= Get_Pragma_Arg
(Arg1
);
11749 -- Special processing for Loop_Invariant, Loop_Variant or for
11750 -- other cases where a Loop_Entry attribute is present. If the
11751 -- assertion pragma contains attribute Loop_Entry, ensure that
11752 -- the related pragma is within a loop.
11754 if Prag_Id
= Pragma_Loop_Invariant
11755 or else Prag_Id
= Pragma_Loop_Variant
11756 or else Contains_Loop_Entry
(Expr
)
11758 Check_Loop_Pragma_Placement
;
11760 -- Perform preanalysis to deal with embedded Loop_Entry
11763 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
11766 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11767 -- a corresponding Check pragma:
11769 -- pragma Check (name, condition [, msg]);
11771 -- Where name is the identifier matching the pragma name. So
11772 -- rewrite pragma in this manner, transfer the message argument
11773 -- if present, and analyze the result
11775 -- Note: When dealing with a semantically analyzed tree, the
11776 -- information that a Check node N corresponds to a source Assert,
11777 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11778 -- pragma kind of Original_Node(N).
11780 New_Args
:= New_List
(
11781 Make_Pragma_Argument_Association
(Loc
,
11782 Expression
=> Make_Identifier
(Loc
, Pname
)),
11783 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11784 Expression
=> Expr
));
11786 if Arg_Count
> 1 then
11787 Check_Optional_Identifier
(Arg2
, Name_Message
);
11789 -- Provide semantic annnotations for optional argument, for
11790 -- ASIS use, before rewriting.
11792 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11793 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
11796 -- Rewrite as Check pragma
11800 Chars
=> Name_Check
,
11801 Pragma_Argument_Associations
=> New_Args
));
11806 ----------------------
11807 -- Assertion_Policy --
11808 ----------------------
11810 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11812 -- The following form is Ada 2012 only, but we allow it in all modes
11814 -- Pragma Assertion_Policy (
11815 -- ASSERTION_KIND => POLICY_IDENTIFIER
11816 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11818 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11820 -- RM_ASSERTION_KIND ::= Assert |
11821 -- Static_Predicate |
11822 -- Dynamic_Predicate |
11827 -- Type_Invariant |
11828 -- Type_Invariant'Class
11830 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11832 -- Contract_Cases |
11834 -- Default_Initial_Condition |
11836 -- Initial_Condition |
11837 -- Loop_Invariant |
11843 -- Statement_Assertions
11845 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11846 -- ID_ASSERTION_KIND list contains implementation-defined additions
11847 -- recognized by GNAT. The effect is to control the behavior of
11848 -- identically named aspects and pragmas, depending on the specified
11849 -- policy identifier:
11851 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore
11853 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11854 -- implementation-defined addition that results in totally ignoring
11855 -- the corresponding assertion. If Disable is specified, then the
11856 -- argument of the assertion is not even analyzed. This is useful
11857 -- when the aspect/pragma argument references entities in a with'ed
11858 -- package that is replaced by a dummy package in the final build.
11860 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11861 -- and Type_Invariant'Class were recognized by the parser and
11862 -- transformed into references to the special internal identifiers
11863 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11864 -- processing is required here.
11866 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11875 -- This can always appear as a configuration pragma
11877 if Is_Configuration_Pragma
then
11880 -- It can also appear in a declarative part or package spec in Ada
11881 -- 2012 mode. We allow this in other modes, but in that case we
11882 -- consider that we have an Ada 2012 pragma on our hands.
11885 Check_Is_In_Decl_Part_Or_Package_Spec
;
11889 -- One argument case with no identifier (first form above)
11892 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11893 or else Chars
(Arg1
) = No_Name
)
11895 Check_Arg_Is_One_Of
11896 (Arg1
, Name_Check
, Name_Disable
, Name_Ignore
);
11898 -- Treat one argument Assertion_Policy as equivalent to:
11900 -- pragma Check_Policy (Assertion, policy)
11902 -- So rewrite pragma in that manner and link on to the chain
11903 -- of Check_Policy pragmas, marking the pragma as analyzed.
11905 Policy
:= Get_Pragma_Arg
(Arg1
);
11909 Chars
=> Name_Check_Policy
,
11910 Pragma_Argument_Associations
=> New_List
(
11911 Make_Pragma_Argument_Association
(Loc
,
11912 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11914 Make_Pragma_Argument_Association
(Loc
,
11916 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11919 -- Here if we have two or more arguments
11922 Check_At_Least_N_Arguments
(1);
11925 -- Loop through arguments
11928 while Present
(Arg
) loop
11929 LocP
:= Sloc
(Arg
);
11931 -- Kind must be specified
11933 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11934 or else Chars
(Arg
) = No_Name
11937 ("missing assertion kind for pragma%", Arg
);
11940 -- Check Kind and Policy have allowed forms
11942 Kind
:= Chars
(Arg
);
11943 Policy
:= Get_Pragma_Arg
(Arg
);
11945 if not Is_Valid_Assertion_Kind
(Kind
) then
11947 ("invalid assertion kind for pragma%", Arg
);
11950 Check_Arg_Is_One_Of
11951 (Arg
, Name_Check
, Name_Disable
, Name_Ignore
);
11953 if Kind
= Name_Ghost
then
11955 -- The Ghost policy must be either Check or Ignore
11956 -- (SPARK RM 6.9(6)).
11958 if not Nam_In
(Chars
(Policy
), Name_Check
,
11962 ("argument of pragma % Ghost must be Check or "
11963 & "Ignore", Policy
);
11966 -- Pragma Assertion_Policy specifying a Ghost policy
11967 -- cannot occur within a Ghost subprogram or package
11968 -- (SPARK RM 6.9(14)).
11970 if Ghost_Mode
> None
then
11972 ("pragma % cannot appear within ghost subprogram or "
11977 -- Rewrite the Assertion_Policy pragma as a series of
11978 -- Check_Policy pragmas of the form:
11980 -- Check_Policy (Kind, Policy);
11982 -- Note: the insertion of the pragmas cannot be done with
11983 -- Insert_Action because in the configuration case, there
11984 -- are no scopes on the scope stack and the mechanism will
11987 Insert_Before_And_Analyze
(N
,
11989 Chars
=> Name_Check_Policy
,
11990 Pragma_Argument_Associations
=> New_List
(
11991 Make_Pragma_Argument_Association
(LocP
,
11992 Expression
=> Make_Identifier
(LocP
, Kind
)),
11993 Make_Pragma_Argument_Association
(LocP
,
11994 Expression
=> Policy
))));
11999 -- Rewrite the Assertion_Policy pragma as null since we have
12000 -- now inserted all the equivalent Check pragmas.
12002 Rewrite
(N
, Make_Null_Statement
(Loc
));
12005 end Assertion_Policy
;
12007 ------------------------------
12008 -- Assume_No_Invalid_Values --
12009 ------------------------------
12011 -- pragma Assume_No_Invalid_Values (On | Off);
12013 when Pragma_Assume_No_Invalid_Values
=>
12015 Check_Valid_Configuration_Pragma
;
12016 Check_Arg_Count
(1);
12017 Check_No_Identifiers
;
12018 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12020 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12021 Assume_No_Invalid_Values
:= True;
12023 Assume_No_Invalid_Values
:= False;
12026 --------------------------
12027 -- Attribute_Definition --
12028 --------------------------
12030 -- pragma Attribute_Definition
12031 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12032 -- [Entity =>] LOCAL_NAME,
12033 -- [Expression =>] EXPRESSION | NAME);
12035 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12036 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12041 Check_Arg_Count
(3);
12042 Check_Optional_Identifier
(Arg1
, "attribute");
12043 Check_Optional_Identifier
(Arg2
, "entity");
12044 Check_Optional_Identifier
(Arg3
, "expression");
12046 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12047 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12051 Check_Arg_Is_Local_Name
(Arg2
);
12053 -- If the attribute is not recognized, then issue a warning (not
12054 -- an error), and ignore the pragma.
12056 Aname
:= Chars
(Attribute_Designator
);
12058 if not Is_Attribute_Name
(Aname
) then
12059 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12063 -- Otherwise, rewrite the pragma as an attribute definition clause
12066 Make_Attribute_Definition_Clause
(Loc
,
12067 Name
=> Get_Pragma_Arg
(Arg2
),
12069 Expression
=> Get_Pragma_Arg
(Arg3
)));
12071 end Attribute_Definition
;
12073 ------------------------------------------------------------------
12074 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12075 ------------------------------------------------------------------
12077 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12078 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12079 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12080 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12082 when Pragma_Async_Readers |
12083 Pragma_Async_Writers |
12084 Pragma_Effective_Reads |
12085 Pragma_Effective_Writes
=>
12086 Async_Effective
: declare
12087 Obj_Decl
: Node_Id
;
12088 Obj_Id
: Entity_Id
;
12092 Check_No_Identifiers
;
12093 Check_At_Most_N_Arguments
(1);
12095 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12097 -- Object declaration
12099 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12102 -- Otherwise the pragma is associated with an illegal construact
12109 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12111 -- Perform minimal verification to ensure that the argument is at
12112 -- least a variable. Subsequent finer grained checks will be done
12113 -- at the end of the declarative region the contains the pragma.
12115 if Ekind
(Obj_Id
) = E_Variable
then
12117 -- Chain the pragma on the contract for further processing by
12118 -- Analyze_External_Property_In_Decl_Part.
12120 Add_Contract_Item
(N
, Obj_Id
);
12122 -- A pragma that applies to a Ghost entity becomes Ghost for
12123 -- the purposes of legality checks and removal of ignored Ghost
12126 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
12128 -- Analyze the Boolean expression (if any)
12130 if Present
(Arg1
) then
12131 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12134 -- Otherwise the external property applies to a constant
12137 Error_Pragma
("pragma % must apply to a volatile object");
12139 end Async_Effective
;
12145 -- pragma Asynchronous (LOCAL_NAME);
12147 when Pragma_Asynchronous
=> Asynchronous
: declare
12150 Formal
: Entity_Id
;
12155 procedure Process_Async_Pragma
;
12156 -- Common processing for procedure and access-to-procedure case
12158 --------------------------
12159 -- Process_Async_Pragma --
12160 --------------------------
12162 procedure Process_Async_Pragma
is
12165 Set_Is_Asynchronous
(Nm
);
12169 -- The formals should be of mode IN (RM E.4.1(6))
12172 while Present
(S
) loop
12173 Formal
:= Defining_Identifier
(S
);
12175 if Nkind
(Formal
) = N_Defining_Identifier
12176 and then Ekind
(Formal
) /= E_In_Parameter
12179 ("pragma% procedure can only have IN parameter",
12186 Set_Is_Asynchronous
(Nm
);
12187 end Process_Async_Pragma
;
12189 -- Start of processing for pragma Asynchronous
12192 Check_Ada_83_Warning
;
12193 Check_No_Identifiers
;
12194 Check_Arg_Count
(1);
12195 Check_Arg_Is_Local_Name
(Arg1
);
12197 if Debug_Flag_U
then
12201 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12202 Analyze
(Get_Pragma_Arg
(Arg1
));
12203 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12205 -- A pragma that applies to a Ghost entity becomes Ghost for the
12206 -- purposes of legality checks and removal of ignored Ghost code.
12208 Mark_Pragma_As_Ghost
(N
, Nm
);
12210 if not Is_Remote_Call_Interface
(C_Ent
)
12211 and then not Is_Remote_Types
(C_Ent
)
12213 -- This pragma should only appear in an RCI or Remote Types
12214 -- unit (RM E.4.1(4)).
12217 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12220 if Ekind
(Nm
) = E_Procedure
12221 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12223 if not Is_Remote_Call_Interface
(Nm
) then
12225 ("pragma% cannot be applied on non-remote procedure",
12229 L
:= Parameter_Specifications
(Parent
(Nm
));
12230 Process_Async_Pragma
;
12233 elsif Ekind
(Nm
) = E_Function
then
12235 ("pragma% cannot be applied to function", Arg1
);
12237 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12238 if Is_Record_Type
(Nm
) then
12240 -- A record type that is the Equivalent_Type for a remote
12241 -- access-to-subprogram type.
12243 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
12246 -- A non-expanded RAS type (distribution is not enabled)
12248 Decl
:= Declaration_Node
(Nm
);
12251 if Nkind
(Decl
) = N_Full_Type_Declaration
12252 and then Nkind
(Type_Definition
(Decl
)) =
12253 N_Access_Procedure_Definition
12255 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
12256 Process_Async_Pragma
;
12258 if Is_Asynchronous
(Nm
)
12259 and then Expander_Active
12260 and then Get_PCS_Name
/= Name_No_DSA
12262 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
12267 ("pragma% cannot reference access-to-function type",
12271 -- Only other possibility is Access-to-class-wide type
12273 elsif Is_Access_Type
(Nm
)
12274 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
12276 Check_First_Subtype
(Arg1
);
12277 Set_Is_Asynchronous
(Nm
);
12278 if Expander_Active
then
12279 RACW_Type_Is_Asynchronous
(Nm
);
12283 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12291 -- pragma Atomic (LOCAL_NAME);
12293 when Pragma_Atomic
=>
12294 Process_Atomic_Independent_Shared_Volatile
;
12296 -----------------------
12297 -- Atomic_Components --
12298 -----------------------
12300 -- pragma Atomic_Components (array_LOCAL_NAME);
12302 -- This processing is shared by Volatile_Components
12304 when Pragma_Atomic_Components |
12305 Pragma_Volatile_Components
=>
12306 Atomic_Components
: declare
12313 Check_Ada_83_Warning
;
12314 Check_No_Identifiers
;
12315 Check_Arg_Count
(1);
12316 Check_Arg_Is_Local_Name
(Arg1
);
12317 E_Id
:= Get_Pragma_Arg
(Arg1
);
12319 if Etype
(E_Id
) = Any_Type
then
12323 E
:= Entity
(E_Id
);
12325 -- A pragma that applies to a Ghost entity becomes Ghost for the
12326 -- purposes of legality checks and removal of ignored Ghost code.
12328 Mark_Pragma_As_Ghost
(N
, E
);
12329 Check_Duplicate_Pragma
(E
);
12331 if Rep_Item_Too_Early
(E
, N
)
12333 Rep_Item_Too_Late
(E
, N
)
12338 D
:= Declaration_Node
(E
);
12341 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
12343 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
12344 and then Nkind
(D
) = N_Object_Declaration
12345 and then Nkind
(Object_Definition
(D
)) =
12346 N_Constrained_Array_Definition
)
12348 -- The flag is set on the object, or on the base type
12350 if Nkind
(D
) /= N_Object_Declaration
then
12351 E
:= Base_Type
(E
);
12354 -- Atomic implies both Independent and Volatile
12356 if Prag_Id
= Pragma_Atomic_Components
then
12357 Set_Has_Atomic_Components
(E
);
12358 Set_Has_Independent_Components
(E
);
12361 Set_Has_Volatile_Components
(E
);
12364 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
12366 end Atomic_Components
;
12368 --------------------
12369 -- Attach_Handler --
12370 --------------------
12372 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12374 when Pragma_Attach_Handler
=>
12375 Check_Ada_83_Warning
;
12376 Check_No_Identifiers
;
12377 Check_Arg_Count
(2);
12379 if No_Run_Time_Mode
then
12380 Error_Msg_CRT
("Attach_Handler pragma", N
);
12382 Check_Interrupt_Or_Attach_Handler
;
12384 -- The expression that designates the attribute may depend on a
12385 -- discriminant, and is therefore a per-object expression, to
12386 -- be expanded in the init proc. If expansion is enabled, then
12387 -- perform semantic checks on a copy only.
12392 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
12395 -- In Relaxed_RM_Semantics mode, we allow any static
12396 -- integer value, for compatibility with other compilers.
12398 if Relaxed_RM_Semantics
12399 and then Nkind
(Parg2
) = N_Integer_Literal
12401 Typ
:= Standard_Integer
;
12403 Typ
:= RTE
(RE_Interrupt_ID
);
12406 if Expander_Active
then
12407 Temp
:= New_Copy_Tree
(Parg2
);
12408 Set_Parent
(Temp
, N
);
12409 Preanalyze_And_Resolve
(Temp
, Typ
);
12412 Resolve
(Parg2
, Typ
);
12416 Process_Interrupt_Or_Attach_Handler
;
12419 --------------------
12420 -- C_Pass_By_Copy --
12421 --------------------
12423 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12425 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
12431 Check_Valid_Configuration_Pragma
;
12432 Check_Arg_Count
(1);
12433 Check_Optional_Identifier
(Arg1
, "max_size");
12435 Arg
:= Get_Pragma_Arg
(Arg1
);
12436 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
12438 Val
:= Expr_Value
(Arg
);
12442 ("maximum size for pragma% must be positive", Arg1
);
12444 elsif UI_Is_In_Int_Range
(Val
) then
12445 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
12447 -- If a giant value is given, Int'Last will do well enough.
12448 -- If sometime someone complains that a record larger than
12449 -- two gigabytes is not copied, we will worry about it then.
12452 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
12454 end C_Pass_By_Copy
;
12460 -- pragma Check ([Name =>] CHECK_KIND,
12461 -- [Check =>] Boolean_EXPRESSION
12462 -- [,[Message =>] String_EXPRESSION]);
12464 -- CHECK_KIND ::= IDENTIFIER |
12467 -- Invariant'Class |
12468 -- Type_Invariant'Class
12470 -- The identifiers Assertions and Statement_Assertions are not
12471 -- allowed, since they have special meaning for Check_Policy.
12473 when Pragma_Check
=> Check
: declare
12479 Save_Ghost_Mode
: constant Ghost_Mode_Type
:= Ghost_Mode
;
12482 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12483 -- the mode now to ensure that any nodes generated during analysis
12484 -- and expansion are marked as Ghost.
12486 Set_Ghost_Mode
(N
);
12489 Check_At_Least_N_Arguments
(2);
12490 Check_At_Most_N_Arguments
(3);
12491 Check_Optional_Identifier
(Arg1
, Name_Name
);
12492 Check_Optional_Identifier
(Arg2
, Name_Check
);
12494 if Arg_Count
= 3 then
12495 Check_Optional_Identifier
(Arg3
, Name_Message
);
12496 Str
:= Get_Pragma_Arg
(Arg3
);
12499 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
12500 Check_Arg_Is_Identifier
(Arg1
);
12501 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
12503 -- Check forbidden name Assertions or Statement_Assertions
12506 when Name_Assertions
=>
12508 ("""Assertions"" is not allowed as a check kind for "
12509 & "pragma%", Arg1
);
12511 when Name_Statement_Assertions
=>
12513 ("""Statement_Assertions"" is not allowed as a check kind "
12514 & "for pragma%", Arg1
);
12520 -- Check applicable policy. We skip this if Checked/Ignored status
12521 -- is already set (e.g. in the case of a pragma from an aspect).
12523 if Is_Checked
(N
) or else Is_Ignored
(N
) then
12526 -- For a non-source pragma that is a rewriting of another pragma,
12527 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12529 elsif Is_Rewrite_Substitution
(N
)
12530 and then Nkind
(Original_Node
(N
)) = N_Pragma
12531 and then Original_Node
(N
) /= N
12533 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12534 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12536 -- Otherwise query the applicable policy at this point
12539 case Check_Kind
(Cname
) is
12540 when Name_Ignore
=>
12541 Set_Is_Ignored
(N
, True);
12542 Set_Is_Checked
(N
, False);
12545 Set_Is_Ignored
(N
, False);
12546 Set_Is_Checked
(N
, True);
12548 -- For disable, rewrite pragma as null statement and skip
12549 -- rest of the analysis of the pragma.
12551 when Name_Disable
=>
12552 Rewrite
(N
, Make_Null_Statement
(Loc
));
12556 -- No other possibilities
12559 raise Program_Error
;
12563 -- If check kind was not Disable, then continue pragma analysis
12565 Expr
:= Get_Pragma_Arg
(Arg2
);
12567 -- Deal with SCO generation
12571 -- Nothing to do for predicates as the checks occur in the
12572 -- client units. The SCO for the aspect in the declaration
12573 -- unit is conservatively always enabled.
12575 when Name_Predicate
=>
12578 -- Otherwise mark aspect/pragma SCO as enabled
12581 if Is_Checked
(N
) and then not Split_PPC
(N
) then
12582 Set_SCO_Pragma_Enabled
(Loc
);
12586 -- Deal with analyzing the string argument
12588 if Arg_Count
= 3 then
12590 -- If checks are not on we don't want any expansion (since
12591 -- such expansion would not get properly deleted) but
12592 -- we do want to analyze (to get proper references).
12593 -- The Preanalyze_And_Resolve routine does just what we want
12595 if Is_Ignored
(N
) then
12596 Preanalyze_And_Resolve
(Str
, Standard_String
);
12598 -- Otherwise we need a proper analysis and expansion
12601 Analyze_And_Resolve
(Str
, Standard_String
);
12605 -- Now you might think we could just do the same with the Boolean
12606 -- expression if checks are off (and expansion is on) and then
12607 -- rewrite the check as a null statement. This would work but we
12608 -- would lose the useful warnings about an assertion being bound
12609 -- to fail even if assertions are turned off.
12611 -- So instead we wrap the boolean expression in an if statement
12612 -- that looks like:
12614 -- if False and then condition then
12618 -- The reason we do this rewriting during semantic analysis rather
12619 -- than as part of normal expansion is that we cannot analyze and
12620 -- expand the code for the boolean expression directly, or it may
12621 -- cause insertion of actions that would escape the attempt to
12622 -- suppress the check code.
12624 -- Note that the Sloc for the if statement corresponds to the
12625 -- argument condition, not the pragma itself. The reason for
12626 -- this is that we may generate a warning if the condition is
12627 -- False at compile time, and we do not want to delete this
12628 -- warning when we delete the if statement.
12630 if Expander_Active
and Is_Ignored
(N
) then
12631 Eloc
:= Sloc
(Expr
);
12634 Make_If_Statement
(Eloc
,
12636 Make_And_Then
(Eloc
,
12637 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
12638 Right_Opnd
=> Expr
),
12639 Then_Statements
=> New_List
(
12640 Make_Null_Statement
(Eloc
))));
12642 -- Now go ahead and analyze the if statement
12644 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12646 -- One rather special treatment. If we are now in Eliminated
12647 -- overflow mode, then suppress overflow checking since we do
12648 -- not want to drag in the bignum stuff if we are in Ignore
12649 -- mode anyway. This is particularly important if we are using
12650 -- a configurable run time that does not support bignum ops.
12652 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
12654 Svo
: constant Boolean :=
12655 Scope_Suppress
.Suppress
(Overflow_Check
);
12657 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
12658 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
12660 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
12661 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
12664 -- Not that special case
12670 -- All done with this check
12672 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12674 -- Check is active or expansion not active. In these cases we can
12675 -- just go ahead and analyze the boolean with no worries.
12678 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12679 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12680 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12683 Ghost_Mode
:= Save_Ghost_Mode
;
12686 --------------------------
12687 -- Check_Float_Overflow --
12688 --------------------------
12690 -- pragma Check_Float_Overflow;
12692 when Pragma_Check_Float_Overflow
=>
12694 Check_Valid_Configuration_Pragma
;
12695 Check_Arg_Count
(0);
12696 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
12702 -- pragma Check_Name (check_IDENTIFIER);
12704 when Pragma_Check_Name
=>
12706 Check_No_Identifiers
;
12707 Check_Valid_Configuration_Pragma
;
12708 Check_Arg_Count
(1);
12709 Check_Arg_Is_Identifier
(Arg1
);
12712 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12715 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12716 if Check_Names
.Table
(J
) = Nam
then
12721 Check_Names
.Append
(Nam
);
12728 -- This is the old style syntax, which is still allowed in all modes:
12730 -- pragma Check_Policy ([Name =>] CHECK_KIND
12731 -- [Policy =>] POLICY_IDENTIFIER);
12733 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12735 -- CHECK_KIND ::= IDENTIFIER |
12738 -- Type_Invariant'Class |
12741 -- This is the new style syntax, compatible with Assertion_Policy
12742 -- and also allowed in all modes.
12744 -- Pragma Check_Policy (
12745 -- CHECK_KIND => POLICY_IDENTIFIER
12746 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12748 -- Note: the identifiers Name and Policy are not allowed as
12749 -- Check_Kind values. This avoids ambiguities between the old and
12750 -- new form syntax.
12752 when Pragma_Check_Policy
=> Check_Policy
: declare
12757 Check_At_Least_N_Arguments
(1);
12759 -- A Check_Policy pragma can appear either as a configuration
12760 -- pragma, or in a declarative part or a package spec (see RM
12761 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12762 -- followed for Check_Policy).
12764 if not Is_Configuration_Pragma
then
12765 Check_Is_In_Decl_Part_Or_Package_Spec
;
12768 -- Figure out if we have the old or new syntax. We have the
12769 -- old syntax if the first argument has no identifier, or the
12770 -- identifier is Name.
12772 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12773 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12777 Check_Arg_Count
(2);
12778 Check_Optional_Identifier
(Arg1
, Name_Name
);
12779 Kind
:= Get_Pragma_Arg
(Arg1
);
12780 Rewrite_Assertion_Kind
(Kind
);
12781 Check_Arg_Is_Identifier
(Arg1
);
12783 -- Check forbidden check kind
12785 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12786 Error_Msg_Name_2
:= Chars
(Kind
);
12788 ("pragma% does not allow% as check name", Arg1
);
12793 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12794 Check_Arg_Is_One_Of
12796 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12798 -- And chain pragma on the Check_Policy_List for search
12800 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12801 Opt
.Check_Policy_List
:= N
;
12803 -- For the new syntax, what we do is to convert each argument to
12804 -- an old syntax equivalent. We do that because we want to chain
12805 -- old style Check_Policy pragmas for the search (we don't want
12806 -- to have to deal with multiple arguments in the search).
12817 while Present
(Arg
) loop
12818 LocP
:= Sloc
(Arg
);
12819 Argx
:= Get_Pragma_Arg
(Arg
);
12821 -- Kind must be specified
12823 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12824 or else Chars
(Arg
) = No_Name
12827 ("missing assertion kind for pragma%", Arg
);
12830 -- Construct equivalent old form syntax Check_Policy
12831 -- pragma and insert it to get remaining checks.
12835 Chars
=> Name_Check_Policy
,
12836 Pragma_Argument_Associations
=> New_List
(
12837 Make_Pragma_Argument_Association
(LocP
,
12839 Make_Identifier
(LocP
, Chars
(Arg
))),
12840 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12841 Expression
=> Argx
)));
12845 -- For a configuration pragma, insert old form in
12846 -- the corresponding file.
12848 if Is_Configuration_Pragma
then
12849 Insert_After
(N
, New_P
);
12853 Insert_Action
(N
, New_P
);
12857 -- Rewrite original Check_Policy pragma to null, since we
12858 -- have converted it into a series of old syntax pragmas.
12860 Rewrite
(N
, Make_Null_Statement
(Loc
));
12870 -- pragma Comment (static_string_EXPRESSION)
12872 -- Processing for pragma Comment shares the circuitry for pragma
12873 -- Ident. The only differences are that Ident enforces a limit of 31
12874 -- characters on its argument, and also enforces limitations on
12875 -- placement for DEC compatibility. Pragma Comment shares neither of
12876 -- these restrictions.
12878 -------------------
12879 -- Common_Object --
12880 -------------------
12882 -- pragma Common_Object (
12883 -- [Internal =>] LOCAL_NAME
12884 -- [, [External =>] EXTERNAL_SYMBOL]
12885 -- [, [Size =>] EXTERNAL_SYMBOL]);
12887 -- Processing for this pragma is shared with Psect_Object
12889 ------------------------
12890 -- Compile_Time_Error --
12891 ------------------------
12893 -- pragma Compile_Time_Error
12894 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12896 when Pragma_Compile_Time_Error
=>
12898 Process_Compile_Time_Warning_Or_Error
;
12900 --------------------------
12901 -- Compile_Time_Warning --
12902 --------------------------
12904 -- pragma Compile_Time_Warning
12905 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12907 when Pragma_Compile_Time_Warning
=>
12909 Process_Compile_Time_Warning_Or_Error
;
12911 ---------------------------
12912 -- Compiler_Unit_Warning --
12913 ---------------------------
12915 -- pragma Compiler_Unit_Warning;
12919 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12920 -- errors not warnings. This means that we had introduced a big extra
12921 -- inertia to compiler changes, since even if we implemented a new
12922 -- feature, and even if all versions to be used for bootstrapping
12923 -- implemented this new feature, we could not use it, since old
12924 -- compilers would give errors for using this feature in units
12925 -- having Compiler_Unit pragmas.
12927 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12928 -- problem. We no longer have any units mentioning Compiler_Unit,
12929 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12930 -- and thus generates a warning which can be ignored. So that deals
12931 -- with the problem of old compilers not implementing the newer form
12934 -- Newer compilers recognize the new pragma, but generate warning
12935 -- messages instead of errors, which again can be ignored in the
12936 -- case of an old compiler which implements a wanted new feature
12937 -- but at the time felt like warning about it for older compilers.
12939 -- We retain Compiler_Unit so that new compilers can be used to build
12940 -- older run-times that use this pragma. That's an unusual case, but
12941 -- it's easy enough to handle, so why not?
12943 when Pragma_Compiler_Unit | Pragma_Compiler_Unit_Warning
=>
12945 Check_Arg_Count
(0);
12947 -- Only recognized in main unit
12949 if Current_Sem_Unit
= Main_Unit
then
12950 Compiler_Unit
:= True;
12953 -----------------------------
12954 -- Complete_Representation --
12955 -----------------------------
12957 -- pragma Complete_Representation;
12959 when Pragma_Complete_Representation
=>
12961 Check_Arg_Count
(0);
12963 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
12965 ("pragma & must appear within record representation clause");
12968 ----------------------------
12969 -- Complex_Representation --
12970 ----------------------------
12972 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
12974 when Pragma_Complex_Representation
=> Complex_Representation
: declare
12981 Check_Arg_Count
(1);
12982 Check_Optional_Identifier
(Arg1
, Name_Entity
);
12983 Check_Arg_Is_Local_Name
(Arg1
);
12984 E_Id
:= Get_Pragma_Arg
(Arg1
);
12986 if Etype
(E_Id
) = Any_Type
then
12990 E
:= Entity
(E_Id
);
12992 if not Is_Record_Type
(E
) then
12994 ("argument for pragma% must be record type", Arg1
);
12997 Ent
:= First_Entity
(E
);
13000 or else No
(Next_Entity
(Ent
))
13001 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13002 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13003 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13006 ("record for pragma% must have two fields of the same "
13007 & "floating-point type", Arg1
);
13010 Set_Has_Complex_Representation
(Base_Type
(E
));
13012 -- We need to treat the type has having a non-standard
13013 -- representation, for back-end purposes, even though in
13014 -- general a complex will have the default representation
13015 -- of a record with two real components.
13017 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13019 end Complex_Representation
;
13021 -------------------------
13022 -- Component_Alignment --
13023 -------------------------
13025 -- pragma Component_Alignment (
13026 -- [Form =>] ALIGNMENT_CHOICE
13027 -- [, [Name =>] type_LOCAL_NAME]);
13029 -- ALIGNMENT_CHOICE ::=
13031 -- | Component_Size_4
13035 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13036 Args
: Args_List
(1 .. 2);
13037 Names
: constant Name_List
(1 .. 2) := (
13041 Form
: Node_Id
renames Args
(1);
13042 Name
: Node_Id
renames Args
(2);
13044 Atype
: Component_Alignment_Kind
;
13049 Gather_Associations
(Names
, Args
);
13052 Error_Pragma
("missing Form argument for pragma%");
13055 Check_Arg_Is_Identifier
(Form
);
13057 -- Get proper alignment, note that Default = Component_Size on all
13058 -- machines we have so far, and we want to set this value rather
13059 -- than the default value to indicate that it has been explicitly
13060 -- set (and thus will not get overridden by the default component
13061 -- alignment for the current scope)
13063 if Chars
(Form
) = Name_Component_Size
then
13064 Atype
:= Calign_Component_Size
;
13066 elsif Chars
(Form
) = Name_Component_Size_4
then
13067 Atype
:= Calign_Component_Size_4
;
13069 elsif Chars
(Form
) = Name_Default
then
13070 Atype
:= Calign_Component_Size
;
13072 elsif Chars
(Form
) = Name_Storage_Unit
then
13073 Atype
:= Calign_Storage_Unit
;
13077 ("invalid Form parameter for pragma%", Form
);
13080 -- The pragma appears in a configuration file
13082 if No
(Parent
(N
)) then
13083 Check_Valid_Configuration_Pragma
;
13085 -- Capture the component alignment in a global variable when
13086 -- the pragma appears in a configuration file. Note that the
13087 -- scope stack is empty at this point and cannot be used to
13088 -- store the alignment value.
13090 Configuration_Component_Alignment
:= Atype
;
13092 -- Case with no name, supplied, affects scope table entry
13094 elsif No
(Name
) then
13096 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13098 -- Case of name supplied
13101 Check_Arg_Is_Local_Name
(Name
);
13103 Typ
:= Entity
(Name
);
13106 or else Rep_Item_Too_Early
(Typ
, N
)
13110 Typ
:= Underlying_Type
(Typ
);
13113 if not Is_Record_Type
(Typ
)
13114 and then not Is_Array_Type
(Typ
)
13117 ("Name parameter of pragma% must identify record or "
13118 & "array type", Name
);
13121 -- An explicit Component_Alignment pragma overrides an
13122 -- implicit pragma Pack, but not an explicit one.
13124 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13125 Set_Is_Packed
(Base_Type
(Typ
), False);
13126 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13129 end Component_AlignmentP
;
13131 --------------------------------
13132 -- Constant_After_Elaboration --
13133 --------------------------------
13135 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13137 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13139 Obj_Decl
: Node_Id
;
13140 Obj_Id
: Entity_Id
;
13144 Check_No_Identifiers
;
13145 Check_At_Most_N_Arguments
(1);
13147 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13149 -- Object declaration
13151 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
13154 -- Otherwise the pragma is associated with an illegal construct
13161 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13163 -- The object declaration must be a library-level variable which
13164 -- is either explicitly initialized or obtains a value during the
13165 -- elaboration of a package body (SPARK RM 3.3.1).
13167 if Ekind
(Obj_Id
) = E_Variable
then
13168 if not Is_Library_Level_Entity
(Obj_Id
) then
13170 ("pragma % must apply to a library level variable");
13174 -- Otherwise the pragma applies to a constant, which is illegal
13177 Error_Pragma
("pragma % must apply to a variable declaration");
13181 -- Chain the pragma on the contract for completeness
13183 Add_Contract_Item
(N
, Obj_Id
);
13185 -- A pragma that applies to a Ghost entity becomes Ghost for the
13186 -- purposes of legality checks and removal of ignored Ghost code.
13188 Mark_Pragma_As_Ghost
(N
, Obj_Id
);
13190 -- Analyze the Boolean expression (if any)
13192 if Present
(Arg1
) then
13193 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13195 end Constant_After_Elaboration
;
13197 --------------------
13198 -- Contract_Cases --
13199 --------------------
13201 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13203 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13205 -- CASE_GUARD ::= boolean_EXPRESSION | others
13207 -- CONSEQUENCE ::= boolean_EXPRESSION
13209 -- Characteristics:
13211 -- * Analysis - The annotation undergoes initial checks to verify
13212 -- the legal placement and context. Secondary checks preanalyze the
13215 -- Analyze_Contract_Cases_In_Decl_Part
13217 -- * Expansion - The annotation is expanded during the expansion of
13218 -- the related subprogram [body] contract as performed in:
13220 -- Expand_Subprogram_Contract
13222 -- * Template - The annotation utilizes the generic template of the
13223 -- related subprogram [body] when it is:
13225 -- aspect on subprogram declaration
13226 -- aspect on stand alone subprogram body
13227 -- pragma on stand alone subprogram body
13229 -- The annotation must prepare its own template when it is:
13231 -- pragma on subprogram declaration
13233 -- * Globals - Capture of global references must occur after full
13236 -- * Instance - The annotation is instantiated automatically when
13237 -- the related generic subprogram [body] is instantiated except for
13238 -- the "pragma on subprogram declaration" case. In that scenario
13239 -- the annotation must instantiate itself.
13241 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13242 Spec_Id
: Entity_Id
;
13243 Subp_Decl
: Node_Id
;
13247 Check_No_Identifiers
;
13248 Check_Arg_Count
(1);
13250 -- Ensure the proper placement of the pragma. Contract_Cases must
13251 -- be associated with a subprogram declaration or a body that acts
13255 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13259 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13262 -- Generic subprogram
13264 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13267 -- Body acts as spec
13269 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13270 and then No
(Corresponding_Spec
(Subp_Decl
))
13274 -- Body stub acts as spec
13276 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13277 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13283 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13291 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13293 -- Chain the pragma on the contract for further processing by
13294 -- Analyze_Contract_Cases_In_Decl_Part.
13296 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13298 -- A pragma that applies to a Ghost entity becomes Ghost for the
13299 -- purposes of legality checks and removal of ignored Ghost code.
13301 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
13302 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13304 -- Fully analyze the pragma when it appears inside an entry
13305 -- or subprogram body because it cannot benefit from forward
13308 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13310 N_Subprogram_Body_Stub
)
13312 -- The legality checks of pragma Contract_Cases are affected by
13313 -- the SPARK mode in effect and the volatility of the context.
13314 -- Analyze all pragmas in a specific order.
13316 Analyze_If_Present
(Pragma_SPARK_Mode
);
13317 Analyze_If_Present
(Pragma_Volatile_Function
);
13318 Analyze_Contract_Cases_In_Decl_Part
(N
);
13320 end Contract_Cases
;
13326 -- pragma Controlled (first_subtype_LOCAL_NAME);
13328 when Pragma_Controlled
=> Controlled
: declare
13332 Check_No_Identifiers
;
13333 Check_Arg_Count
(1);
13334 Check_Arg_Is_Local_Name
(Arg1
);
13335 Arg
:= Get_Pragma_Arg
(Arg1
);
13337 if not Is_Entity_Name
(Arg
)
13338 or else not Is_Access_Type
(Entity
(Arg
))
13340 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
13342 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
13350 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13351 -- [Entity =>] LOCAL_NAME);
13353 when Pragma_Convention
=> Convention
: declare
13356 pragma Warnings
(Off
, C
);
13357 pragma Warnings
(Off
, E
);
13359 Check_Arg_Order
((Name_Convention
, Name_Entity
));
13360 Check_Ada_83_Warning
;
13361 Check_Arg_Count
(2);
13362 Process_Convention
(C
, E
);
13364 -- A pragma that applies to a Ghost entity becomes Ghost for the
13365 -- purposes of legality checks and removal of ignored Ghost code.
13367 Mark_Pragma_As_Ghost
(N
, E
);
13370 ---------------------------
13371 -- Convention_Identifier --
13372 ---------------------------
13374 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13375 -- [Convention =>] convention_IDENTIFIER);
13377 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
13383 Check_Arg_Order
((Name_Name
, Name_Convention
));
13384 Check_Arg_Count
(2);
13385 Check_Optional_Identifier
(Arg1
, Name_Name
);
13386 Check_Optional_Identifier
(Arg2
, Name_Convention
);
13387 Check_Arg_Is_Identifier
(Arg1
);
13388 Check_Arg_Is_Identifier
(Arg2
);
13389 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
13390 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
13392 if Is_Convention_Name
(Cname
) then
13393 Record_Convention_Identifier
13394 (Idnam
, Get_Convention_Id
(Cname
));
13397 ("second arg for % pragma must be convention", Arg2
);
13399 end Convention_Identifier
;
13405 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13407 when Pragma_CPP_Class
=> CPP_Class
: declare
13411 if Warn_On_Obsolescent_Feature
then
13413 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13414 & "effect; replace it by pragma import?j?", N
);
13417 Check_Arg_Count
(1);
13421 Chars
=> Name_Import
,
13422 Pragma_Argument_Associations
=> New_List
(
13423 Make_Pragma_Argument_Association
(Loc
,
13424 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
13425 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
13429 ---------------------
13430 -- CPP_Constructor --
13431 ---------------------
13433 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13434 -- [, [External_Name =>] static_string_EXPRESSION ]
13435 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13437 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
13440 Def_Id
: Entity_Id
;
13441 Tag_Typ
: Entity_Id
;
13445 Check_At_Least_N_Arguments
(1);
13446 Check_At_Most_N_Arguments
(3);
13447 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13448 Check_Arg_Is_Local_Name
(Arg1
);
13450 Id
:= Get_Pragma_Arg
(Arg1
);
13451 Find_Program_Unit_Name
(Id
);
13453 -- If we did not find the name, we are done
13455 if Etype
(Id
) = Any_Type
then
13459 Def_Id
:= Entity
(Id
);
13461 -- Check if already defined as constructor
13463 if Is_Constructor
(Def_Id
) then
13465 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
13469 if Ekind
(Def_Id
) = E_Function
13470 and then (Is_CPP_Class
(Etype
(Def_Id
))
13471 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
13473 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
13475 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
13477 ("'C'P'P constructor must be defined in the scope of "
13478 & "its returned type", Arg1
);
13481 if Arg_Count
>= 2 then
13482 Set_Imported
(Def_Id
);
13483 Set_Is_Public
(Def_Id
);
13484 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
13487 Set_Has_Completion
(Def_Id
);
13488 Set_Is_Constructor
(Def_Id
);
13489 Set_Convention
(Def_Id
, Convention_CPP
);
13491 -- Imported C++ constructors are not dispatching primitives
13492 -- because in C++ they don't have a dispatch table slot.
13493 -- However, in Ada the constructor has the profile of a
13494 -- function that returns a tagged type and therefore it has
13495 -- been treated as a primitive operation during semantic
13496 -- analysis. We now remove it from the list of primitive
13497 -- operations of the type.
13499 if Is_Tagged_Type
(Etype
(Def_Id
))
13500 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
13501 and then Is_Dispatching_Operation
(Def_Id
)
13503 Tag_Typ
:= Etype
(Def_Id
);
13505 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
13506 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
13510 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
13511 Set_Is_Dispatching_Operation
(Def_Id
, False);
13514 -- For backward compatibility, if the constructor returns a
13515 -- class wide type, and we internally change the return type to
13516 -- the corresponding root type.
13518 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
13519 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
13523 ("pragma% requires function returning a 'C'P'P_Class type",
13526 end CPP_Constructor
;
13532 when Pragma_CPP_Virtual
=> CPP_Virtual
: declare
13536 if Warn_On_Obsolescent_Feature
then
13538 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13547 when Pragma_CPP_Vtable
=> CPP_Vtable
: declare
13551 if Warn_On_Obsolescent_Feature
then
13553 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13562 -- pragma CPU (EXPRESSION);
13564 when Pragma_CPU
=> CPU
: declare
13565 P
: constant Node_Id
:= Parent
(N
);
13571 Check_No_Identifiers
;
13572 Check_Arg_Count
(1);
13576 if Nkind
(P
) = N_Subprogram_Body
then
13577 Check_In_Main_Program
;
13579 Arg
:= Get_Pragma_Arg
(Arg1
);
13580 Analyze_And_Resolve
(Arg
, Any_Integer
);
13582 Ent
:= Defining_Unit_Name
(Specification
(P
));
13584 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
13585 Ent
:= Defining_Identifier
(Ent
);
13590 if not Is_OK_Static_Expression
(Arg
) then
13591 Flag_Non_Static_Expr
13592 ("main subprogram affinity is not static!", Arg
);
13595 -- If constraint error, then we already signalled an error
13597 elsif Raises_Constraint_Error
(Arg
) then
13600 -- Otherwise check in range
13604 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
13605 -- This is the entity System.Multiprocessors.CPU_Range;
13607 Val
: constant Uint
:= Expr_Value
(Arg
);
13610 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
13612 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
13615 ("main subprogram CPU is out of range", Arg1
);
13621 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
13625 elsif Nkind
(P
) = N_Task_Definition
then
13626 Arg
:= Get_Pragma_Arg
(Arg1
);
13627 Ent
:= Defining_Identifier
(Parent
(P
));
13629 -- The expression must be analyzed in the special manner
13630 -- described in "Handling of Default and Per-Object
13631 -- Expressions" in sem.ads.
13633 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
13635 -- Anything else is incorrect
13641 -- Check duplicate pragma before we chain the pragma in the Rep
13642 -- Item chain of Ent.
13644 Check_Duplicate_Pragma
(Ent
);
13645 Record_Rep_Item
(Ent
, N
);
13652 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13654 when Pragma_Debug
=> Debug
: declare
13661 -- The condition for executing the call is that the expander
13662 -- is active and that we are not ignoring this debug pragma.
13667 (Expander_Active
and then not Is_Ignored
(N
)),
13670 if not Is_Ignored
(N
) then
13671 Set_SCO_Pragma_Enabled
(Loc
);
13674 if Arg_Count
= 2 then
13676 Make_And_Then
(Loc
,
13677 Left_Opnd
=> Relocate_Node
(Cond
),
13678 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
13679 Call
:= Get_Pragma_Arg
(Arg2
);
13681 Call
:= Get_Pragma_Arg
(Arg1
);
13685 N_Indexed_Component
,
13689 N_Selected_Component
)
13691 -- If this pragma Debug comes from source, its argument was
13692 -- parsed as a name form (which is syntactically identical).
13693 -- In a generic context a parameterless call will be left as
13694 -- an expanded name (if global) or selected_component if local.
13695 -- Change it to a procedure call statement now.
13697 Change_Name_To_Procedure_Call_Statement
(Call
);
13699 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
13701 -- Already in the form of a procedure call statement: nothing
13702 -- to do (could happen in case of an internally generated
13708 -- All other cases: diagnose error
13711 ("argument of pragma ""Debug"" is not procedure call",
13716 -- Rewrite into a conditional with an appropriate condition. We
13717 -- wrap the procedure call in a block so that overhead from e.g.
13718 -- use of the secondary stack does not generate execution overhead
13719 -- for suppressed conditions.
13721 -- Normally the analysis that follows will freeze the subprogram
13722 -- being called. However, if the call is to a null procedure,
13723 -- we want to freeze it before creating the block, because the
13724 -- analysis that follows may be done with expansion disabled, in
13725 -- which case the body will not be generated, leading to spurious
13728 if Nkind
(Call
) = N_Procedure_Call_Statement
13729 and then Is_Entity_Name
(Name
(Call
))
13731 Analyze
(Name
(Call
));
13732 Freeze_Before
(N
, Entity
(Name
(Call
)));
13736 Make_Implicit_If_Statement
(N
,
13738 Then_Statements
=> New_List
(
13739 Make_Block_Statement
(Loc
,
13740 Handled_Statement_Sequence
=>
13741 Make_Handled_Sequence_Of_Statements
(Loc
,
13742 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13745 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13746 -- after analysis of the normally rewritten node, to capture all
13747 -- references to entities, which avoids issuing wrong warnings
13748 -- about unused entities.
13750 if GNATprove_Mode
then
13751 Rewrite
(N
, Make_Null_Statement
(Loc
));
13759 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13761 when Pragma_Debug_Policy
=>
13763 Check_Arg_Count
(1);
13764 Check_No_Identifiers
;
13765 Check_Arg_Is_Identifier
(Arg1
);
13767 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13768 -- rewrite it that way, and let the rest of the checking come
13769 -- from analyzing the rewritten pragma.
13773 Chars
=> Name_Check_Policy
,
13774 Pragma_Argument_Associations
=> New_List
(
13775 Make_Pragma_Argument_Association
(Loc
,
13776 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13778 Make_Pragma_Argument_Association
(Loc
,
13779 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13782 -------------------------------
13783 -- Default_Initial_Condition --
13784 -------------------------------
13786 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13788 when Pragma_Default_Initial_Condition
=> Default_Init_Cond
: declare
13795 Check_No_Identifiers
;
13796 Check_At_Most_N_Arguments
(1);
13799 while Present
(Stmt
) loop
13801 -- Skip prior pragmas, but check for duplicates
13803 if Nkind
(Stmt
) = N_Pragma
then
13804 if Pragma_Name
(Stmt
) = Pname
then
13805 Error_Msg_Name_1
:= Pname
;
13806 Error_Msg_Sloc
:= Sloc
(Stmt
);
13807 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13810 -- Skip internally generated code
13812 elsif not Comes_From_Source
(Stmt
) then
13815 -- The associated private type [extension] has been found, stop
13818 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
13819 N_Private_Type_Declaration
)
13821 Typ
:= Defining_Entity
(Stmt
);
13824 -- The pragma does not apply to a legal construct, issue an
13825 -- error and stop the analysis.
13832 Stmt
:= Prev
(Stmt
);
13835 -- A pragma that applies to a Ghost entity becomes Ghost for the
13836 -- purposes of legality checks and removal of ignored Ghost code.
13838 Mark_Pragma_As_Ghost
(N
, Typ
);
13839 Set_Has_Default_Init_Cond
(Typ
);
13840 Set_Has_Inherited_Default_Init_Cond
(Typ
, False);
13842 -- Chain the pragma on the rep item chain for further processing
13844 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13845 end Default_Init_Cond
;
13847 ----------------------------------
13848 -- Default_Scalar_Storage_Order --
13849 ----------------------------------
13851 -- pragma Default_Scalar_Storage_Order
13852 -- (High_Order_First | Low_Order_First);
13854 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
13855 Default
: Character;
13859 Check_Arg_Count
(1);
13861 -- Default_Scalar_Storage_Order can appear as a configuration
13862 -- pragma, or in a declarative part of a package spec.
13864 if not Is_Configuration_Pragma
then
13865 Check_Is_In_Decl_Part_Or_Package_Spec
;
13868 Check_No_Identifiers
;
13869 Check_Arg_Is_One_Of
13870 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
13871 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13872 Default
:= Fold_Upper
(Name_Buffer
(1));
13874 if not Support_Nondefault_SSO_On_Target
13875 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
13877 if Warn_On_Unrecognized_Pragma
then
13879 ("non-default Scalar_Storage_Order not supported "
13880 & "on target?g?", N
);
13882 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
13885 -- Here set the specified default
13888 Opt
.Default_SSO
:= Default
;
13892 --------------------------
13893 -- Default_Storage_Pool --
13894 --------------------------
13896 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13898 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
13903 Check_Arg_Count
(1);
13905 -- Default_Storage_Pool can appear as a configuration pragma, or
13906 -- in a declarative part of a package spec.
13908 if not Is_Configuration_Pragma
then
13909 Check_Is_In_Decl_Part_Or_Package_Spec
;
13912 if From_Aspect_Specification
(N
) then
13914 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
13916 if not In_Open_Scopes
(E
) then
13918 ("aspect must apply to package or subprogram", N
);
13923 if Present
(Arg1
) then
13924 Pool
:= Get_Pragma_Arg
(Arg1
);
13926 -- Case of Default_Storage_Pool (null);
13928 if Nkind
(Pool
) = N_Null
then
13931 -- This is an odd case, this is not really an expression,
13932 -- so we don't have a type for it. So just set the type to
13935 Set_Etype
(Pool
, Empty
);
13937 -- Case of Default_Storage_Pool (storage_pool_NAME);
13940 -- If it's a configuration pragma, then the only allowed
13941 -- argument is "null".
13943 if Is_Configuration_Pragma
then
13944 Error_Pragma_Arg
("NULL expected", Arg1
);
13947 -- The expected type for a non-"null" argument is
13948 -- Root_Storage_Pool'Class, and the pool must be a variable.
13950 Analyze_And_Resolve
13951 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13953 if Is_Variable
(Pool
) then
13955 -- A pragma that applies to a Ghost entity becomes Ghost
13956 -- for the purposes of legality checks and removal of
13957 -- ignored Ghost code.
13959 Mark_Pragma_As_Ghost
(N
, Entity
(Pool
));
13963 ("default storage pool must be a variable", Arg1
);
13967 -- Record the pool name (or null). Freeze.Freeze_Entity for an
13968 -- access type will use this information to set the appropriate
13969 -- attributes of the access type.
13971 Default_Pool
:= Pool
;
13973 end Default_Storage_Pool
;
13979 -- pragma Depends (DEPENDENCY_RELATION);
13981 -- DEPENDENCY_RELATION ::=
13983 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
13985 -- DEPENDENCY_CLAUSE ::=
13986 -- OUTPUT_LIST =>[+] INPUT_LIST
13987 -- | NULL_DEPENDENCY_CLAUSE
13989 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
13991 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
13993 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
13995 -- OUTPUT ::= NAME | FUNCTION_RESULT
13998 -- where FUNCTION_RESULT is a function Result attribute_reference
14000 -- Characteristics:
14002 -- * Analysis - The annotation undergoes initial checks to verify
14003 -- the legal placement and context. Secondary checks fully analyze
14004 -- the dependency clauses in:
14006 -- Analyze_Depends_In_Decl_Part
14008 -- * Expansion - None.
14010 -- * Template - The annotation utilizes the generic template of the
14011 -- related subprogram [body] when it is:
14013 -- aspect on subprogram declaration
14014 -- aspect on stand alone subprogram body
14015 -- pragma on stand alone subprogram body
14017 -- The annotation must prepare its own template when it is:
14019 -- pragma on subprogram declaration
14021 -- * Globals - Capture of global references must occur after full
14024 -- * Instance - The annotation is instantiated automatically when
14025 -- the related generic subprogram [body] is instantiated except for
14026 -- the "pragma on subprogram declaration" case. In that scenario
14027 -- the annotation must instantiate itself.
14029 when Pragma_Depends
=> Depends
: declare
14031 Spec_Id
: Entity_Id
;
14032 Subp_Decl
: Node_Id
;
14035 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14039 -- Chain the pragma on the contract for further processing by
14040 -- Analyze_Depends_In_Decl_Part.
14042 Add_Contract_Item
(N
, Spec_Id
);
14044 -- Fully analyze the pragma when it appears inside an entry
14045 -- or subprogram body because it cannot benefit from forward
14048 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14050 N_Subprogram_Body_Stub
)
14052 -- The legality checks of pragmas Depends and Global are
14053 -- affected by the SPARK mode in effect and the volatility
14054 -- of the context. In addition these two pragmas are subject
14055 -- to an inherent order:
14060 -- Analyze all these pragmas in the order outlined above
14062 Analyze_If_Present
(Pragma_SPARK_Mode
);
14063 Analyze_If_Present
(Pragma_Volatile_Function
);
14064 Analyze_If_Present
(Pragma_Global
);
14065 Analyze_Depends_In_Decl_Part
(N
);
14070 ---------------------
14071 -- Detect_Blocking --
14072 ---------------------
14074 -- pragma Detect_Blocking;
14076 when Pragma_Detect_Blocking
=>
14078 Check_Arg_Count
(0);
14079 Check_Valid_Configuration_Pragma
;
14080 Detect_Blocking
:= True;
14082 ------------------------------------
14083 -- Disable_Atomic_Synchronization --
14084 ------------------------------------
14086 -- pragma Disable_Atomic_Synchronization [(Entity)];
14088 when Pragma_Disable_Atomic_Synchronization
=>
14090 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14092 -------------------
14093 -- Discard_Names --
14094 -------------------
14096 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14098 when Pragma_Discard_Names
=> Discard_Names
: declare
14103 Check_Ada_83_Warning
;
14105 -- Deal with configuration pragma case
14107 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14108 Global_Discard_Names
:= True;
14111 -- Otherwise, check correct appropriate context
14114 Check_Is_In_Decl_Part_Or_Package_Spec
;
14116 if Arg_Count
= 0 then
14118 -- If there is no parameter, then from now on this pragma
14119 -- applies to any enumeration, exception or tagged type
14120 -- defined in the current declarative part, and recursively
14121 -- to any nested scope.
14123 Set_Discard_Names
(Current_Scope
);
14127 Check_Arg_Count
(1);
14128 Check_Optional_Identifier
(Arg1
, Name_On
);
14129 Check_Arg_Is_Local_Name
(Arg1
);
14131 E_Id
:= Get_Pragma_Arg
(Arg1
);
14133 if Etype
(E_Id
) = Any_Type
then
14136 E
:= Entity
(E_Id
);
14139 -- A pragma that applies to a Ghost entity becomes Ghost for
14140 -- the purposes of legality checks and removal of ignored
14143 Mark_Pragma_As_Ghost
(N
, E
);
14145 if (Is_First_Subtype
(E
)
14147 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14148 or else Ekind
(E
) = E_Exception
14150 Set_Discard_Names
(E
);
14151 Record_Rep_Item
(E
, N
);
14155 ("inappropriate entity for pragma%", Arg1
);
14161 ------------------------
14162 -- Dispatching_Domain --
14163 ------------------------
14165 -- pragma Dispatching_Domain (EXPRESSION);
14167 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14168 P
: constant Node_Id
:= Parent
(N
);
14174 Check_No_Identifiers
;
14175 Check_Arg_Count
(1);
14177 -- This pragma is born obsolete, but not the aspect
14179 if not From_Aspect_Specification
(N
) then
14181 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14184 if Nkind
(P
) = N_Task_Definition
then
14185 Arg
:= Get_Pragma_Arg
(Arg1
);
14186 Ent
:= Defining_Identifier
(Parent
(P
));
14188 -- A pragma that applies to a Ghost entity becomes Ghost for
14189 -- the purposes of legality checks and removal of ignored Ghost
14192 Mark_Pragma_As_Ghost
(N
, Ent
);
14194 -- The expression must be analyzed in the special manner
14195 -- described in "Handling of Default and Per-Object
14196 -- Expressions" in sem.ads.
14198 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14200 -- Check duplicate pragma before we chain the pragma in the Rep
14201 -- Item chain of Ent.
14203 Check_Duplicate_Pragma
(Ent
);
14204 Record_Rep_Item
(Ent
, N
);
14206 -- Anything else is incorrect
14211 end Dispatching_Domain
;
14217 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14219 when Pragma_Elaborate
=> Elaborate
: declare
14224 -- Pragma must be in context items list of a compilation unit
14226 if not Is_In_Context_Clause
then
14230 -- Must be at least one argument
14232 if Arg_Count
= 0 then
14233 Error_Pragma
("pragma% requires at least one argument");
14236 -- In Ada 83 mode, there can be no items following it in the
14237 -- context list except other pragmas and implicit with clauses
14238 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14239 -- placement rule does not apply.
14241 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14243 while Present
(Citem
) loop
14244 if Nkind
(Citem
) = N_Pragma
14245 or else (Nkind
(Citem
) = N_With_Clause
14246 and then Implicit_With
(Citem
))
14251 ("(Ada 83) pragma% must be at end of context clause");
14258 -- Finally, the arguments must all be units mentioned in a with
14259 -- clause in the same context clause. Note we already checked (in
14260 -- Par.Prag) that the arguments are all identifiers or selected
14264 Outer
: while Present
(Arg
) loop
14265 Citem
:= First
(List_Containing
(N
));
14266 Inner
: while Citem
/= N
loop
14267 if Nkind
(Citem
) = N_With_Clause
14268 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14270 Set_Elaborate_Present
(Citem
, True);
14271 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14273 -- With the pragma present, elaboration calls on
14274 -- subprograms from the named unit need no further
14275 -- checks, as long as the pragma appears in the current
14276 -- compilation unit. If the pragma appears in some unit
14277 -- in the context, there might still be a need for an
14278 -- Elaborate_All_Desirable from the current compilation
14279 -- to the named unit, so we keep the check enabled.
14281 if In_Extended_Main_Source_Unit
(N
) then
14283 -- This does not apply in SPARK mode, where we allow
14284 -- pragma Elaborate, but we don't trust it to be right
14285 -- so we will still insist on the Elaborate_All.
14287 if SPARK_Mode
/= On
then
14288 Set_Suppress_Elaboration_Warnings
14289 (Entity
(Name
(Citem
)));
14301 ("argument of pragma% is not withed unit", Arg
);
14307 -- Give a warning if operating in static mode with one of the
14308 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14311 and not Dynamic_Elaboration_Checks
14313 -- pragma Elaborate not allowed in SPARK mode anyway. We
14314 -- already complained about it, no point in generating any
14315 -- further complaint.
14317 and SPARK_Mode
/= On
14320 ("?l?use of pragma Elaborate may not be safe", N
);
14322 ("?l?use pragma Elaborate_All instead if possible", N
);
14326 -------------------
14327 -- Elaborate_All --
14328 -------------------
14330 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14332 when Pragma_Elaborate_All
=> Elaborate_All
: declare
14337 Check_Ada_83_Warning
;
14339 -- Pragma must be in context items list of a compilation unit
14341 if not Is_In_Context_Clause
then
14345 -- Must be at least one argument
14347 if Arg_Count
= 0 then
14348 Error_Pragma
("pragma% requires at least one argument");
14351 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14352 -- have to appear at the end of the context clause, but may
14353 -- appear mixed in with other items, even in Ada 83 mode.
14355 -- Final check: the arguments must all be units mentioned in
14356 -- a with clause in the same context clause. Note that we
14357 -- already checked (in Par.Prag) that all the arguments are
14358 -- either identifiers or selected components.
14361 Outr
: while Present
(Arg
) loop
14362 Citem
:= First
(List_Containing
(N
));
14363 Innr
: while Citem
/= N
loop
14364 if Nkind
(Citem
) = N_With_Clause
14365 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14367 Set_Elaborate_All_Present
(Citem
, True);
14368 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14370 -- Suppress warnings and elaboration checks on the named
14371 -- unit if the pragma is in the current compilation, as
14372 -- for pragma Elaborate.
14374 if In_Extended_Main_Source_Unit
(N
) then
14375 Set_Suppress_Elaboration_Warnings
14376 (Entity
(Name
(Citem
)));
14385 Set_Error_Posted
(N
);
14387 ("argument of pragma% is not withed unit", Arg
);
14394 --------------------
14395 -- Elaborate_Body --
14396 --------------------
14398 -- pragma Elaborate_Body [( library_unit_NAME )];
14400 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
14401 Cunit_Node
: Node_Id
;
14402 Cunit_Ent
: Entity_Id
;
14405 Check_Ada_83_Warning
;
14406 Check_Valid_Library_Unit_Pragma
;
14408 if Nkind
(N
) = N_Null_Statement
then
14412 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
14413 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14415 -- A pragma that applies to a Ghost entity becomes Ghost for the
14416 -- purposes of legality checks and removal of ignored Ghost code.
14418 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
14420 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
14423 Error_Pragma
("pragma% must refer to a spec, not a body");
14425 Set_Body_Required
(Cunit_Node
, True);
14426 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
14428 -- If we are in dynamic elaboration mode, then we suppress
14429 -- elaboration warnings for the unit, since it is definitely
14430 -- fine NOT to do dynamic checks at the first level (and such
14431 -- checks will be suppressed because no elaboration boolean
14432 -- is created for Elaborate_Body packages).
14434 -- But in the static model of elaboration, Elaborate_Body is
14435 -- definitely NOT good enough to ensure elaboration safety on
14436 -- its own, since the body may WITH other units that are not
14437 -- safe from an elaboration point of view, so a client must
14438 -- still do an Elaborate_All on such units.
14440 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14441 -- Elaborate_Body always suppressed elab warnings.
14443 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
14444 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
14447 end Elaborate_Body
;
14449 ------------------------
14450 -- Elaboration_Checks --
14451 ------------------------
14453 -- pragma Elaboration_Checks (Static | Dynamic);
14455 when Pragma_Elaboration_Checks
=>
14457 Check_Arg_Count
(1);
14458 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
14460 -- Set flag accordingly (ignore attempt at dynamic elaboration
14461 -- checks in SPARK mode).
14463 Dynamic_Elaboration_Checks
:=
14464 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
14470 -- pragma Eliminate (
14471 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14472 -- [,[Entity =>] IDENTIFIER |
14473 -- SELECTED_COMPONENT |
14475 -- [, OVERLOADING_RESOLUTION]);
14477 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14480 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14481 -- FUNCTION_PROFILE
14483 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14485 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14486 -- Result_Type => result_SUBTYPE_NAME]
14488 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14489 -- SUBTYPE_NAME ::= STRING_LITERAL
14491 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14492 -- SOURCE_TRACE ::= STRING_LITERAL
14494 when Pragma_Eliminate
=> Eliminate
: declare
14495 Args
: Args_List
(1 .. 5);
14496 Names
: constant Name_List
(1 .. 5) := (
14499 Name_Parameter_Types
,
14501 Name_Source_Location
);
14503 Unit_Name
: Node_Id
renames Args
(1);
14504 Entity
: Node_Id
renames Args
(2);
14505 Parameter_Types
: Node_Id
renames Args
(3);
14506 Result_Type
: Node_Id
renames Args
(4);
14507 Source_Location
: Node_Id
renames Args
(5);
14511 Check_Valid_Configuration_Pragma
;
14512 Gather_Associations
(Names
, Args
);
14514 if No
(Unit_Name
) then
14515 Error_Pragma
("missing Unit_Name argument for pragma%");
14519 and then (Present
(Parameter_Types
)
14521 Present
(Result_Type
)
14523 Present
(Source_Location
))
14525 Error_Pragma
("missing Entity argument for pragma%");
14528 if (Present
(Parameter_Types
)
14530 Present
(Result_Type
))
14532 Present
(Source_Location
)
14535 ("parameter profile and source location cannot be used "
14536 & "together in pragma%");
14539 Process_Eliminate_Pragma
14548 -----------------------------------
14549 -- Enable_Atomic_Synchronization --
14550 -----------------------------------
14552 -- pragma Enable_Atomic_Synchronization [(Entity)];
14554 when Pragma_Enable_Atomic_Synchronization
=>
14556 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
14563 -- [ Convention =>] convention_IDENTIFIER,
14564 -- [ Entity =>] LOCAL_NAME
14565 -- [, [External_Name =>] static_string_EXPRESSION ]
14566 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14568 when Pragma_Export
=> Export
: declare
14570 Def_Id
: Entity_Id
;
14572 pragma Warnings
(Off
, C
);
14575 Check_Ada_83_Warning
;
14579 Name_External_Name
,
14582 Check_At_Least_N_Arguments
(2);
14583 Check_At_Most_N_Arguments
(4);
14585 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14586 -- pragma Export (Entity, "external name");
14588 if Relaxed_RM_Semantics
14589 and then Arg_Count
= 2
14590 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
14593 Def_Id
:= Get_Pragma_Arg
(Arg1
);
14596 if not Is_Entity_Name
(Def_Id
) then
14597 Error_Pragma_Arg
("entity name required", Arg1
);
14600 Def_Id
:= Entity
(Def_Id
);
14601 Set_Exported
(Def_Id
, Arg1
);
14604 Process_Convention
(C
, Def_Id
);
14606 -- A pragma that applies to a Ghost entity becomes Ghost for
14607 -- the purposes of legality checks and removal of ignored Ghost
14610 Mark_Pragma_As_Ghost
(N
, Def_Id
);
14612 if Ekind
(Def_Id
) /= E_Constant
then
14613 Note_Possible_Modification
14614 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14617 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14618 Set_Exported
(Def_Id
, Arg2
);
14621 -- If the entity is a deferred constant, propagate the information
14622 -- to the full view, because gigi elaborates the full view only.
14624 if Ekind
(Def_Id
) = E_Constant
14625 and then Present
(Full_View
(Def_Id
))
14628 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
14630 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
14631 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
14632 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
14637 ---------------------
14638 -- Export_Function --
14639 ---------------------
14641 -- pragma Export_Function (
14642 -- [Internal =>] LOCAL_NAME
14643 -- [, [External =>] EXTERNAL_SYMBOL]
14644 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14645 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14646 -- [, [Mechanism =>] MECHANISM]
14647 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14649 -- EXTERNAL_SYMBOL ::=
14651 -- | static_string_EXPRESSION
14653 -- PARAMETER_TYPES ::=
14655 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14657 -- TYPE_DESIGNATOR ::=
14659 -- | subtype_Name ' Access
14663 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14665 -- MECHANISM_ASSOCIATION ::=
14666 -- [formal_parameter_NAME =>] MECHANISM_NAME
14668 -- MECHANISM_NAME ::=
14672 when Pragma_Export_Function
=> Export_Function
: declare
14673 Args
: Args_List
(1 .. 6);
14674 Names
: constant Name_List
(1 .. 6) := (
14677 Name_Parameter_Types
,
14680 Name_Result_Mechanism
);
14682 Internal
: Node_Id
renames Args
(1);
14683 External
: Node_Id
renames Args
(2);
14684 Parameter_Types
: Node_Id
renames Args
(3);
14685 Result_Type
: Node_Id
renames Args
(4);
14686 Mechanism
: Node_Id
renames Args
(5);
14687 Result_Mechanism
: Node_Id
renames Args
(6);
14691 Gather_Associations
(Names
, Args
);
14692 Process_Extended_Import_Export_Subprogram_Pragma
(
14693 Arg_Internal
=> Internal
,
14694 Arg_External
=> External
,
14695 Arg_Parameter_Types
=> Parameter_Types
,
14696 Arg_Result_Type
=> Result_Type
,
14697 Arg_Mechanism
=> Mechanism
,
14698 Arg_Result_Mechanism
=> Result_Mechanism
);
14699 end Export_Function
;
14701 -------------------
14702 -- Export_Object --
14703 -------------------
14705 -- pragma Export_Object (
14706 -- [Internal =>] LOCAL_NAME
14707 -- [, [External =>] EXTERNAL_SYMBOL]
14708 -- [, [Size =>] EXTERNAL_SYMBOL]);
14710 -- EXTERNAL_SYMBOL ::=
14712 -- | static_string_EXPRESSION
14714 -- PARAMETER_TYPES ::=
14716 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14718 -- TYPE_DESIGNATOR ::=
14720 -- | subtype_Name ' Access
14724 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14726 -- MECHANISM_ASSOCIATION ::=
14727 -- [formal_parameter_NAME =>] MECHANISM_NAME
14729 -- MECHANISM_NAME ::=
14733 when Pragma_Export_Object
=> Export_Object
: declare
14734 Args
: Args_List
(1 .. 3);
14735 Names
: constant Name_List
(1 .. 3) := (
14740 Internal
: Node_Id
renames Args
(1);
14741 External
: Node_Id
renames Args
(2);
14742 Size
: Node_Id
renames Args
(3);
14746 Gather_Associations
(Names
, Args
);
14747 Process_Extended_Import_Export_Object_Pragma
(
14748 Arg_Internal
=> Internal
,
14749 Arg_External
=> External
,
14753 ----------------------
14754 -- Export_Procedure --
14755 ----------------------
14757 -- pragma Export_Procedure (
14758 -- [Internal =>] LOCAL_NAME
14759 -- [, [External =>] EXTERNAL_SYMBOL]
14760 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14761 -- [, [Mechanism =>] MECHANISM]);
14763 -- EXTERNAL_SYMBOL ::=
14765 -- | static_string_EXPRESSION
14767 -- PARAMETER_TYPES ::=
14769 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14771 -- TYPE_DESIGNATOR ::=
14773 -- | subtype_Name ' Access
14777 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14779 -- MECHANISM_ASSOCIATION ::=
14780 -- [formal_parameter_NAME =>] MECHANISM_NAME
14782 -- MECHANISM_NAME ::=
14786 when Pragma_Export_Procedure
=> Export_Procedure
: declare
14787 Args
: Args_List
(1 .. 4);
14788 Names
: constant Name_List
(1 .. 4) := (
14791 Name_Parameter_Types
,
14794 Internal
: Node_Id
renames Args
(1);
14795 External
: Node_Id
renames Args
(2);
14796 Parameter_Types
: Node_Id
renames Args
(3);
14797 Mechanism
: Node_Id
renames Args
(4);
14801 Gather_Associations
(Names
, Args
);
14802 Process_Extended_Import_Export_Subprogram_Pragma
(
14803 Arg_Internal
=> Internal
,
14804 Arg_External
=> External
,
14805 Arg_Parameter_Types
=> Parameter_Types
,
14806 Arg_Mechanism
=> Mechanism
);
14807 end Export_Procedure
;
14813 -- pragma Export_Value (
14814 -- [Value =>] static_integer_EXPRESSION,
14815 -- [Link_Name =>] static_string_EXPRESSION);
14817 when Pragma_Export_Value
=>
14819 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
14820 Check_Arg_Count
(2);
14822 Check_Optional_Identifier
(Arg1
, Name_Value
);
14823 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
14825 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
14826 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
14828 -----------------------------
14829 -- Export_Valued_Procedure --
14830 -----------------------------
14832 -- pragma Export_Valued_Procedure (
14833 -- [Internal =>] LOCAL_NAME
14834 -- [, [External =>] EXTERNAL_SYMBOL,]
14835 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14836 -- [, [Mechanism =>] MECHANISM]);
14838 -- EXTERNAL_SYMBOL ::=
14840 -- | static_string_EXPRESSION
14842 -- PARAMETER_TYPES ::=
14844 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14846 -- TYPE_DESIGNATOR ::=
14848 -- | subtype_Name ' Access
14852 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14854 -- MECHANISM_ASSOCIATION ::=
14855 -- [formal_parameter_NAME =>] MECHANISM_NAME
14857 -- MECHANISM_NAME ::=
14861 when Pragma_Export_Valued_Procedure
=>
14862 Export_Valued_Procedure
: declare
14863 Args
: Args_List
(1 .. 4);
14864 Names
: constant Name_List
(1 .. 4) := (
14867 Name_Parameter_Types
,
14870 Internal
: Node_Id
renames Args
(1);
14871 External
: Node_Id
renames Args
(2);
14872 Parameter_Types
: Node_Id
renames Args
(3);
14873 Mechanism
: Node_Id
renames Args
(4);
14877 Gather_Associations
(Names
, Args
);
14878 Process_Extended_Import_Export_Subprogram_Pragma
(
14879 Arg_Internal
=> Internal
,
14880 Arg_External
=> External
,
14881 Arg_Parameter_Types
=> Parameter_Types
,
14882 Arg_Mechanism
=> Mechanism
);
14883 end Export_Valued_Procedure
;
14885 -------------------
14886 -- Extend_System --
14887 -------------------
14889 -- pragma Extend_System ([Name =>] Identifier);
14891 when Pragma_Extend_System
=> Extend_System
: declare
14894 Check_Valid_Configuration_Pragma
;
14895 Check_Arg_Count
(1);
14896 Check_Optional_Identifier
(Arg1
, Name_Name
);
14897 Check_Arg_Is_Identifier
(Arg1
);
14899 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14902 and then Name_Buffer
(1 .. 4) = "aux_"
14904 if Present
(System_Extend_Pragma_Arg
) then
14905 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14906 Chars
(Expression
(System_Extend_Pragma_Arg
))
14910 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14911 Error_Pragma
("pragma% conflicts with that #");
14915 System_Extend_Pragma_Arg
:= Arg1
;
14917 if not GNAT_Mode
then
14918 System_Extend_Unit
:= Arg1
;
14922 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14926 ------------------------
14927 -- Extensions_Allowed --
14928 ------------------------
14930 -- pragma Extensions_Allowed (ON | OFF);
14932 when Pragma_Extensions_Allowed
=>
14934 Check_Arg_Count
(1);
14935 Check_No_Identifiers
;
14936 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14938 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14939 Extensions_Allowed
:= True;
14940 Ada_Version
:= Ada_Version_Type
'Last;
14943 Extensions_Allowed
:= False;
14944 Ada_Version
:= Ada_Version_Explicit
;
14945 Ada_Version_Pragma
:= Empty
;
14948 ------------------------
14949 -- Extensions_Visible --
14950 ------------------------
14952 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14954 -- Characteristics:
14956 -- * Analysis - The annotation is fully analyzed immediately upon
14957 -- elaboration as its expression must be static.
14959 -- * Expansion - None.
14961 -- * Template - The annotation utilizes the generic template of the
14962 -- related subprogram [body] when it is:
14964 -- aspect on subprogram declaration
14965 -- aspect on stand alone subprogram body
14966 -- pragma on stand alone subprogram body
14968 -- The annotation must prepare its own template when it is:
14970 -- pragma on subprogram declaration
14972 -- * Globals - Capture of global references must occur after full
14975 -- * Instance - The annotation is instantiated automatically when
14976 -- the related generic subprogram [body] is instantiated except for
14977 -- the "pragma on subprogram declaration" case. In that scenario
14978 -- the annotation must instantiate itself.
14980 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
14981 Formal
: Entity_Id
;
14982 Has_OK_Formal
: Boolean := False;
14983 Spec_Id
: Entity_Id
;
14984 Subp_Decl
: Node_Id
;
14988 Check_No_Identifiers
;
14989 Check_At_Most_N_Arguments
(1);
14992 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
14994 -- Abstract subprogram declaration
14996 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
14999 -- Generic subprogram declaration
15001 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15004 -- Body acts as spec
15006 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15007 and then No
(Corresponding_Spec
(Subp_Decl
))
15011 -- Body stub acts as spec
15013 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15014 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15018 -- Subprogram declaration
15020 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15023 -- Otherwise the pragma is associated with an illegal construct
15026 Error_Pragma
("pragma % must apply to a subprogram");
15030 -- Chain the pragma on the contract for completeness
15032 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15034 -- The legality checks of pragma Extension_Visible are affected
15035 -- by the SPARK mode in effect. Analyze all pragmas in specific
15038 Analyze_If_Present
(Pragma_SPARK_Mode
);
15040 -- Mark the pragma as Ghost if the related subprogram is also
15041 -- Ghost. This also ensures that any expansion performed further
15042 -- below will produce Ghost nodes.
15044 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15045 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
15047 -- Examine the formals of the related subprogram
15049 Formal
:= First_Formal
(Spec_Id
);
15050 while Present
(Formal
) loop
15052 -- At least one of the formals is of a specific tagged type,
15053 -- the pragma is legal.
15055 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15056 Has_OK_Formal
:= True;
15059 -- A generic subprogram with at least one formal of a private
15060 -- type ensures the legality of the pragma because the actual
15061 -- may be specifically tagged. Note that this is verified by
15062 -- the check above at instantiation time.
15064 elsif Is_Private_Type
(Etype
(Formal
))
15065 and then Is_Generic_Type
(Etype
(Formal
))
15067 Has_OK_Formal
:= True;
15071 Next_Formal
(Formal
);
15074 if not Has_OK_Formal
then
15075 Error_Msg_Name_1
:= Pname
;
15076 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15078 ("\subprogram & lacks parameter of specific tagged or "
15079 & "generic private type", N
, Spec_Id
);
15084 -- Analyze the Boolean expression (if any)
15086 if Present
(Arg1
) then
15087 Check_Static_Boolean_Expression
15088 (Expression
(Get_Argument
(N
, Spec_Id
)));
15090 end Extensions_Visible
;
15096 -- pragma External (
15097 -- [ Convention =>] convention_IDENTIFIER,
15098 -- [ Entity =>] LOCAL_NAME
15099 -- [, [External_Name =>] static_string_EXPRESSION ]
15100 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15102 when Pragma_External
=> External
: declare
15105 pragma Warnings
(Off
, C
);
15112 Name_External_Name
,
15114 Check_At_Least_N_Arguments
(2);
15115 Check_At_Most_N_Arguments
(4);
15116 Process_Convention
(C
, E
);
15118 -- A pragma that applies to a Ghost entity becomes Ghost for the
15119 -- purposes of legality checks and removal of ignored Ghost code.
15121 Mark_Pragma_As_Ghost
(N
, E
);
15123 Note_Possible_Modification
15124 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15125 Process_Interface_Name
(E
, Arg3
, Arg4
);
15126 Set_Exported
(E
, Arg2
);
15129 --------------------------
15130 -- External_Name_Casing --
15131 --------------------------
15133 -- pragma External_Name_Casing (
15134 -- UPPERCASE | LOWERCASE
15135 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15137 when Pragma_External_Name_Casing
=> External_Name_Casing
: declare
15140 Check_No_Identifiers
;
15142 if Arg_Count
= 2 then
15143 Check_Arg_Is_One_Of
15144 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15146 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15148 Opt
.External_Name_Exp_Casing
:= As_Is
;
15150 when Name_Uppercase
=>
15151 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15153 when Name_Lowercase
=>
15154 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15161 Check_Arg_Count
(1);
15164 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15166 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15167 when Name_Uppercase
=>
15168 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15170 when Name_Lowercase
=>
15171 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15176 end External_Name_Casing
;
15182 -- pragma Fast_Math;
15184 when Pragma_Fast_Math
=>
15186 Check_No_Identifiers
;
15187 Check_Valid_Configuration_Pragma
;
15190 --------------------------
15191 -- Favor_Top_Level --
15192 --------------------------
15194 -- pragma Favor_Top_Level (type_NAME);
15196 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15201 Check_No_Identifiers
;
15202 Check_Arg_Count
(1);
15203 Check_Arg_Is_Local_Name
(Arg1
);
15204 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15206 -- A pragma that applies to a Ghost entity becomes Ghost for the
15207 -- purposes of legality checks and removal of ignored Ghost code.
15209 Mark_Pragma_As_Ghost
(N
, Typ
);
15211 -- If it's an access-to-subprogram type (in particular, not a
15212 -- subtype), set the flag on that type.
15214 if Is_Access_Subprogram_Type
(Typ
) then
15215 Set_Can_Use_Internal_Rep
(Typ
, False);
15217 -- Otherwise it's an error (name denotes the wrong sort of entity)
15221 ("access-to-subprogram type expected",
15222 Get_Pragma_Arg
(Arg1
));
15224 end Favor_Top_Level
;
15226 ---------------------------
15227 -- Finalize_Storage_Only --
15228 ---------------------------
15230 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15232 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15233 Assoc
: constant Node_Id
:= Arg1
;
15234 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15239 Check_No_Identifiers
;
15240 Check_Arg_Count
(1);
15241 Check_Arg_Is_Local_Name
(Arg1
);
15243 Find_Type
(Type_Id
);
15244 Typ
:= Entity
(Type_Id
);
15247 or else Rep_Item_Too_Early
(Typ
, N
)
15251 Typ
:= Underlying_Type
(Typ
);
15254 if not Is_Controlled
(Typ
) then
15255 Error_Pragma
("pragma% must specify controlled type");
15258 Check_First_Subtype
(Arg1
);
15260 if Finalize_Storage_Only
(Typ
) then
15261 Error_Pragma
("duplicate pragma%, only one allowed");
15263 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15264 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15266 end Finalize_Storage
;
15272 -- pragma Ghost [ (boolean_EXPRESSION) ];
15274 when Pragma_Ghost
=> Ghost
: declare
15278 Orig_Stmt
: Node_Id
;
15279 Prev_Id
: Entity_Id
;
15284 Check_No_Identifiers
;
15285 Check_At_Most_N_Arguments
(1);
15289 while Present
(Stmt
) loop
15291 -- Skip prior pragmas, but check for duplicates
15293 if Nkind
(Stmt
) = N_Pragma
then
15294 if Pragma_Name
(Stmt
) = Pname
then
15295 Error_Msg_Name_1
:= Pname
;
15296 Error_Msg_Sloc
:= Sloc
(Stmt
);
15297 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
15300 -- Task unit declared without a definition cannot be subject to
15301 -- pragma Ghost (SPARK RM 6.9(19)).
15303 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15304 N_Task_Type_Declaration
)
15306 Error_Pragma
("pragma % cannot apply to a task type");
15309 -- Skip internally generated code
15311 elsif not Comes_From_Source
(Stmt
) then
15312 Orig_Stmt
:= Original_Node
(Stmt
);
15314 -- When pragma Ghost applies to an untagged derivation, the
15315 -- derivation is transformed into a [sub]type declaration.
15317 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15318 N_Subtype_Declaration
)
15319 and then Comes_From_Source
(Orig_Stmt
)
15320 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15321 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15322 N_Derived_Type_Definition
15324 Id
:= Defining_Entity
(Stmt
);
15327 -- When pragma Ghost applies to an object declaration which
15328 -- is initialized by means of a function call that returns
15329 -- on the secondary stack, the object declaration becomes a
15332 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
15333 and then Comes_From_Source
(Orig_Stmt
)
15334 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
15336 Id
:= Defining_Entity
(Stmt
);
15339 -- When pragma Ghost applies to an expression function, the
15340 -- expression function is transformed into a subprogram.
15342 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
15343 and then Comes_From_Source
(Orig_Stmt
)
15344 and then Nkind
(Orig_Stmt
) = N_Expression_Function
15346 Id
:= Defining_Entity
(Stmt
);
15350 -- The pragma applies to a legal construct, stop the traversal
15352 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
15353 N_Full_Type_Declaration
,
15354 N_Generic_Subprogram_Declaration
,
15355 N_Object_Declaration
,
15356 N_Private_Extension_Declaration
,
15357 N_Private_Type_Declaration
,
15358 N_Subprogram_Declaration
,
15359 N_Subtype_Declaration
)
15361 Id
:= Defining_Entity
(Stmt
);
15364 -- The pragma does not apply to a legal construct, issue an
15365 -- error and stop the analysis.
15369 ("pragma % must apply to an object, package, subprogram "
15374 Stmt
:= Prev
(Stmt
);
15377 Context
:= Parent
(N
);
15379 -- Handle compilation units
15381 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
15382 Context
:= Unit
(Parent
(Context
));
15385 -- Protected and task types cannot be subject to pragma Ghost
15386 -- (SPARK RM 6.9(19)).
15388 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
15390 Error_Pragma
("pragma % cannot apply to a protected type");
15393 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
15394 Error_Pragma
("pragma % cannot apply to a task type");
15400 -- When pragma Ghost is associated with a [generic] package, it
15401 -- appears in the visible declarations.
15403 if Nkind
(Context
) = N_Package_Specification
15404 and then Present
(Visible_Declarations
(Context
))
15405 and then List_Containing
(N
) = Visible_Declarations
(Context
)
15407 Id
:= Defining_Entity
(Context
);
15409 -- Pragma Ghost applies to a stand alone subprogram body
15411 elsif Nkind
(Context
) = N_Subprogram_Body
15412 and then No
(Corresponding_Spec
(Context
))
15414 Id
:= Defining_Entity
(Context
);
15416 -- Pragma Ghost applies to a subprogram declaration that acts
15417 -- as a compilation unit.
15419 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
15420 Id
:= Defining_Entity
(Context
);
15426 ("pragma % must apply to an object, package, subprogram or "
15431 -- Handle completions of types and constants that are subject to
15434 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
15435 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
15437 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
15438 Error_Msg_Name_1
:= Pname
;
15440 -- The full declaration of a deferred constant cannot be
15441 -- subject to pragma Ghost unless the deferred declaration
15442 -- is also Ghost (SPARK RM 6.9(9)).
15444 if Ekind
(Prev_Id
) = E_Constant
then
15445 Error_Msg_Name_1
:= Pname
;
15446 Error_Msg_NE
(Fix_Error
15447 ("pragma % must apply to declaration of deferred "
15448 & "constant &"), N
, Id
);
15451 -- Pragma Ghost may appear on the full view of an incomplete
15452 -- type because the incomplete declaration lacks aspects and
15453 -- cannot be subject to pragma Ghost.
15455 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
15458 -- The full declaration of a type cannot be subject to
15459 -- pragma Ghost unless the partial view is also Ghost
15460 -- (SPARK RM 6.9(9)).
15463 Error_Msg_NE
(Fix_Error
15464 ("pragma % must apply to partial view of type &"),
15470 -- A synchronized object cannot be subject to pragma Ghost
15471 -- (SPARK RM 6.9(19)).
15473 elsif Ekind
(Id
) = E_Variable
then
15474 if Is_Protected_Type
(Etype
(Id
)) then
15475 Error_Pragma
("pragma % cannot apply to a protected object");
15478 elsif Is_Task_Type
(Etype
(Id
)) then
15479 Error_Pragma
("pragma % cannot apply to a task object");
15484 -- Analyze the Boolean expression (if any)
15486 if Present
(Arg1
) then
15487 Expr
:= Get_Pragma_Arg
(Arg1
);
15489 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
15491 if Is_OK_Static_Expression
(Expr
) then
15493 -- "Ghostness" cannot be turned off once enabled within a
15494 -- region (SPARK RM 6.9(6)).
15496 if Is_False
(Expr_Value
(Expr
))
15497 and then Ghost_Mode
> None
15500 ("pragma % with value False cannot appear in enabled "
15505 -- Otherwie the expression is not static
15509 ("expression of pragma % must be static", Expr
);
15514 Set_Is_Ghost_Entity
(Id
);
15521 -- pragma Global (GLOBAL_SPECIFICATION);
15523 -- GLOBAL_SPECIFICATION ::=
15526 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15528 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15530 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15531 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15532 -- GLOBAL_ITEM ::= NAME
15534 -- Characteristics:
15536 -- * Analysis - The annotation undergoes initial checks to verify
15537 -- the legal placement and context. Secondary checks fully analyze
15538 -- the dependency clauses in:
15540 -- Analyze_Global_In_Decl_Part
15542 -- * Expansion - None.
15544 -- * Template - The annotation utilizes the generic template of the
15545 -- related subprogram [body] when it is:
15547 -- aspect on subprogram declaration
15548 -- aspect on stand alone subprogram body
15549 -- pragma on stand alone subprogram body
15551 -- The annotation must prepare its own template when it is:
15553 -- pragma on subprogram declaration
15555 -- * Globals - Capture of global references must occur after full
15558 -- * Instance - The annotation is instantiated automatically when
15559 -- the related generic subprogram [body] is instantiated except for
15560 -- the "pragma on subprogram declaration" case. In that scenario
15561 -- the annotation must instantiate itself.
15563 when Pragma_Global
=> Global
: declare
15565 Spec_Id
: Entity_Id
;
15566 Subp_Decl
: Node_Id
;
15569 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15573 -- Chain the pragma on the contract for further processing by
15574 -- Analyze_Global_In_Decl_Part.
15576 Add_Contract_Item
(N
, Spec_Id
);
15578 -- Fully analyze the pragma when it appears inside an entry
15579 -- or subprogram body because it cannot benefit from forward
15582 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15584 N_Subprogram_Body_Stub
)
15586 -- The legality checks of pragmas Depends and Global are
15587 -- affected by the SPARK mode in effect and the volatility
15588 -- of the context. In addition these two pragmas are subject
15589 -- to an inherent order:
15594 -- Analyze all these pragmas in the order outlined above
15596 Analyze_If_Present
(Pragma_SPARK_Mode
);
15597 Analyze_If_Present
(Pragma_Volatile_Function
);
15598 Analyze_Global_In_Decl_Part
(N
);
15599 Analyze_If_Present
(Pragma_Depends
);
15608 -- pragma Ident (static_string_EXPRESSION)
15610 -- Note: pragma Comment shares this processing. Pragma Ident is
15611 -- identical in effect to pragma Commment.
15613 when Pragma_Ident | Pragma_Comment
=> Ident
: declare
15618 Check_Arg_Count
(1);
15619 Check_No_Identifiers
;
15620 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15623 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
15630 GP
:= Parent
(Parent
(N
));
15632 if Nkind_In
(GP
, N_Package_Declaration
,
15633 N_Generic_Package_Declaration
)
15638 -- If we have a compilation unit, then record the ident value,
15639 -- checking for improper duplication.
15641 if Nkind
(GP
) = N_Compilation_Unit
then
15642 CS
:= Ident_String
(Current_Sem_Unit
);
15644 if Present
(CS
) then
15646 -- If we have multiple instances, concatenate them, but
15647 -- not in ASIS, where we want the original tree.
15649 if not ASIS_Mode
then
15650 Start_String
(Strval
(CS
));
15651 Store_String_Char
(' ');
15652 Store_String_Chars
(Strval
(Str
));
15653 Set_Strval
(CS
, End_String
);
15657 Set_Ident_String
(Current_Sem_Unit
, Str
);
15660 -- For subunits, we just ignore the Ident, since in GNAT these
15661 -- are not separate object files, and hence not separate units
15662 -- in the unit table.
15664 elsif Nkind
(GP
) = N_Subunit
then
15670 -------------------
15671 -- Ignore_Pragma --
15672 -------------------
15674 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15676 -- Entirely handled in the parser, nothing to do here
15678 when Pragma_Ignore_Pragma
=>
15681 ----------------------------
15682 -- Implementation_Defined --
15683 ----------------------------
15685 -- pragma Implementation_Defined (LOCAL_NAME);
15687 -- Marks previously declared entity as implementation defined. For
15688 -- an overloaded entity, applies to the most recent homonym.
15690 -- pragma Implementation_Defined;
15692 -- The form with no arguments appears anywhere within a scope, most
15693 -- typically a package spec, and indicates that all entities that are
15694 -- defined within the package spec are Implementation_Defined.
15696 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15701 Check_No_Identifiers
;
15703 -- Form with no arguments
15705 if Arg_Count
= 0 then
15706 Set_Is_Implementation_Defined
(Current_Scope
);
15708 -- Form with one argument
15711 Check_Arg_Count
(1);
15712 Check_Arg_Is_Local_Name
(Arg1
);
15713 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15714 Set_Is_Implementation_Defined
(Ent
);
15716 end Implementation_Defined
;
15722 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15724 -- IMPLEMENTATION_KIND ::=
15725 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15727 -- "By_Any" and "Optional" are treated as synonyms in order to
15728 -- support Ada 2012 aspect Synchronization.
15730 when Pragma_Implemented
=> Implemented
: declare
15731 Proc_Id
: Entity_Id
;
15736 Check_Arg_Count
(2);
15737 Check_No_Identifiers
;
15738 Check_Arg_Is_Identifier
(Arg1
);
15739 Check_Arg_Is_Local_Name
(Arg1
);
15740 Check_Arg_Is_One_Of
(Arg2
,
15743 Name_By_Protected_Procedure
,
15746 -- Extract the name of the local procedure
15748 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15750 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15751 -- primitive procedure of a synchronized tagged type.
15753 if Ekind
(Proc_Id
) = E_Procedure
15754 and then Is_Primitive
(Proc_Id
)
15755 and then Present
(First_Formal
(Proc_Id
))
15757 Typ
:= Etype
(First_Formal
(Proc_Id
));
15759 if Is_Tagged_Type
(Typ
)
15762 -- Check for a protected, a synchronized or a task interface
15764 ((Is_Interface
(Typ
)
15765 and then Is_Synchronized_Interface
(Typ
))
15767 -- Check for a protected type or a task type that implements
15771 (Is_Concurrent_Record_Type
(Typ
)
15772 and then Present
(Interfaces
(Typ
)))
15774 -- In analysis-only mode, examine original protected type
15777 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
15778 and then Present
(Interface_List
(Parent
(Typ
))))
15780 -- Check for a private record extension with keyword
15784 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
15785 E_Record_Subtype_With_Private
)
15786 and then Synchronized_Present
(Parent
(Typ
))))
15791 ("controlling formal must be of synchronized tagged type",
15796 -- Procedures declared inside a protected type must be accepted
15798 elsif Ekind
(Proc_Id
) = E_Procedure
15799 and then Is_Protected_Type
(Scope
(Proc_Id
))
15803 -- The first argument is not a primitive procedure
15807 ("pragma % must be applied to a primitive procedure", Arg1
);
15811 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15812 -- By_Protected_Procedure to the primitive procedure of a task
15815 if Chars
(Arg2
) = Name_By_Protected_Procedure
15816 and then Is_Interface
(Typ
)
15817 and then Is_Task_Interface
(Typ
)
15820 ("implementation kind By_Protected_Procedure cannot be "
15821 & "applied to a task interface primitive", Arg2
);
15825 Record_Rep_Item
(Proc_Id
, N
);
15828 ----------------------
15829 -- Implicit_Packing --
15830 ----------------------
15832 -- pragma Implicit_Packing;
15834 when Pragma_Implicit_Packing
=>
15836 Check_Arg_Count
(0);
15837 Implicit_Packing
:= True;
15844 -- [Convention =>] convention_IDENTIFIER,
15845 -- [Entity =>] LOCAL_NAME
15846 -- [, [External_Name =>] static_string_EXPRESSION ]
15847 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15849 when Pragma_Import
=>
15850 Check_Ada_83_Warning
;
15854 Name_External_Name
,
15857 Check_At_Least_N_Arguments
(2);
15858 Check_At_Most_N_Arguments
(4);
15859 Process_Import_Or_Interface
;
15861 ---------------------
15862 -- Import_Function --
15863 ---------------------
15865 -- pragma Import_Function (
15866 -- [Internal =>] LOCAL_NAME,
15867 -- [, [External =>] EXTERNAL_SYMBOL]
15868 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15869 -- [, [Result_Type =>] SUBTYPE_MARK]
15870 -- [, [Mechanism =>] MECHANISM]
15871 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15873 -- EXTERNAL_SYMBOL ::=
15875 -- | static_string_EXPRESSION
15877 -- PARAMETER_TYPES ::=
15879 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15881 -- TYPE_DESIGNATOR ::=
15883 -- | subtype_Name ' Access
15887 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15889 -- MECHANISM_ASSOCIATION ::=
15890 -- [formal_parameter_NAME =>] MECHANISM_NAME
15892 -- MECHANISM_NAME ::=
15896 when Pragma_Import_Function
=> Import_Function
: declare
15897 Args
: Args_List
(1 .. 6);
15898 Names
: constant Name_List
(1 .. 6) := (
15901 Name_Parameter_Types
,
15904 Name_Result_Mechanism
);
15906 Internal
: Node_Id
renames Args
(1);
15907 External
: Node_Id
renames Args
(2);
15908 Parameter_Types
: Node_Id
renames Args
(3);
15909 Result_Type
: Node_Id
renames Args
(4);
15910 Mechanism
: Node_Id
renames Args
(5);
15911 Result_Mechanism
: Node_Id
renames Args
(6);
15915 Gather_Associations
(Names
, Args
);
15916 Process_Extended_Import_Export_Subprogram_Pragma
(
15917 Arg_Internal
=> Internal
,
15918 Arg_External
=> External
,
15919 Arg_Parameter_Types
=> Parameter_Types
,
15920 Arg_Result_Type
=> Result_Type
,
15921 Arg_Mechanism
=> Mechanism
,
15922 Arg_Result_Mechanism
=> Result_Mechanism
);
15923 end Import_Function
;
15925 -------------------
15926 -- Import_Object --
15927 -------------------
15929 -- pragma Import_Object (
15930 -- [Internal =>] LOCAL_NAME
15931 -- [, [External =>] EXTERNAL_SYMBOL]
15932 -- [, [Size =>] EXTERNAL_SYMBOL]);
15934 -- EXTERNAL_SYMBOL ::=
15936 -- | static_string_EXPRESSION
15938 when Pragma_Import_Object
=> Import_Object
: declare
15939 Args
: Args_List
(1 .. 3);
15940 Names
: constant Name_List
(1 .. 3) := (
15945 Internal
: Node_Id
renames Args
(1);
15946 External
: Node_Id
renames Args
(2);
15947 Size
: Node_Id
renames Args
(3);
15951 Gather_Associations
(Names
, Args
);
15952 Process_Extended_Import_Export_Object_Pragma
(
15953 Arg_Internal
=> Internal
,
15954 Arg_External
=> External
,
15958 ----------------------
15959 -- Import_Procedure --
15960 ----------------------
15962 -- pragma Import_Procedure (
15963 -- [Internal =>] LOCAL_NAME
15964 -- [, [External =>] EXTERNAL_SYMBOL]
15965 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15966 -- [, [Mechanism =>] MECHANISM]);
15968 -- EXTERNAL_SYMBOL ::=
15970 -- | static_string_EXPRESSION
15972 -- PARAMETER_TYPES ::=
15974 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15976 -- TYPE_DESIGNATOR ::=
15978 -- | subtype_Name ' Access
15982 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15984 -- MECHANISM_ASSOCIATION ::=
15985 -- [formal_parameter_NAME =>] MECHANISM_NAME
15987 -- MECHANISM_NAME ::=
15991 when Pragma_Import_Procedure
=> Import_Procedure
: declare
15992 Args
: Args_List
(1 .. 4);
15993 Names
: constant Name_List
(1 .. 4) := (
15996 Name_Parameter_Types
,
15999 Internal
: Node_Id
renames Args
(1);
16000 External
: Node_Id
renames Args
(2);
16001 Parameter_Types
: Node_Id
renames Args
(3);
16002 Mechanism
: Node_Id
renames Args
(4);
16006 Gather_Associations
(Names
, Args
);
16007 Process_Extended_Import_Export_Subprogram_Pragma
(
16008 Arg_Internal
=> Internal
,
16009 Arg_External
=> External
,
16010 Arg_Parameter_Types
=> Parameter_Types
,
16011 Arg_Mechanism
=> Mechanism
);
16012 end Import_Procedure
;
16014 -----------------------------
16015 -- Import_Valued_Procedure --
16016 -----------------------------
16018 -- pragma Import_Valued_Procedure (
16019 -- [Internal =>] LOCAL_NAME
16020 -- [, [External =>] EXTERNAL_SYMBOL]
16021 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16022 -- [, [Mechanism =>] MECHANISM]);
16024 -- EXTERNAL_SYMBOL ::=
16026 -- | static_string_EXPRESSION
16028 -- PARAMETER_TYPES ::=
16030 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16032 -- TYPE_DESIGNATOR ::=
16034 -- | subtype_Name ' Access
16038 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16040 -- MECHANISM_ASSOCIATION ::=
16041 -- [formal_parameter_NAME =>] MECHANISM_NAME
16043 -- MECHANISM_NAME ::=
16047 when Pragma_Import_Valued_Procedure
=>
16048 Import_Valued_Procedure
: declare
16049 Args
: Args_List
(1 .. 4);
16050 Names
: constant Name_List
(1 .. 4) := (
16053 Name_Parameter_Types
,
16056 Internal
: Node_Id
renames Args
(1);
16057 External
: Node_Id
renames Args
(2);
16058 Parameter_Types
: Node_Id
renames Args
(3);
16059 Mechanism
: Node_Id
renames Args
(4);
16063 Gather_Associations
(Names
, Args
);
16064 Process_Extended_Import_Export_Subprogram_Pragma
(
16065 Arg_Internal
=> Internal
,
16066 Arg_External
=> External
,
16067 Arg_Parameter_Types
=> Parameter_Types
,
16068 Arg_Mechanism
=> Mechanism
);
16069 end Import_Valued_Procedure
;
16075 -- pragma Independent (LOCAL_NAME);
16077 when Pragma_Independent
=>
16078 Process_Atomic_Independent_Shared_Volatile
;
16080 ----------------------------
16081 -- Independent_Components --
16082 ----------------------------
16084 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16086 when Pragma_Independent_Components
=> Independent_Components
: declare
16094 Check_Ada_83_Warning
;
16096 Check_No_Identifiers
;
16097 Check_Arg_Count
(1);
16098 Check_Arg_Is_Local_Name
(Arg1
);
16099 E_Id
:= Get_Pragma_Arg
(Arg1
);
16101 if Etype
(E_Id
) = Any_Type
then
16105 E
:= Entity
(E_Id
);
16107 -- A pragma that applies to a Ghost entity becomes Ghost for the
16108 -- purposes of legality checks and removal of ignored Ghost code.
16110 Mark_Pragma_As_Ghost
(N
, E
);
16112 -- Check duplicate before we chain ourselves
16114 Check_Duplicate_Pragma
(E
);
16116 -- Check appropriate entity
16118 if Rep_Item_Too_Early
(E
, N
)
16120 Rep_Item_Too_Late
(E
, N
)
16125 D
:= Declaration_Node
(E
);
16128 -- The flag is set on the base type, or on the object
16130 if K
= N_Full_Type_Declaration
16131 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16133 Set_Has_Independent_Components
(Base_Type
(E
));
16134 Record_Independence_Check
(N
, Base_Type
(E
));
16136 -- For record type, set all components independent
16138 if Is_Record_Type
(E
) then
16139 C
:= First_Component
(E
);
16140 while Present
(C
) loop
16141 Set_Is_Independent
(C
);
16142 Next_Component
(C
);
16146 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16147 and then Nkind
(D
) = N_Object_Declaration
16148 and then Nkind
(Object_Definition
(D
)) =
16149 N_Constrained_Array_Definition
16151 Set_Has_Independent_Components
(E
);
16152 Record_Independence_Check
(N
, E
);
16155 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16157 end Independent_Components
;
16159 -----------------------
16160 -- Initial_Condition --
16161 -----------------------
16163 -- pragma Initial_Condition (boolean_EXPRESSION);
16165 -- Characteristics:
16167 -- * Analysis - The annotation undergoes initial checks to verify
16168 -- the legal placement and context. Secondary checks preanalyze the
16171 -- Analyze_Initial_Condition_In_Decl_Part
16173 -- * Expansion - The annotation is expanded during the expansion of
16174 -- the package body whose declaration is subject to the annotation
16177 -- Expand_Pragma_Initial_Condition
16179 -- * Template - The annotation utilizes the generic template of the
16180 -- related package declaration.
16182 -- * Globals - Capture of global references must occur after full
16185 -- * Instance - The annotation is instantiated automatically when
16186 -- the related generic package is instantiated.
16188 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16189 Pack_Decl
: Node_Id
;
16190 Pack_Id
: Entity_Id
;
16194 Check_No_Identifiers
;
16195 Check_Arg_Count
(1);
16197 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16199 -- Ensure the proper placement of the pragma. Initial_Condition
16200 -- must be associated with a package declaration.
16202 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16203 N_Package_Declaration
)
16207 -- Otherwise the pragma is associated with an illegal context
16214 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16216 -- Chain the pragma on the contract for further processing by
16217 -- Analyze_Initial_Condition_In_Decl_Part.
16219 Add_Contract_Item
(N
, Pack_Id
);
16221 -- The legality checks of pragmas Abstract_State, Initializes, and
16222 -- Initial_Condition are affected by the SPARK mode in effect. In
16223 -- addition, these three pragmas are subject to an inherent order:
16225 -- 1) Abstract_State
16227 -- 3) Initial_Condition
16229 -- Analyze all these pragmas in the order outlined above
16231 Analyze_If_Present
(Pragma_SPARK_Mode
);
16232 Analyze_If_Present
(Pragma_Abstract_State
);
16233 Analyze_If_Present
(Pragma_Initializes
);
16235 -- A pragma that applies to a Ghost entity becomes Ghost for the
16236 -- purposes of legality checks and removal of ignored Ghost code.
16238 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
16239 end Initial_Condition
;
16241 ------------------------
16242 -- Initialize_Scalars --
16243 ------------------------
16245 -- pragma Initialize_Scalars;
16247 when Pragma_Initialize_Scalars
=>
16249 Check_Arg_Count
(0);
16250 Check_Valid_Configuration_Pragma
;
16251 Check_Restriction
(No_Initialize_Scalars
, N
);
16253 -- Initialize_Scalars creates false positives in CodePeer, and
16254 -- incorrect negative results in GNATprove mode, so ignore this
16255 -- pragma in these modes.
16257 if not Restriction_Active
(No_Initialize_Scalars
)
16258 and then not (CodePeer_Mode
or GNATprove_Mode
)
16260 Init_Or_Norm_Scalars
:= True;
16261 Initialize_Scalars
:= True;
16268 -- pragma Initializes (INITIALIZATION_LIST);
16270 -- INITIALIZATION_LIST ::=
16272 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16274 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16279 -- | (INPUT {, INPUT})
16283 -- Characteristics:
16285 -- * Analysis - The annotation undergoes initial checks to verify
16286 -- the legal placement and context. Secondary checks preanalyze the
16289 -- Analyze_Initializes_In_Decl_Part
16291 -- * Expansion - None.
16293 -- * Template - The annotation utilizes the generic template of the
16294 -- related package declaration.
16296 -- * Globals - Capture of global references must occur after full
16299 -- * Instance - The annotation is instantiated automatically when
16300 -- the related generic package is instantiated.
16302 when Pragma_Initializes
=> Initializes
: declare
16303 Pack_Decl
: Node_Id
;
16304 Pack_Id
: Entity_Id
;
16308 Check_No_Identifiers
;
16309 Check_Arg_Count
(1);
16311 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16313 -- Ensure the proper placement of the pragma. Initializes must be
16314 -- associated with a package declaration.
16316 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16317 N_Package_Declaration
)
16321 -- Otherwise the pragma is associated with an illegal construc
16328 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16330 -- Chain the pragma on the contract for further processing by
16331 -- Analyze_Initializes_In_Decl_Part.
16333 Add_Contract_Item
(N
, Pack_Id
);
16335 -- The legality checks of pragmas Abstract_State, Initializes, and
16336 -- Initial_Condition are affected by the SPARK mode in effect. In
16337 -- addition, these three pragmas are subject to an inherent order:
16339 -- 1) Abstract_State
16341 -- 3) Initial_Condition
16343 -- Analyze all these pragmas in the order outlined above
16345 Analyze_If_Present
(Pragma_SPARK_Mode
);
16346 Analyze_If_Present
(Pragma_Abstract_State
);
16348 -- A pragma that applies to a Ghost entity becomes Ghost for the
16349 -- purposes of legality checks and removal of ignored Ghost code.
16351 Mark_Pragma_As_Ghost
(N
, Pack_Id
);
16352 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
16354 Analyze_If_Present
(Pragma_Initial_Condition
);
16361 -- pragma Inline ( NAME {, NAME} );
16363 when Pragma_Inline
=>
16365 -- Pragma always active unless in GNATprove mode. It is disabled
16366 -- in GNATprove mode because frontend inlining is applied
16367 -- independently of pragmas Inline and Inline_Always for
16368 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16371 if not GNATprove_Mode
then
16373 -- Inline status is Enabled if option -gnatn is specified.
16374 -- However this status determines only the value of the
16375 -- Is_Inlined flag on the subprogram and does not prevent
16376 -- the pragma itself from being recorded for later use,
16377 -- in particular for a later modification of Is_Inlined
16378 -- independently of the -gnatn option.
16380 -- In other words, if -gnatn is specified for a unit, then
16381 -- all Inline pragmas processed for the compilation of this
16382 -- unit, including those in the spec of other units, are
16383 -- activated, so subprograms will be inlined across units.
16385 -- If -gnatn is not specified, no Inline pragma is activated
16386 -- here, which means that subprograms will not be inlined
16387 -- across units. The Is_Inlined flag will nevertheless be
16388 -- set later when bodies are analyzed, so subprograms will
16389 -- be inlined within the unit.
16391 if Inline_Active
then
16392 Process_Inline
(Enabled
);
16394 Process_Inline
(Disabled
);
16398 -------------------
16399 -- Inline_Always --
16400 -------------------
16402 -- pragma Inline_Always ( NAME {, NAME} );
16404 when Pragma_Inline_Always
=>
16407 -- Pragma always active unless in CodePeer mode or GNATprove
16408 -- mode. It is disabled in CodePeer mode because inlining is
16409 -- not helpful, and enabling it caused walk order issues. It
16410 -- is disabled in GNATprove mode because frontend inlining is
16411 -- applied independently of pragmas Inline and Inline_Always for
16412 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16415 if not CodePeer_Mode
and not GNATprove_Mode
then
16416 Process_Inline
(Enabled
);
16419 --------------------
16420 -- Inline_Generic --
16421 --------------------
16423 -- pragma Inline_Generic (NAME {, NAME});
16425 when Pragma_Inline_Generic
=>
16427 Process_Generic_List
;
16429 ----------------------
16430 -- Inspection_Point --
16431 ----------------------
16433 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16435 when Pragma_Inspection_Point
=> Inspection_Point
: declare
16442 if Arg_Count
> 0 then
16445 Exp
:= Get_Pragma_Arg
(Arg
);
16448 if not Is_Entity_Name
(Exp
)
16449 or else not Is_Object
(Entity
(Exp
))
16451 Error_Pragma_Arg
("object name required", Arg
);
16455 exit when No
(Arg
);
16458 end Inspection_Point
;
16464 -- pragma Interface (
16465 -- [ Convention =>] convention_IDENTIFIER,
16466 -- [ Entity =>] LOCAL_NAME
16467 -- [, [External_Name =>] static_string_EXPRESSION ]
16468 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16470 when Pragma_Interface
=>
16475 Name_External_Name
,
16477 Check_At_Least_N_Arguments
(2);
16478 Check_At_Most_N_Arguments
(4);
16479 Process_Import_Or_Interface
;
16481 -- In Ada 2005, the permission to use Interface (a reserved word)
16482 -- as a pragma name is considered an obsolescent feature, and this
16483 -- pragma was already obsolescent in Ada 95.
16485 if Ada_Version
>= Ada_95
then
16487 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16489 if Warn_On_Obsolescent_Feature
then
16491 ("pragma Interface is an obsolescent feature?j?", N
);
16493 ("|use pragma Import instead?j?", N
);
16497 --------------------
16498 -- Interface_Name --
16499 --------------------
16501 -- pragma Interface_Name (
16502 -- [ Entity =>] LOCAL_NAME
16503 -- [,[External_Name =>] static_string_EXPRESSION ]
16504 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16506 when Pragma_Interface_Name
=> Interface_Name
: declare
16508 Def_Id
: Entity_Id
;
16509 Hom_Id
: Entity_Id
;
16515 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
16516 Check_At_Least_N_Arguments
(2);
16517 Check_At_Most_N_Arguments
(3);
16518 Id
:= Get_Pragma_Arg
(Arg1
);
16521 -- This is obsolete from Ada 95 on, but it is an implementation
16522 -- defined pragma, so we do not consider that it violates the
16523 -- restriction (No_Obsolescent_Features).
16525 if Ada_Version
>= Ada_95
then
16526 if Warn_On_Obsolescent_Feature
then
16528 ("pragma Interface_Name is an obsolescent feature?j?", N
);
16530 ("|use pragma Import instead?j?", N
);
16534 if not Is_Entity_Name
(Id
) then
16536 ("first argument for pragma% must be entity name", Arg1
);
16537 elsif Etype
(Id
) = Any_Type
then
16540 Def_Id
:= Entity
(Id
);
16543 -- Special DEC-compatible processing for the object case, forces
16544 -- object to be imported.
16546 if Ekind
(Def_Id
) = E_Variable
then
16547 Kill_Size_Check_Code
(Def_Id
);
16548 Note_Possible_Modification
(Id
, Sure
=> False);
16550 -- Initialization is not allowed for imported variable
16552 if Present
(Expression
(Parent
(Def_Id
)))
16553 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
16555 Error_Msg_Sloc
:= Sloc
(Def_Id
);
16557 ("no initialization allowed for declaration of& #",
16561 -- For compatibility, support VADS usage of providing both
16562 -- pragmas Interface and Interface_Name to obtain the effect
16563 -- of a single Import pragma.
16565 if Is_Imported
(Def_Id
)
16566 and then Present
(First_Rep_Item
(Def_Id
))
16567 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
16569 Pragma_Name
(First_Rep_Item
(Def_Id
)) = Name_Interface
16573 Set_Imported
(Def_Id
);
16576 Set_Is_Public
(Def_Id
);
16577 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16580 -- Otherwise must be subprogram
16582 elsif not Is_Subprogram
(Def_Id
) then
16584 ("argument of pragma% is not subprogram", Arg1
);
16587 Check_At_Most_N_Arguments
(3);
16591 -- Loop through homonyms
16594 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
16596 if Is_Imported
(Def_Id
) then
16597 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16601 exit when From_Aspect_Specification
(N
);
16602 Hom_Id
:= Homonym
(Hom_Id
);
16604 exit when No
(Hom_Id
)
16605 or else Scope
(Hom_Id
) /= Current_Scope
;
16610 ("argument of pragma% is not imported subprogram",
16614 end Interface_Name
;
16616 -----------------------
16617 -- Interrupt_Handler --
16618 -----------------------
16620 -- pragma Interrupt_Handler (handler_NAME);
16622 when Pragma_Interrupt_Handler
=>
16623 Check_Ada_83_Warning
;
16624 Check_Arg_Count
(1);
16625 Check_No_Identifiers
;
16627 if No_Run_Time_Mode
then
16628 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
16630 Check_Interrupt_Or_Attach_Handler
;
16631 Process_Interrupt_Or_Attach_Handler
;
16634 ------------------------
16635 -- Interrupt_Priority --
16636 ------------------------
16638 -- pragma Interrupt_Priority [(EXPRESSION)];
16640 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
16641 P
: constant Node_Id
:= Parent
(N
);
16646 Check_Ada_83_Warning
;
16648 if Arg_Count
/= 0 then
16649 Arg
:= Get_Pragma_Arg
(Arg1
);
16650 Check_Arg_Count
(1);
16651 Check_No_Identifiers
;
16653 -- The expression must be analyzed in the special manner
16654 -- described in "Handling of Default and Per-Object
16655 -- Expressions" in sem.ads.
16657 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
16660 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
16665 Ent
:= Defining_Identifier
(Parent
(P
));
16667 -- Check duplicate pragma before we chain the pragma in the Rep
16668 -- Item chain of Ent.
16670 Check_Duplicate_Pragma
(Ent
);
16671 Record_Rep_Item
(Ent
, N
);
16673 -- Check the No_Task_At_Interrupt_Priority restriction
16675 if Nkind
(P
) = N_Task_Definition
then
16676 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16679 end Interrupt_Priority
;
16681 ---------------------
16682 -- Interrupt_State --
16683 ---------------------
16685 -- pragma Interrupt_State (
16686 -- [Name =>] INTERRUPT_ID,
16687 -- [State =>] INTERRUPT_STATE);
16689 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16690 -- INTERRUPT_STATE => System | Runtime | User
16692 -- Note: if the interrupt id is given as an identifier, then it must
16693 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16694 -- given as a static integer expression which must be in the range of
16695 -- Ada.Interrupts.Interrupt_ID.
16697 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16698 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16699 -- This is the entity Ada.Interrupts.Interrupt_ID;
16701 State_Type
: Character;
16702 -- Set to 's'/'r'/'u' for System/Runtime/User
16705 -- Index to entry in Interrupt_States table
16708 -- Value of interrupt
16710 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16711 -- The first argument to the pragma
16713 Int_Ent
: Entity_Id
;
16714 -- Interrupt entity in Ada.Interrupts.Names
16718 Check_Arg_Order
((Name_Name
, Name_State
));
16719 Check_Arg_Count
(2);
16721 Check_Optional_Identifier
(Arg1
, Name_Name
);
16722 Check_Optional_Identifier
(Arg2
, Name_State
);
16723 Check_Arg_Is_Identifier
(Arg2
);
16725 -- First argument is identifier
16727 if Nkind
(Arg1X
) = N_Identifier
then
16729 -- Search list of names in Ada.Interrupts.Names
16731 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16733 if No
(Int_Ent
) then
16734 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16736 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16737 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16741 Next_Entity
(Int_Ent
);
16744 -- First argument is not an identifier, so it must be a static
16745 -- expression of type Ada.Interrupts.Interrupt_ID.
16748 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16749 Int_Val
:= Expr_Value
(Arg1X
);
16751 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16753 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
16756 ("value not in range of type "
16757 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
16763 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16764 when Name_Runtime
=> State_Type
:= 'r';
16765 when Name_System
=> State_Type
:= 's';
16766 when Name_User
=> State_Type
:= 'u';
16769 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
16772 -- Check if entry is already stored
16774 IST_Num
:= Interrupt_States
.First
;
16776 -- If entry not found, add it
16778 if IST_Num
> Interrupt_States
.Last
then
16779 Interrupt_States
.Append
16780 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
16781 Interrupt_State
=> State_Type
,
16782 Pragma_Loc
=> Loc
));
16785 -- Case of entry for the same entry
16787 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
16790 -- If state matches, done, no need to make redundant entry
16793 State_Type
= Interrupt_States
.Table
(IST_Num
).
16796 -- Otherwise if state does not match, error
16799 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
16801 ("state conflicts with that given #", Arg2
);
16805 IST_Num
:= IST_Num
+ 1;
16807 end Interrupt_State
;
16813 -- pragma Invariant
16814 -- ([Entity =>] type_LOCAL_NAME,
16815 -- [Check =>] EXPRESSION
16816 -- [,[Message =>] String_Expression]);
16818 when Pragma_Invariant
=> Invariant
: declare
16823 CRec_Typ
: Entity_Id
;
16824 -- The corresponding record type of Full_Typ
16826 Full_Base
: Entity_Id
;
16827 -- The base type of Full_Typ
16829 Full_Typ
: Entity_Id
;
16830 -- The full view of Typ
16832 Priv_Typ
: Entity_Id
;
16833 -- The partial view of Typ
16837 Check_At_Least_N_Arguments
(2);
16838 Check_At_Most_N_Arguments
(3);
16839 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16840 Check_Optional_Identifier
(Arg2
, Name_Check
);
16842 if Arg_Count
= 3 then
16843 Check_Optional_Identifier
(Arg3
, Name_Message
);
16844 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
16847 Check_Arg_Is_Local_Name
(Arg1
);
16849 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
16850 Find_Type
(Typ_Arg
);
16851 Typ
:= Entity
(Typ_Arg
);
16853 -- Nothing to do of the related type is erroneous in some way
16855 if Typ
= Any_Type
then
16858 -- AI12-0041: Invariants are allowed in interface types
16860 elsif Is_Interface
(Typ
) then
16863 -- An invariant must apply to a private type, or appear in the
16864 -- private part of a package spec and apply to a completion.
16865 -- a class-wide invariant can only appear on a private declaration
16866 -- or private extension, not a completion.
16868 -- A [class-wide] invariant may be associated a [limited] private
16869 -- type or a private extension.
16871 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
16873 E_Record_Type_With_Private
)
16877 -- A non-class-wide invariant may be associated with the full view
16878 -- of a [limited] private type or a private extension.
16880 elsif Has_Private_Declaration
(Typ
)
16881 and then not Class_Present
(N
)
16885 -- A class-wide invariant may appear on the partial view only
16887 elsif Class_Present
(N
) then
16889 ("pragma % only allowed for private type", Arg1
);
16892 -- A regular invariant may appear on both views
16896 ("pragma % only allowed for private type or corresponding "
16897 & "full view", Arg1
);
16901 -- An invariant associated with an abstract type (this includes
16902 -- interfaces) must be class-wide.
16904 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
16906 ("pragma % not allowed for abstract type", Arg1
);
16910 -- A pragma that applies to a Ghost entity becomes Ghost for the
16911 -- purposes of legality checks and removal of ignored Ghost code.
16913 Mark_Pragma_As_Ghost
(N
, Typ
);
16915 -- The pragma defines a type-specific invariant, the type is said
16916 -- to have invariants of its "own".
16918 Set_Has_Own_Invariants
(Typ
);
16920 -- If the invariant is class-wide, then it can be inherited by
16921 -- derived or interface implementing types. The type is said to
16922 -- have "inheritable" invariants.
16924 if Class_Present
(N
) then
16925 Set_Has_Inheritable_Invariants
(Typ
);
16928 Get_Views
(Typ
, Priv_Typ
, Full_Typ
, Full_Base
, CRec_Typ
);
16930 -- Propagate invariant-related attributes to all views of the type
16931 -- and any additional types that may have been created.
16933 Propagate_Invariant_Attributes
(Priv_Typ
, From_Typ
=> Typ
);
16934 Propagate_Invariant_Attributes
(Full_Typ
, From_Typ
=> Typ
);
16935 Propagate_Invariant_Attributes
(Full_Base
, From_Typ
=> Typ
);
16936 Propagate_Invariant_Attributes
(CRec_Typ
, From_Typ
=> Typ
);
16938 -- Chain the pragma on to the rep item chain, for processing when
16939 -- the type is frozen.
16941 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16943 -- Create the declaration of the invariant procedure which will
16944 -- verify the invariant at run-time. Note that interfaces do not
16945 -- carry such a declaration.
16947 Build_Invariant_Procedure_Declaration
(Typ
);
16954 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16956 when Pragma_Keep_Names
=> Keep_Names
: declare
16961 Check_Arg_Count
(1);
16962 Check_Optional_Identifier
(Arg1
, Name_On
);
16963 Check_Arg_Is_Local_Name
(Arg1
);
16965 Arg
:= Get_Pragma_Arg
(Arg1
);
16968 if Etype
(Arg
) = Any_Type
then
16972 if not Is_Entity_Name
(Arg
)
16973 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16976 ("pragma% requires a local enumeration type", Arg1
);
16979 Set_Discard_Names
(Entity
(Arg
), False);
16986 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
16988 when Pragma_License
=>
16991 -- Do not analyze pragma any further in CodePeer mode, to avoid
16992 -- extraneous errors in this implementation-dependent pragma,
16993 -- which has a different profile on other compilers.
16995 if CodePeer_Mode
then
16999 Check_Arg_Count
(1);
17000 Check_No_Identifiers
;
17001 Check_Valid_Configuration_Pragma
;
17002 Check_Arg_Is_Identifier
(Arg1
);
17005 Sind
: constant Source_File_Index
:=
17006 Source_Index
(Current_Sem_Unit
);
17009 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17011 Set_License
(Sind
, GPL
);
17013 when Name_Modified_GPL
=>
17014 Set_License
(Sind
, Modified_GPL
);
17016 when Name_Restricted
=>
17017 Set_License
(Sind
, Restricted
);
17019 when Name_Unrestricted
=>
17020 Set_License
(Sind
, Unrestricted
);
17023 Error_Pragma_Arg
("invalid license name", Arg1
);
17031 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17033 when Pragma_Link_With
=> Link_With
: declare
17039 if Operating_Mode
= Generate_Code
17040 and then In_Extended_Main_Source_Unit
(N
)
17042 Check_At_Least_N_Arguments
(1);
17043 Check_No_Identifiers
;
17044 Check_Is_In_Decl_Part_Or_Package_Spec
;
17045 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17049 while Present
(Arg
) loop
17050 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17052 -- Store argument, converting sequences of spaces to a
17053 -- single null character (this is one of the differences
17054 -- in processing between Link_With and Linker_Options).
17056 Arg_Store
: declare
17057 C
: constant Char_Code
:= Get_Char_Code
(' ');
17058 S
: constant String_Id
:=
17059 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17060 L
: constant Nat
:= String_Length
(S
);
17063 procedure Skip_Spaces
;
17064 -- Advance F past any spaces
17070 procedure Skip_Spaces
is
17072 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17077 -- Start of processing for Arg_Store
17080 Skip_Spaces
; -- skip leading spaces
17082 -- Loop through characters, changing any embedded
17083 -- sequence of spaces to a single null character (this
17084 -- is how Link_With/Linker_Options differ)
17087 if Get_String_Char
(S
, F
) = C
then
17090 Store_String_Char
(ASCII
.NUL
);
17093 Store_String_Char
(Get_String_Char
(S
, F
));
17101 if Present
(Arg
) then
17102 Store_String_Char
(ASCII
.NUL
);
17106 Store_Linker_Option_String
(End_String
);
17114 -- pragma Linker_Alias (
17115 -- [Entity =>] LOCAL_NAME
17116 -- [Target =>] static_string_EXPRESSION);
17118 when Pragma_Linker_Alias
=>
17120 Check_Arg_Order
((Name_Entity
, Name_Target
));
17121 Check_Arg_Count
(2);
17122 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17123 Check_Optional_Identifier
(Arg2
, Name_Target
);
17124 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17125 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17127 -- The only processing required is to link this item on to the
17128 -- list of rep items for the given entity. This is accomplished
17129 -- by the call to Rep_Item_Too_Late (when no error is detected
17130 -- and False is returned).
17132 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17135 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17138 ------------------------
17139 -- Linker_Constructor --
17140 ------------------------
17142 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17144 -- Code is shared with Linker_Destructor
17146 -----------------------
17147 -- Linker_Destructor --
17148 -----------------------
17150 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17152 when Pragma_Linker_Constructor |
17153 Pragma_Linker_Destructor
=>
17154 Linker_Constructor
: declare
17160 Check_Arg_Count
(1);
17161 Check_No_Identifiers
;
17162 Check_Arg_Is_Local_Name
(Arg1
);
17163 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17165 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17167 if not Is_Library_Level_Entity
(Proc
) then
17169 ("argument for pragma% must be library level entity", Arg1
);
17172 -- The only processing required is to link this item on to the
17173 -- list of rep items for the given entity. This is accomplished
17174 -- by the call to Rep_Item_Too_Late (when no error is detected
17175 -- and False is returned).
17177 if Rep_Item_Too_Late
(Proc
, N
) then
17180 Set_Has_Gigi_Rep_Item
(Proc
);
17182 end Linker_Constructor
;
17184 --------------------
17185 -- Linker_Options --
17186 --------------------
17188 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17190 when Pragma_Linker_Options
=> Linker_Options
: declare
17194 Check_Ada_83_Warning
;
17195 Check_No_Identifiers
;
17196 Check_Arg_Count
(1);
17197 Check_Is_In_Decl_Part_Or_Package_Spec
;
17198 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17199 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17202 while Present
(Arg
) loop
17203 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17204 Store_String_Char
(ASCII
.NUL
);
17206 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17210 if Operating_Mode
= Generate_Code
17211 and then In_Extended_Main_Source_Unit
(N
)
17213 Store_Linker_Option_String
(End_String
);
17215 end Linker_Options
;
17217 --------------------
17218 -- Linker_Section --
17219 --------------------
17221 -- pragma Linker_Section (
17222 -- [Entity =>] LOCAL_NAME
17223 -- [Section =>] static_string_EXPRESSION);
17225 when Pragma_Linker_Section
=> Linker_Section
: declare
17230 Ghost_Error_Posted
: Boolean := False;
17231 -- Flag set when an error concerning the illegal mix of Ghost and
17232 -- non-Ghost subprograms is emitted.
17234 Ghost_Id
: Entity_Id
:= Empty
;
17235 -- The entity of the first Ghost subprogram encountered while
17236 -- processing the arguments of the pragma.
17240 Check_Arg_Order
((Name_Entity
, Name_Section
));
17241 Check_Arg_Count
(2);
17242 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17243 Check_Optional_Identifier
(Arg2
, Name_Section
);
17244 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17245 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17247 -- Check kind of entity
17249 Arg
:= Get_Pragma_Arg
(Arg1
);
17250 Ent
:= Entity
(Arg
);
17252 case Ekind
(Ent
) is
17254 -- Objects (constants and variables) and types. For these cases
17255 -- all we need to do is to set the Linker_Section_pragma field,
17256 -- checking that we do not have a duplicate.
17258 when E_Constant | E_Variable | Type_Kind
=>
17259 LPE
:= Linker_Section_Pragma
(Ent
);
17261 if Present
(LPE
) then
17262 Error_Msg_Sloc
:= Sloc
(LPE
);
17264 ("Linker_Section already specified for &#", Arg1
, Ent
);
17267 Set_Linker_Section_Pragma
(Ent
, N
);
17269 -- A pragma that applies to a Ghost entity becomes Ghost for
17270 -- the purposes of legality checks and removal of ignored
17273 Mark_Pragma_As_Ghost
(N
, Ent
);
17277 when Subprogram_Kind
=>
17279 -- Aspect case, entity already set
17281 if From_Aspect_Specification
(N
) then
17282 Set_Linker_Section_Pragma
17283 (Entity
(Corresponding_Aspect
(N
)), N
);
17285 -- Pragma case, we must climb the homonym chain, but skip
17286 -- any for which the linker section is already set.
17290 if No
(Linker_Section_Pragma
(Ent
)) then
17291 Set_Linker_Section_Pragma
(Ent
, N
);
17293 -- A pragma that applies to a Ghost entity becomes
17294 -- Ghost for the purposes of legality checks and
17295 -- removal of ignored Ghost code.
17297 Mark_Pragma_As_Ghost
(N
, Ent
);
17299 -- Capture the entity of the first Ghost subprogram
17300 -- being processed for error detection purposes.
17302 if Is_Ghost_Entity
(Ent
) then
17303 if No
(Ghost_Id
) then
17307 -- Otherwise the subprogram is non-Ghost. It is
17308 -- illegal to mix references to Ghost and non-Ghost
17309 -- entities (SPARK RM 6.9).
17311 elsif Present
(Ghost_Id
)
17312 and then not Ghost_Error_Posted
17314 Ghost_Error_Posted
:= True;
17316 Error_Msg_Name_1
:= Pname
;
17318 ("pragma % cannot mention ghost and "
17319 & "non-ghost subprograms", N
);
17321 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17323 ("\& # declared as ghost", N
, Ghost_Id
);
17325 Error_Msg_Sloc
:= Sloc
(Ent
);
17327 ("\& # declared as non-ghost", N
, Ent
);
17331 Ent
:= Homonym
(Ent
);
17333 or else Scope
(Ent
) /= Current_Scope
;
17337 -- All other cases are illegal
17341 ("pragma% applies only to objects, subprograms, and types",
17344 end Linker_Section
;
17350 -- pragma List (On | Off)
17352 -- There is nothing to do here, since we did all the processing for
17353 -- this pragma in Par.Prag (so that it works properly even in syntax
17356 when Pragma_List
=>
17363 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17365 when Pragma_Lock_Free
=> Lock_Free
: declare
17366 P
: constant Node_Id
:= Parent
(N
);
17372 Check_No_Identifiers
;
17373 Check_At_Most_N_Arguments
(1);
17375 -- Protected definition case
17377 if Nkind
(P
) = N_Protected_Definition
then
17378 Ent
:= Defining_Identifier
(Parent
(P
));
17382 if Arg_Count
= 1 then
17383 Arg
:= Get_Pragma_Arg
(Arg1
);
17384 Val
:= Is_True
(Static_Boolean
(Arg
));
17386 -- No arguments (expression is considered to be True)
17392 -- Check duplicate pragma before we chain the pragma in the Rep
17393 -- Item chain of Ent.
17395 Check_Duplicate_Pragma
(Ent
);
17396 Record_Rep_Item
(Ent
, N
);
17397 Set_Uses_Lock_Free
(Ent
, Val
);
17399 -- Anything else is incorrect placement
17406 --------------------
17407 -- Locking_Policy --
17408 --------------------
17410 -- pragma Locking_Policy (policy_IDENTIFIER);
17412 when Pragma_Locking_Policy
=> declare
17413 subtype LP_Range
is Name_Id
17414 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
17419 Check_Ada_83_Warning
;
17420 Check_Arg_Count
(1);
17421 Check_No_Identifiers
;
17422 Check_Arg_Is_Locking_Policy
(Arg1
);
17423 Check_Valid_Configuration_Pragma
;
17424 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17427 when Name_Ceiling_Locking
=>
17429 when Name_Inheritance_Locking
=>
17431 when Name_Concurrent_Readers_Locking
=>
17435 if Locking_Policy
/= ' '
17436 and then Locking_Policy
/= LP
17438 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17439 Error_Pragma
("locking policy incompatible with policy#");
17441 -- Set new policy, but always preserve System_Location since we
17442 -- like the error message with the run time name.
17445 Locking_Policy
:= LP
;
17447 if Locking_Policy_Sloc
/= System_Location
then
17448 Locking_Policy_Sloc
:= Loc
;
17453 -------------------
17454 -- Loop_Optimize --
17455 -------------------
17457 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17459 -- OPTIMIZATION_HINT ::=
17460 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17462 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
17467 Check_At_Least_N_Arguments
(1);
17468 Check_No_Identifiers
;
17470 Hint
:= First
(Pragma_Argument_Associations
(N
));
17471 while Present
(Hint
) loop
17472 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
17480 Check_Loop_Pragma_Placement
;
17487 -- pragma Loop_Variant
17488 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17490 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17492 -- CHANGE_DIRECTION ::= Increases | Decreases
17494 when Pragma_Loop_Variant
=> Loop_Variant
: declare
17499 Check_At_Least_N_Arguments
(1);
17500 Check_Loop_Pragma_Placement
;
17502 -- Process all increasing / decreasing expressions
17504 Variant
:= First
(Pragma_Argument_Associations
(N
));
17505 while Present
(Variant
) loop
17506 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
17509 Error_Pragma_Arg
("wrong change modifier", Variant
);
17512 Preanalyze_Assert_Expression
17513 (Expression
(Variant
), Any_Discrete
);
17519 -----------------------
17520 -- Machine_Attribute --
17521 -----------------------
17523 -- pragma Machine_Attribute (
17524 -- [Entity =>] LOCAL_NAME,
17525 -- [Attribute_Name =>] static_string_EXPRESSION
17526 -- [, [Info =>] static_EXPRESSION] );
17528 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
17529 Def_Id
: Entity_Id
;
17533 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
17535 if Arg_Count
= 3 then
17536 Check_Optional_Identifier
(Arg3
, Name_Info
);
17537 Check_Arg_Is_OK_Static_Expression
(Arg3
);
17539 Check_Arg_Count
(2);
17542 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17543 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
17544 Check_Arg_Is_Local_Name
(Arg1
);
17545 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17546 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17548 if Is_Access_Type
(Def_Id
) then
17549 Def_Id
:= Designated_Type
(Def_Id
);
17552 if Rep_Item_Too_Early
(Def_Id
, N
) then
17556 Def_Id
:= Underlying_Type
(Def_Id
);
17558 -- The only processing required is to link this item on to the
17559 -- list of rep items for the given entity. This is accomplished
17560 -- by the call to Rep_Item_Too_Late (when no error is detected
17561 -- and False is returned).
17563 if Rep_Item_Too_Late
(Def_Id
, N
) then
17566 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17568 end Machine_Attribute
;
17575 -- (MAIN_OPTION [, MAIN_OPTION]);
17578 -- [STACK_SIZE =>] static_integer_EXPRESSION
17579 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17580 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17582 when Pragma_Main
=> Main
: declare
17583 Args
: Args_List
(1 .. 3);
17584 Names
: constant Name_List
(1 .. 3) := (
17586 Name_Task_Stack_Size_Default
,
17587 Name_Time_Slicing_Enabled
);
17593 Gather_Associations
(Names
, Args
);
17595 for J
in 1 .. 2 loop
17596 if Present
(Args
(J
)) then
17597 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17601 if Present
(Args
(3)) then
17602 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
17606 while Present
(Nod
) loop
17607 if Nkind
(Nod
) = N_Pragma
17608 and then Pragma_Name
(Nod
) = Name_Main
17610 Error_Msg_Name_1
:= Pname
;
17611 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17622 -- pragma Main_Storage
17623 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17625 -- MAIN_STORAGE_OPTION ::=
17626 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17627 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17629 when Pragma_Main_Storage
=> Main_Storage
: declare
17630 Args
: Args_List
(1 .. 2);
17631 Names
: constant Name_List
(1 .. 2) := (
17632 Name_Working_Storage
,
17639 Gather_Associations
(Names
, Args
);
17641 for J
in 1 .. 2 loop
17642 if Present
(Args
(J
)) then
17643 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17647 Check_In_Main_Program
;
17650 while Present
(Nod
) loop
17651 if Nkind
(Nod
) = N_Pragma
17652 and then Pragma_Name
(Nod
) = Name_Main_Storage
17654 Error_Msg_Name_1
:= Pname
;
17655 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17666 -- pragma Memory_Size (NUMERIC_LITERAL)
17668 when Pragma_Memory_Size
=>
17671 -- Memory size is simply ignored
17673 Check_No_Identifiers
;
17674 Check_Arg_Count
(1);
17675 Check_Arg_Is_Integer_Literal
(Arg1
);
17683 -- The only correct use of this pragma is on its own in a file, in
17684 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17685 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17686 -- check for a file containing nothing but a No_Body pragma). If we
17687 -- attempt to process it during normal semantics processing, it means
17688 -- it was misplaced.
17690 when Pragma_No_Body
=>
17694 -----------------------------
17695 -- No_Elaboration_Code_All --
17696 -----------------------------
17698 -- pragma No_Elaboration_Code_All;
17700 when Pragma_No_Elaboration_Code_All
=>
17702 Check_Valid_Library_Unit_Pragma
;
17704 if Nkind
(N
) = N_Null_Statement
then
17708 -- Must appear for a spec or generic spec
17710 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
17711 N_Generic_Package_Declaration
,
17712 N_Generic_Subprogram_Declaration
,
17713 N_Package_Declaration
,
17714 N_Subprogram_Declaration
)
17718 ("pragma% can only occur for package "
17719 & "or subprogram spec"));
17722 -- Set flag in unit table
17724 Set_No_Elab_Code_All
(Current_Sem_Unit
);
17726 -- Set restriction No_Elaboration_Code if this is the main unit
17728 if Current_Sem_Unit
= Main_Unit
then
17729 Set_Restriction
(No_Elaboration_Code
, N
);
17732 -- If we are in the main unit or in an extended main source unit,
17733 -- then we also add it to the configuration restrictions so that
17734 -- it will apply to all units in the extended main source.
17736 if Current_Sem_Unit
= Main_Unit
17737 or else In_Extended_Main_Source_Unit
(N
)
17739 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
17742 -- If in main extended unit, activate transitive with test
17744 if In_Extended_Main_Source_Unit
(N
) then
17745 Opt
.No_Elab_Code_All_Pragma
:= N
;
17752 -- pragma No_Inline ( NAME {, NAME} );
17754 when Pragma_No_Inline
=>
17756 Process_Inline
(Suppressed
);
17762 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17764 when Pragma_No_Return
=> No_Return
: declare
17770 Ghost_Error_Posted
: Boolean := False;
17771 -- Flag set when an error concerning the illegal mix of Ghost and
17772 -- non-Ghost subprograms is emitted.
17774 Ghost_Id
: Entity_Id
:= Empty
;
17775 -- The entity of the first Ghost procedure encountered while
17776 -- processing the arguments of the pragma.
17780 Check_At_Least_N_Arguments
(1);
17782 -- Loop through arguments of pragma
17785 while Present
(Arg
) loop
17786 Check_Arg_Is_Local_Name
(Arg
);
17787 Id
:= Get_Pragma_Arg
(Arg
);
17790 if not Is_Entity_Name
(Id
) then
17791 Error_Pragma_Arg
("entity name required", Arg
);
17794 if Etype
(Id
) = Any_Type
then
17798 -- Loop to find matching procedures
17804 and then Scope
(E
) = Current_Scope
17806 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
17809 -- A pragma that applies to a Ghost entity becomes Ghost
17810 -- for the purposes of legality checks and removal of
17811 -- ignored Ghost code.
17813 Mark_Pragma_As_Ghost
(N
, E
);
17815 -- Capture the entity of the first Ghost procedure being
17816 -- processed for error detection purposes.
17818 if Is_Ghost_Entity
(E
) then
17819 if No
(Ghost_Id
) then
17823 -- Otherwise the subprogram is non-Ghost. It is illegal
17824 -- to mix references to Ghost and non-Ghost entities
17827 elsif Present
(Ghost_Id
)
17828 and then not Ghost_Error_Posted
17830 Ghost_Error_Posted
:= True;
17832 Error_Msg_Name_1
:= Pname
;
17834 ("pragma % cannot mention ghost and non-ghost "
17835 & "procedures", N
);
17837 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17838 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
17840 Error_Msg_Sloc
:= Sloc
(E
);
17841 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
17844 -- Set flag on any alias as well
17846 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
17847 Set_No_Return
(Alias
(E
));
17853 exit when From_Aspect_Specification
(N
);
17857 -- If entity in not in current scope it may be the enclosing
17858 -- suprogram body to which the aspect applies.
17861 if Entity
(Id
) = Current_Scope
17862 and then From_Aspect_Specification
(N
)
17864 Set_No_Return
(Entity
(Id
));
17866 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
17878 -- pragma No_Run_Time;
17880 -- Note: this pragma is retained for backwards compatibility. See
17881 -- body of Rtsfind for full details on its handling.
17883 when Pragma_No_Run_Time
=>
17885 Check_Valid_Configuration_Pragma
;
17886 Check_Arg_Count
(0);
17888 -- Remove backward compatibility if Build_Type is FSF or GPL and
17889 -- generate a warning.
17892 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
17895 Error_Pragma
("pragma% is ignored, has no effect??");
17897 No_Run_Time_Mode
:= True;
17898 Configurable_Run_Time_Mode
:= True;
17900 -- Set Duration to 32 bits if word size is 32
17902 if Ttypes
.System_Word_Size
= 32 then
17903 Duration_32_Bits_On_Target
:= True;
17906 -- Set appropriate restrictions
17908 Set_Restriction
(No_Finalization
, N
);
17909 Set_Restriction
(No_Exception_Handlers
, N
);
17910 Set_Restriction
(Max_Tasks
, N
, 0);
17911 Set_Restriction
(No_Tasking
, N
);
17915 -----------------------
17916 -- No_Tagged_Streams --
17917 -----------------------
17919 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
17921 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
17927 Check_At_Most_N_Arguments
(1);
17929 -- One argument case
17931 if Arg_Count
= 1 then
17932 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17933 Check_Arg_Is_Local_Name
(Arg1
);
17934 E_Id
:= Get_Pragma_Arg
(Arg1
);
17936 if Etype
(E_Id
) = Any_Type
then
17940 E
:= Entity
(E_Id
);
17942 Check_Duplicate_Pragma
(E
);
17944 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
17946 ("argument for pragma% must be root tagged type", Arg1
);
17949 if Rep_Item_Too_Early
(E
, N
)
17951 Rep_Item_Too_Late
(E
, N
)
17955 Set_No_Tagged_Streams_Pragma
(E
, N
);
17958 -- Zero argument case
17961 Check_Is_In_Decl_Part_Or_Package_Spec
;
17962 No_Tagged_Streams
:= N
;
17964 end No_Tagged_Strms
;
17966 ------------------------
17967 -- No_Strict_Aliasing --
17968 ------------------------
17970 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
17972 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
17977 Check_At_Most_N_Arguments
(1);
17979 if Arg_Count
= 0 then
17980 Check_Valid_Configuration_Pragma
;
17981 Opt
.No_Strict_Aliasing
:= True;
17984 Check_Optional_Identifier
(Arg2
, Name_Entity
);
17985 Check_Arg_Is_Local_Name
(Arg1
);
17986 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17988 if E_Id
= Any_Type
then
17990 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
17991 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
17994 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
17996 end No_Strict_Aliasing
;
17998 -----------------------
17999 -- Normalize_Scalars --
18000 -----------------------
18002 -- pragma Normalize_Scalars;
18004 when Pragma_Normalize_Scalars
=>
18005 Check_Ada_83_Warning
;
18006 Check_Arg_Count
(0);
18007 Check_Valid_Configuration_Pragma
;
18009 -- Normalize_Scalars creates false positives in CodePeer, and
18010 -- incorrect negative results in GNATprove mode, so ignore this
18011 -- pragma in these modes.
18013 if not (CodePeer_Mode
or GNATprove_Mode
) then
18014 Normalize_Scalars
:= True;
18015 Init_Or_Norm_Scalars
:= True;
18022 -- pragma Obsolescent;
18024 -- pragma Obsolescent (
18025 -- [Message =>] static_string_EXPRESSION
18026 -- [,[Version =>] Ada_05]]);
18028 -- pragma Obsolescent (
18029 -- [Entity =>] NAME
18030 -- [,[Message =>] static_string_EXPRESSION
18031 -- [,[Version =>] Ada_05]] );
18033 when Pragma_Obsolescent
=> Obsolescent
: declare
18037 procedure Set_Obsolescent
(E
: Entity_Id
);
18038 -- Given an entity Ent, mark it as obsolescent if appropriate
18040 ---------------------
18041 -- Set_Obsolescent --
18042 ---------------------
18044 procedure Set_Obsolescent
(E
: Entity_Id
) is
18053 -- A pragma that applies to a Ghost entity becomes Ghost for
18054 -- the purposes of legality checks and removal of ignored Ghost
18057 Mark_Pragma_As_Ghost
(N
, E
);
18059 -- Entity name was given
18061 if Present
(Ename
) then
18063 -- If entity name matches, we are fine. Save entity in
18064 -- pragma argument, for ASIS use.
18066 if Chars
(Ename
) = Chars
(Ent
) then
18067 Set_Entity
(Ename
, Ent
);
18068 Generate_Reference
(Ent
, Ename
);
18070 -- If entity name does not match, only possibility is an
18071 -- enumeration literal from an enumeration type declaration.
18073 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
18075 ("pragma % entity name does not match declaration");
18078 Ent
:= First_Literal
(E
);
18082 ("pragma % entity name does not match any "
18083 & "enumeration literal");
18085 elsif Chars
(Ent
) = Chars
(Ename
) then
18086 Set_Entity
(Ename
, Ent
);
18087 Generate_Reference
(Ent
, Ename
);
18091 Ent
:= Next_Literal
(Ent
);
18097 -- Ent points to entity to be marked
18099 if Arg_Count
>= 1 then
18101 -- Deal with static string argument
18103 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18104 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
18106 for J
in 1 .. String_Length
(S
) loop
18107 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
18109 ("pragma% argument does not allow wide characters",
18114 Obsolescent_Warnings
.Append
18115 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
18117 -- Check for Ada_05 parameter
18119 if Arg_Count
/= 1 then
18120 Check_Arg_Count
(2);
18123 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
18126 Check_Arg_Is_Identifier
(Argx
);
18128 if Chars
(Argx
) /= Name_Ada_05
then
18129 Error_Msg_Name_2
:= Name_Ada_05
;
18131 ("only allowed argument for pragma% is %", Argx
);
18134 if Ada_Version_Explicit
< Ada_2005
18135 or else not Warn_On_Ada_2005_Compatibility
18143 -- Set flag if pragma active
18146 Set_Is_Obsolescent
(Ent
);
18150 end Set_Obsolescent
;
18152 -- Start of processing for pragma Obsolescent
18157 Check_At_Most_N_Arguments
(3);
18159 -- See if first argument specifies an entity name
18163 (Chars
(Arg1
) = Name_Entity
18165 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
18167 N_Operator_Symbol
))
18169 Ename
:= Get_Pragma_Arg
(Arg1
);
18171 -- Eliminate first argument, so we can share processing
18175 Arg_Count
:= Arg_Count
- 1;
18177 -- No Entity name argument given
18183 if Arg_Count
>= 1 then
18184 Check_Optional_Identifier
(Arg1
, Name_Message
);
18186 if Arg_Count
= 2 then
18187 Check_Optional_Identifier
(Arg2
, Name_Version
);
18191 -- Get immediately preceding declaration
18194 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
18198 -- Cases where we do not follow anything other than another pragma
18202 -- First case: library level compilation unit declaration with
18203 -- the pragma immediately following the declaration.
18205 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
18207 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
18210 -- Case 2: library unit placement for package
18214 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
18216 if Is_Package_Or_Generic_Package
(Ent
) then
18217 Set_Obsolescent
(Ent
);
18223 -- Cases where we must follow a declaration, including an
18224 -- abstract subprogram declaration, which is not in the
18225 -- other node subtypes.
18228 if Nkind
(Decl
) not in N_Declaration
18229 and then Nkind
(Decl
) not in N_Later_Decl_Item
18230 and then Nkind
(Decl
) not in N_Generic_Declaration
18231 and then Nkind
(Decl
) not in N_Renaming_Declaration
18232 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
18235 ("pragma% misplaced, "
18236 & "must immediately follow a declaration");
18239 Set_Obsolescent
(Defining_Entity
(Decl
));
18249 -- pragma Optimize (Time | Space | Off);
18251 -- The actual check for optimize is done in Gigi. Note that this
18252 -- pragma does not actually change the optimization setting, it
18253 -- simply checks that it is consistent with the pragma.
18255 when Pragma_Optimize
=>
18256 Check_No_Identifiers
;
18257 Check_Arg_Count
(1);
18258 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
18260 ------------------------
18261 -- Optimize_Alignment --
18262 ------------------------
18264 -- pragma Optimize_Alignment (Time | Space | Off);
18266 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
18268 Check_No_Identifiers
;
18269 Check_Arg_Count
(1);
18270 Check_Valid_Configuration_Pragma
;
18273 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
18277 Opt
.Optimize_Alignment
:= 'T';
18279 Opt
.Optimize_Alignment
:= 'S';
18281 Opt
.Optimize_Alignment
:= 'O';
18283 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
18287 -- Set indication that mode is set locally. If we are in fact in a
18288 -- configuration pragma file, this setting is harmless since the
18289 -- switch will get reset anyway at the start of each unit.
18291 Optimize_Alignment_Local
:= True;
18292 end Optimize_Alignment
;
18298 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18300 when Pragma_Ordered
=> Ordered
: declare
18301 Assoc
: constant Node_Id
:= Arg1
;
18307 Check_No_Identifiers
;
18308 Check_Arg_Count
(1);
18309 Check_Arg_Is_Local_Name
(Arg1
);
18311 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18312 Find_Type
(Type_Id
);
18313 Typ
:= Entity
(Type_Id
);
18315 if Typ
= Any_Type
then
18318 Typ
:= Underlying_Type
(Typ
);
18321 if not Is_Enumeration_Type
(Typ
) then
18322 Error_Pragma
("pragma% must specify enumeration type");
18325 Check_First_Subtype
(Arg1
);
18326 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
18329 -------------------
18330 -- Overflow_Mode --
18331 -------------------
18333 -- pragma Overflow_Mode
18334 -- ([General => ] MODE [, [Assertions => ] MODE]);
18336 -- MODE := STRICT | MINIMIZED | ELIMINATED
18338 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18339 -- since System.Bignums makes this assumption. This is true of nearly
18340 -- all (all?) targets.
18342 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
18343 function Get_Overflow_Mode
18345 Arg
: Node_Id
) return Overflow_Mode_Type
;
18346 -- Function to process one pragma argument, Arg. If an identifier
18347 -- is present, it must be Name. Mode type is returned if a valid
18348 -- argument exists, otherwise an error is signalled.
18350 -----------------------
18351 -- Get_Overflow_Mode --
18352 -----------------------
18354 function Get_Overflow_Mode
18356 Arg
: Node_Id
) return Overflow_Mode_Type
18358 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
18361 Check_Optional_Identifier
(Arg
, Name
);
18362 Check_Arg_Is_Identifier
(Argx
);
18364 if Chars
(Argx
) = Name_Strict
then
18367 elsif Chars
(Argx
) = Name_Minimized
then
18370 elsif Chars
(Argx
) = Name_Eliminated
then
18371 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
18373 ("Eliminated not implemented on this target", Argx
);
18379 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
18381 end Get_Overflow_Mode
;
18383 -- Start of processing for Overflow_Mode
18387 Check_At_Least_N_Arguments
(1);
18388 Check_At_Most_N_Arguments
(2);
18390 -- Process first argument
18392 Scope_Suppress
.Overflow_Mode_General
:=
18393 Get_Overflow_Mode
(Name_General
, Arg1
);
18395 -- Case of only one argument
18397 if Arg_Count
= 1 then
18398 Scope_Suppress
.Overflow_Mode_Assertions
:=
18399 Scope_Suppress
.Overflow_Mode_General
;
18401 -- Case of two arguments present
18404 Scope_Suppress
.Overflow_Mode_Assertions
:=
18405 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
18409 --------------------------
18410 -- Overriding Renamings --
18411 --------------------------
18413 -- pragma Overriding_Renamings;
18415 when Pragma_Overriding_Renamings
=>
18417 Check_Arg_Count
(0);
18418 Check_Valid_Configuration_Pragma
;
18419 Overriding_Renamings
:= True;
18425 -- pragma Pack (first_subtype_LOCAL_NAME);
18427 when Pragma_Pack
=> Pack
: declare
18428 Assoc
: constant Node_Id
:= Arg1
;
18430 Ignore
: Boolean := False;
18435 Check_No_Identifiers
;
18436 Check_Arg_Count
(1);
18437 Check_Arg_Is_Local_Name
(Arg1
);
18438 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18440 if not Is_Entity_Name
(Type_Id
)
18441 or else not Is_Type
(Entity
(Type_Id
))
18444 ("argument for pragma% must be type or subtype", Arg1
);
18447 Find_Type
(Type_Id
);
18448 Typ
:= Entity
(Type_Id
);
18451 or else Rep_Item_Too_Early
(Typ
, N
)
18455 Typ
:= Underlying_Type
(Typ
);
18458 -- A pragma that applies to a Ghost entity becomes Ghost for the
18459 -- purposes of legality checks and removal of ignored Ghost code.
18461 Mark_Pragma_As_Ghost
(N
, Typ
);
18463 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
18464 Error_Pragma
("pragma% must specify array or record type");
18467 Check_First_Subtype
(Arg1
);
18468 Check_Duplicate_Pragma
(Typ
);
18472 if Is_Array_Type
(Typ
) then
18473 Ctyp
:= Component_Type
(Typ
);
18475 -- Ignore pack that does nothing
18477 if Known_Static_Esize
(Ctyp
)
18478 and then Known_Static_RM_Size
(Ctyp
)
18479 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
18480 and then Addressable
(Esize
(Ctyp
))
18485 -- Process OK pragma Pack. Note that if there is a separate
18486 -- component clause present, the Pack will be cancelled. This
18487 -- processing is in Freeze.
18489 if not Rep_Item_Too_Late
(Typ
, N
) then
18491 -- In CodePeer mode, we do not need complex front-end
18492 -- expansions related to pragma Pack, so disable handling
18495 if CodePeer_Mode
then
18498 -- Normal case where we do the pack action
18502 Set_Is_Packed
(Base_Type
(Typ
));
18503 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18506 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18510 -- For record types, the pack is always effective
18512 else pragma Assert
(Is_Record_Type
(Typ
));
18513 if not Rep_Item_Too_Late
(Typ
, N
) then
18514 Set_Is_Packed
(Base_Type
(Typ
));
18515 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18516 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18527 -- There is nothing to do here, since we did all the processing for
18528 -- this pragma in Par.Prag (so that it works properly even in syntax
18531 when Pragma_Page
=>
18538 -- pragma Part_Of (ABSTRACT_STATE);
18540 -- ABSTRACT_STATE ::= NAME
18542 when Pragma_Part_Of
=> Part_Of
: declare
18543 procedure Propagate_Part_Of
18544 (Pack_Id
: Entity_Id
;
18545 State_Id
: Entity_Id
;
18546 Instance
: Node_Id
);
18547 -- Propagate the Part_Of indicator to all abstract states and
18548 -- objects declared in the visible state space of a package
18549 -- denoted by Pack_Id. State_Id is the encapsulating state.
18550 -- Instance is the package instantiation node.
18552 -----------------------
18553 -- Propagate_Part_Of --
18554 -----------------------
18556 procedure Propagate_Part_Of
18557 (Pack_Id
: Entity_Id
;
18558 State_Id
: Entity_Id
;
18559 Instance
: Node_Id
)
18561 Has_Item
: Boolean := False;
18562 -- Flag set when the visible state space contains at least one
18563 -- abstract state or variable.
18565 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
18566 -- Propagate the Part_Of indicator to all abstract states and
18567 -- objects declared in the visible state space of a package
18568 -- denoted by Pack_Id.
18570 -----------------------
18571 -- Propagate_Part_Of --
18572 -----------------------
18574 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
18575 Constits
: Elist_Id
;
18576 Item_Id
: Entity_Id
;
18579 -- Traverse the entity chain of the package and set relevant
18580 -- attributes of abstract states and objects declared in the
18581 -- visible state space of the package.
18583 Item_Id
:= First_Entity
(Pack_Id
);
18584 while Present
(Item_Id
)
18585 and then not In_Private_Part
(Item_Id
)
18587 -- Do not consider internally generated items
18589 if not Comes_From_Source
(Item_Id
) then
18592 -- The Part_Of indicator turns an abstract state or an
18593 -- object into a constituent of the encapsulating state.
18595 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
18600 Constits
:= Part_Of_Constituents
(State_Id
);
18602 if No
(Constits
) then
18603 Constits
:= New_Elmt_List
;
18604 Set_Part_Of_Constituents
(State_Id
, Constits
);
18607 Append_Elmt
(Item_Id
, Constits
);
18608 Set_Encapsulating_State
(Item_Id
, State_Id
);
18610 -- Recursively handle nested packages and instantiations
18612 elsif Ekind
(Item_Id
) = E_Package
then
18613 Propagate_Part_Of
(Item_Id
);
18616 Next_Entity
(Item_Id
);
18618 end Propagate_Part_Of
;
18620 -- Start of processing for Propagate_Part_Of
18623 Propagate_Part_Of
(Pack_Id
);
18625 -- Detect a package instantiation that is subject to a Part_Of
18626 -- indicator, but has no visible state.
18628 if not Has_Item
then
18630 ("package instantiation & has Part_Of indicator but "
18631 & "lacks visible state", Instance
, Pack_Id
);
18633 end Propagate_Part_Of
;
18637 Constits
: Elist_Id
;
18639 Encap_Id
: Entity_Id
;
18640 Item_Id
: Entity_Id
;
18644 -- Start of processing for Part_Of
18648 Check_No_Identifiers
;
18649 Check_Arg_Count
(1);
18651 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
18653 -- Object declaration
18655 if Nkind
(Stmt
) = N_Object_Declaration
then
18658 -- Package instantiation
18660 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
18663 -- Single concurrent type declaration
18665 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
18668 -- Otherwise the pragma is associated with an illegal construct
18675 -- Extract the entity of the related object declaration or package
18676 -- instantiation. In the case of the instantiation, use the entity
18677 -- of the instance spec.
18679 if Nkind
(Stmt
) = N_Package_Instantiation
then
18680 Stmt
:= Instance_Spec
(Stmt
);
18683 Item_Id
:= Defining_Entity
(Stmt
);
18684 Encap
:= Get_Pragma_Arg
(Arg1
);
18686 -- A pragma that applies to a Ghost entity becomes Ghost for the
18687 -- purposes of legality checks and removal of ignored Ghost code.
18689 Mark_Pragma_As_Ghost
(N
, Item_Id
);
18691 -- Chain the pragma on the contract for further processing by
18692 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18694 Add_Contract_Item
(N
, Item_Id
);
18696 -- A variable may act as constituent of a single concurrent type
18697 -- which in turn could be declared after the variable. Due to this
18698 -- discrepancy, the full analysis of indicator Part_Of is delayed
18699 -- until the end of the enclosing declarative region (see routine
18700 -- Analyze_Part_Of_In_Decl_Part).
18702 if Ekind
(Item_Id
) = E_Variable
then
18705 -- Otherwise indicator Part_Of applies to a constant or a package
18709 -- Detect any discrepancies between the placement of the
18710 -- constant or package instantiation with respect to state
18711 -- space and the encapsulating state.
18715 Item_Id
=> Item_Id
,
18717 Encap_Id
=> Encap_Id
,
18721 pragma Assert
(Present
(Encap_Id
));
18723 if Ekind
(Item_Id
) = E_Constant
then
18724 Constits
:= Part_Of_Constituents
(Encap_Id
);
18726 if No
(Constits
) then
18727 Constits
:= New_Elmt_List
;
18728 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
18731 Append_Elmt
(Item_Id
, Constits
);
18732 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
18734 -- Propagate the Part_Of indicator to the visible state
18735 -- space of the package instantiation.
18739 (Pack_Id
=> Item_Id
,
18740 State_Id
=> Encap_Id
,
18747 ----------------------------------
18748 -- Partition_Elaboration_Policy --
18749 ----------------------------------
18751 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18753 when Pragma_Partition_Elaboration_Policy
=> declare
18754 subtype PEP_Range
is Name_Id
18755 range First_Partition_Elaboration_Policy_Name
18756 .. Last_Partition_Elaboration_Policy_Name
;
18757 PEP_Val
: PEP_Range
;
18762 Check_Arg_Count
(1);
18763 Check_No_Identifiers
;
18764 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
18765 Check_Valid_Configuration_Pragma
;
18766 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18769 when Name_Concurrent
=>
18771 when Name_Sequential
=>
18775 if Partition_Elaboration_Policy
/= ' '
18776 and then Partition_Elaboration_Policy
/= PEP
18778 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
18780 ("partition elaboration policy incompatible with policy#");
18782 -- Set new policy, but always preserve System_Location since we
18783 -- like the error message with the run time name.
18786 Partition_Elaboration_Policy
:= PEP
;
18788 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
18789 Partition_Elaboration_Policy_Sloc
:= Loc
;
18798 -- pragma Passive [(PASSIVE_FORM)];
18800 -- PASSIVE_FORM ::= Semaphore | No
18802 when Pragma_Passive
=>
18805 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
18806 Error_Pragma
("pragma% must be within task definition");
18809 if Arg_Count
/= 0 then
18810 Check_Arg_Count
(1);
18811 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
18814 ----------------------------------
18815 -- Preelaborable_Initialization --
18816 ----------------------------------
18818 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18820 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
18825 Check_Arg_Count
(1);
18826 Check_No_Identifiers
;
18827 Check_Arg_Is_Identifier
(Arg1
);
18828 Check_Arg_Is_Local_Name
(Arg1
);
18829 Check_First_Subtype
(Arg1
);
18830 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18832 -- A pragma that applies to a Ghost entity becomes Ghost for the
18833 -- purposes of legality checks and removal of ignored Ghost code.
18835 Mark_Pragma_As_Ghost
(N
, Ent
);
18837 -- The pragma may come from an aspect on a private declaration,
18838 -- even if the freeze point at which this is analyzed in the
18839 -- private part after the full view.
18841 if Has_Private_Declaration
(Ent
)
18842 and then From_Aspect_Specification
(N
)
18846 -- Check appropriate type argument
18848 elsif Is_Private_Type
(Ent
)
18849 or else Is_Protected_Type
(Ent
)
18850 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
18852 -- AI05-0028: The pragma applies to all composite types. Note
18853 -- that we apply this binding interpretation to earlier versions
18854 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18855 -- choice since there are other compilers that do the same.
18857 or else Is_Composite_Type
(Ent
)
18863 ("pragma % can only be applied to private, formal derived, "
18864 & "protected, or composite type", Arg1
);
18867 -- Give an error if the pragma is applied to a protected type that
18868 -- does not qualify (due to having entries, or due to components
18869 -- that do not qualify).
18871 if Is_Protected_Type
(Ent
)
18872 and then not Has_Preelaborable_Initialization
(Ent
)
18875 ("protected type & does not have preelaborable "
18876 & "initialization", Ent
);
18878 -- Otherwise mark the type as definitely having preelaborable
18882 Set_Known_To_Have_Preelab_Init
(Ent
);
18885 if Has_Pragma_Preelab_Init
(Ent
)
18886 and then Warn_On_Redundant_Constructs
18888 Error_Pragma
("?r?duplicate pragma%!");
18890 Set_Has_Pragma_Preelab_Init
(Ent
);
18894 --------------------
18895 -- Persistent_BSS --
18896 --------------------
18898 -- pragma Persistent_BSS [(object_NAME)];
18900 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
18907 Check_At_Most_N_Arguments
(1);
18909 -- Case of application to specific object (one argument)
18911 if Arg_Count
= 1 then
18912 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
18914 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
18916 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
18919 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
18922 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18923 Decl
:= Parent
(Ent
);
18925 -- A pragma that applies to a Ghost entity becomes Ghost for
18926 -- the purposes of legality checks and removal of ignored Ghost
18929 Mark_Pragma_As_Ghost
(N
, Ent
);
18931 -- Check for duplication before inserting in list of
18932 -- representation items.
18934 Check_Duplicate_Pragma
(Ent
);
18936 if Rep_Item_Too_Late
(Ent
, N
) then
18940 if Present
(Expression
(Decl
)) then
18942 ("object for pragma% cannot have initialization", Arg1
);
18945 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
18947 ("object type for pragma% is not potentially persistent",
18952 Make_Linker_Section_Pragma
18953 (Ent
, Sloc
(N
), ".persistent.bss");
18954 Insert_After
(N
, Prag
);
18957 -- Case of use as configuration pragma with no arguments
18960 Check_Valid_Configuration_Pragma
;
18961 Persistent_BSS_Mode
:= True;
18963 end Persistent_BSS
;
18969 -- pragma Polling (ON | OFF);
18971 when Pragma_Polling
=>
18973 Check_Arg_Count
(1);
18974 Check_No_Identifiers
;
18975 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
18976 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
18978 -----------------------------------
18979 -- Post/Post_Class/Postcondition --
18980 -----------------------------------
18982 -- pragma Post (Boolean_EXPRESSION);
18983 -- pragma Post_Class (Boolean_EXPRESSION);
18984 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
18985 -- [,[Message =>] String_EXPRESSION]);
18987 -- Characteristics:
18989 -- * Analysis - The annotation undergoes initial checks to verify
18990 -- the legal placement and context. Secondary checks preanalyze the
18993 -- Analyze_Pre_Post_Condition_In_Decl_Part
18995 -- * Expansion - The annotation is expanded during the expansion of
18996 -- the related subprogram [body] contract as performed in:
18998 -- Expand_Subprogram_Contract
19000 -- * Template - The annotation utilizes the generic template of the
19001 -- related subprogram [body] when it is:
19003 -- aspect on subprogram declaration
19004 -- aspect on stand alone subprogram body
19005 -- pragma on stand alone subprogram body
19007 -- The annotation must prepare its own template when it is:
19009 -- pragma on subprogram declaration
19011 -- * Globals - Capture of global references must occur after full
19014 -- * Instance - The annotation is instantiated automatically when
19015 -- the related generic subprogram [body] is instantiated except for
19016 -- the "pragma on subprogram declaration" case. In that scenario
19017 -- the annotation must instantiate itself.
19020 Pragma_Post_Class |
19021 Pragma_Postcondition
=>
19022 Analyze_Pre_Post_Condition
;
19024 --------------------------------
19025 -- Pre/Pre_Class/Precondition --
19026 --------------------------------
19028 -- pragma Pre (Boolean_EXPRESSION);
19029 -- pragma Pre_Class (Boolean_EXPRESSION);
19030 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19031 -- [,[Message =>] String_EXPRESSION]);
19033 -- Characteristics:
19035 -- * Analysis - The annotation undergoes initial checks to verify
19036 -- the legal placement and context. Secondary checks preanalyze the
19039 -- Analyze_Pre_Post_Condition_In_Decl_Part
19041 -- * Expansion - The annotation is expanded during the expansion of
19042 -- the related subprogram [body] contract as performed in:
19044 -- Expand_Subprogram_Contract
19046 -- * Template - The annotation utilizes the generic template of the
19047 -- related subprogram [body] when it is:
19049 -- aspect on subprogram declaration
19050 -- aspect on stand alone subprogram body
19051 -- pragma on stand alone subprogram body
19053 -- The annotation must prepare its own template when it is:
19055 -- pragma on subprogram declaration
19057 -- * Globals - Capture of global references must occur after full
19060 -- * Instance - The annotation is instantiated automatically when
19061 -- the related generic subprogram [body] is instantiated except for
19062 -- the "pragma on subprogram declaration" case. In that scenario
19063 -- the annotation must instantiate itself.
19067 Pragma_Precondition
=>
19068 Analyze_Pre_Post_Condition
;
19074 -- pragma Predicate
19075 -- ([Entity =>] type_LOCAL_NAME,
19076 -- [Check =>] boolean_EXPRESSION);
19078 when Pragma_Predicate
=> Predicate
: declare
19085 Check_Arg_Count
(2);
19086 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19087 Check_Optional_Identifier
(Arg2
, Name_Check
);
19089 Check_Arg_Is_Local_Name
(Arg1
);
19091 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19092 Find_Type
(Type_Id
);
19093 Typ
:= Entity
(Type_Id
);
19095 if Typ
= Any_Type
then
19099 -- A pragma that applies to a Ghost entity becomes Ghost for the
19100 -- purposes of legality checks and removal of ignored Ghost code.
19102 Mark_Pragma_As_Ghost
(N
, Typ
);
19104 -- The remaining processing is simply to link the pragma on to
19105 -- the rep item chain, for processing when the type is frozen.
19106 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19107 -- mark the type as having predicates.
19109 -- If the current policy for predicate checking is Ignore mark the
19110 -- subtype accordingly. In the case of predicates we consider them
19111 -- enabled unless Ignore is specified (either directly or with a
19112 -- general Assertion_Policy pragma) to preserve existing warnings.
19114 Set_Has_Predicates
(Typ
);
19115 Set_Predicates_Ignored
(Typ
,
19116 Present
(Check_Policy_List
)
19118 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
19119 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19122 -----------------------
19123 -- Predicate_Failure --
19124 -----------------------
19126 -- pragma Predicate_Failure
19127 -- ([Entity =>] type_LOCAL_NAME,
19128 -- [Message =>] string_EXPRESSION);
19130 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
19137 Check_Arg_Count
(2);
19138 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19139 Check_Optional_Identifier
(Arg2
, Name_Message
);
19141 Check_Arg_Is_Local_Name
(Arg1
);
19143 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19144 Find_Type
(Type_Id
);
19145 Typ
:= Entity
(Type_Id
);
19147 if Typ
= Any_Type
then
19151 -- A pragma that applies to a Ghost entity becomes Ghost for the
19152 -- purposes of legality checks and removal of ignored Ghost code.
19154 Mark_Pragma_As_Ghost
(N
, Typ
);
19156 -- The remaining processing is simply to link the pragma on to
19157 -- the rep item chain, for processing when the type is frozen.
19158 -- This is accomplished by a call to Rep_Item_Too_Late.
19160 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19161 end Predicate_Failure
;
19167 -- pragma Preelaborate [(library_unit_NAME)];
19169 -- Set the flag Is_Preelaborated of program unit name entity
19171 when Pragma_Preelaborate
=> Preelaborate
: declare
19172 Pa
: constant Node_Id
:= Parent
(N
);
19173 Pk
: constant Node_Kind
:= Nkind
(Pa
);
19177 Check_Ada_83_Warning
;
19178 Check_Valid_Library_Unit_Pragma
;
19180 if Nkind
(N
) = N_Null_Statement
then
19184 Ent
:= Find_Lib_Unit_Name
;
19186 -- A pragma that applies to a Ghost entity becomes Ghost for the
19187 -- purposes of legality checks and removal of ignored Ghost code.
19189 Mark_Pragma_As_Ghost
(N
, Ent
);
19190 Check_Duplicate_Pragma
(Ent
);
19192 -- This filters out pragmas inside generic parents that show up
19193 -- inside instantiations. Pragmas that come from aspects in the
19194 -- unit are not ignored.
19196 if Present
(Ent
) then
19197 if Pk
= N_Package_Specification
19198 and then Present
(Generic_Parent
(Pa
))
19199 and then not From_Aspect_Specification
(N
)
19204 if not Debug_Flag_U
then
19205 Set_Is_Preelaborated
(Ent
);
19206 Set_Suppress_Elaboration_Warnings
(Ent
);
19212 -------------------------------
19213 -- Prefix_Exception_Messages --
19214 -------------------------------
19216 -- pragma Prefix_Exception_Messages;
19218 when Pragma_Prefix_Exception_Messages
=>
19220 Check_Valid_Configuration_Pragma
;
19221 Check_Arg_Count
(0);
19222 Prefix_Exception_Messages
:= True;
19228 -- pragma Priority (EXPRESSION);
19230 when Pragma_Priority
=> Priority
: declare
19231 P
: constant Node_Id
:= Parent
(N
);
19236 Check_No_Identifiers
;
19237 Check_Arg_Count
(1);
19241 if Nkind
(P
) = N_Subprogram_Body
then
19242 Check_In_Main_Program
;
19244 Ent
:= Defining_Unit_Name
(Specification
(P
));
19246 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
19247 Ent
:= Defining_Identifier
(Ent
);
19250 Arg
:= Get_Pragma_Arg
(Arg1
);
19251 Analyze_And_Resolve
(Arg
, Standard_Integer
);
19255 if not Is_OK_Static_Expression
(Arg
) then
19256 Flag_Non_Static_Expr
19257 ("main subprogram priority is not static!", Arg
);
19260 -- If constraint error, then we already signalled an error
19262 elsif Raises_Constraint_Error
(Arg
) then
19265 -- Otherwise check in range except if Relaxed_RM_Semantics
19266 -- where we ignore the value if out of range.
19269 if not Relaxed_RM_Semantics
19270 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
19273 ("main subprogram priority is out of range", Arg1
);
19276 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
19280 -- Load an arbitrary entity from System.Tasking.Stages or
19281 -- System.Tasking.Restricted.Stages (depending on the
19282 -- supported profile) to make sure that one of these packages
19283 -- is implicitly with'ed, since we need to have the tasking
19284 -- run time active for the pragma Priority to have any effect.
19285 -- Previously we with'ed the package System.Tasking, but this
19286 -- package does not trigger the required initialization of the
19287 -- run-time library.
19290 Discard
: Entity_Id
;
19291 pragma Warnings
(Off
, Discard
);
19293 if Restricted_Profile
then
19294 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
19296 Discard
:= RTE
(RE_Activate_Tasks
);
19300 -- Task or Protected, must be of type Integer
19302 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
19303 Arg
:= Get_Pragma_Arg
(Arg1
);
19304 Ent
:= Defining_Identifier
(Parent
(P
));
19306 -- The expression must be analyzed in the special manner
19307 -- described in "Handling of Default and Per-Object
19308 -- Expressions" in sem.ads.
19310 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
19312 if not Is_OK_Static_Expression
(Arg
) then
19313 Check_Restriction
(Static_Priorities
, Arg
);
19316 -- Anything else is incorrect
19322 -- Check duplicate pragma before we chain the pragma in the Rep
19323 -- Item chain of Ent.
19325 Check_Duplicate_Pragma
(Ent
);
19326 Record_Rep_Item
(Ent
, N
);
19329 -----------------------------------
19330 -- Priority_Specific_Dispatching --
19331 -----------------------------------
19333 -- pragma Priority_Specific_Dispatching (
19334 -- policy_IDENTIFIER,
19335 -- first_priority_EXPRESSION,
19336 -- last_priority_EXPRESSION);
19338 when Pragma_Priority_Specific_Dispatching
=>
19339 Priority_Specific_Dispatching
: declare
19340 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
19341 -- This is the entity System.Any_Priority;
19344 Lower_Bound
: Node_Id
;
19345 Upper_Bound
: Node_Id
;
19351 Check_Arg_Count
(3);
19352 Check_No_Identifiers
;
19353 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19354 Check_Valid_Configuration_Pragma
;
19355 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19356 DP
:= Fold_Upper
(Name_Buffer
(1));
19358 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
19359 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
19360 Lower_Val
:= Expr_Value
(Lower_Bound
);
19362 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
19363 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
19364 Upper_Val
:= Expr_Value
(Upper_Bound
);
19366 -- It is not allowed to use Task_Dispatching_Policy and
19367 -- Priority_Specific_Dispatching in the same partition.
19369 if Task_Dispatching_Policy
/= ' ' then
19370 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19372 ("pragma% incompatible with Task_Dispatching_Policy#");
19374 -- Check lower bound in range
19376 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19378 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19381 ("first_priority is out of range", Arg2
);
19383 -- Check upper bound in range
19385 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19387 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19390 ("last_priority is out of range", Arg3
);
19392 -- Check that the priority range is valid
19394 elsif Lower_Val
> Upper_Val
then
19396 ("last_priority_expression must be greater than or equal to "
19397 & "first_priority_expression");
19399 -- Store the new policy, but always preserve System_Location since
19400 -- we like the error message with the run-time name.
19403 -- Check overlapping in the priority ranges specified in other
19404 -- Priority_Specific_Dispatching pragmas within the same
19405 -- partition. We can only check those we know about.
19408 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
19410 if Specific_Dispatching
.Table
(J
).First_Priority
in
19411 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19412 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
19413 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19416 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
19418 ("priority range overlaps with "
19419 & "Priority_Specific_Dispatching#");
19423 -- The use of Priority_Specific_Dispatching is incompatible
19424 -- with Task_Dispatching_Policy.
19426 if Task_Dispatching_Policy
/= ' ' then
19427 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19429 ("Priority_Specific_Dispatching incompatible "
19430 & "with Task_Dispatching_Policy#");
19433 -- The use of Priority_Specific_Dispatching forces ceiling
19436 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
19437 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19439 ("Priority_Specific_Dispatching incompatible "
19440 & "with Locking_Policy#");
19442 -- Set the Ceiling_Locking policy, but preserve System_Location
19443 -- since we like the error message with the run time name.
19446 Locking_Policy
:= 'C';
19448 if Locking_Policy_Sloc
/= System_Location
then
19449 Locking_Policy_Sloc
:= Loc
;
19453 -- Add entry in the table
19455 Specific_Dispatching
.Append
19456 ((Dispatching_Policy
=> DP
,
19457 First_Priority
=> UI_To_Int
(Lower_Val
),
19458 Last_Priority
=> UI_To_Int
(Upper_Val
),
19459 Pragma_Loc
=> Loc
));
19461 end Priority_Specific_Dispatching
;
19467 -- pragma Profile (profile_IDENTIFIER);
19469 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19471 when Pragma_Profile
=>
19473 Check_Arg_Count
(1);
19474 Check_Valid_Configuration_Pragma
;
19475 Check_No_Identifiers
;
19478 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19481 if Chars
(Argx
) = Name_Ravenscar
then
19482 Set_Ravenscar_Profile
(Ravenscar
, N
);
19484 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
19485 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
19487 elsif Chars
(Argx
) = Name_Restricted
then
19488 Set_Profile_Restrictions
19490 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19492 elsif Chars
(Argx
) = Name_Rational
then
19493 Set_Rational_Profile
;
19495 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19496 Set_Profile_Restrictions
19497 (No_Implementation_Extensions
,
19498 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19501 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19505 ----------------------
19506 -- Profile_Warnings --
19507 ----------------------
19509 -- pragma Profile_Warnings (profile_IDENTIFIER);
19511 -- profile_IDENTIFIER => Restricted | Ravenscar
19513 when Pragma_Profile_Warnings
=>
19515 Check_Arg_Count
(1);
19516 Check_Valid_Configuration_Pragma
;
19517 Check_No_Identifiers
;
19520 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19523 if Chars
(Argx
) = Name_Ravenscar
then
19524 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
19526 elsif Chars
(Argx
) = Name_Restricted
then
19527 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
19529 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19530 Set_Profile_Restrictions
19531 (No_Implementation_Extensions
, N
, Warn
=> True);
19534 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19538 --------------------------
19539 -- Propagate_Exceptions --
19540 --------------------------
19542 -- pragma Propagate_Exceptions;
19544 -- Note: this pragma is obsolete and has no effect
19546 when Pragma_Propagate_Exceptions
=>
19548 Check_Arg_Count
(0);
19550 if Warn_On_Obsolescent_Feature
then
19552 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19553 "and has no effect?j?", N
);
19556 -----------------------------
19557 -- Provide_Shift_Operators --
19558 -----------------------------
19560 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19562 when Pragma_Provide_Shift_Operators
=>
19563 Provide_Shift_Operators
: declare
19566 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
19567 -- Insert declaration and pragma Instrinsic for named shift op
19569 ----------------------------
19570 -- Declare_Shift_Operator --
19571 ----------------------------
19573 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
19579 Make_Subprogram_Declaration
(Loc
,
19580 Make_Function_Specification
(Loc
,
19581 Defining_Unit_Name
=>
19582 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
19584 Result_Definition
=>
19585 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
19587 Parameter_Specifications
=> New_List
(
19588 Make_Parameter_Specification
(Loc
,
19589 Defining_Identifier
=>
19590 Make_Defining_Identifier
(Loc
, Name_Value
),
19592 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
19594 Make_Parameter_Specification
(Loc
,
19595 Defining_Identifier
=>
19596 Make_Defining_Identifier
(Loc
, Name_Amount
),
19598 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
19602 Pragma_Identifier
=> Make_Identifier
(Loc
, Name_Import
),
19603 Pragma_Argument_Associations
=> New_List
(
19604 Make_Pragma_Argument_Association
(Loc
,
19605 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
19606 Make_Pragma_Argument_Association
(Loc
,
19607 Expression
=> Make_Identifier
(Loc
, Nam
))));
19609 Insert_After
(N
, Import
);
19610 Insert_After
(N
, Func
);
19611 end Declare_Shift_Operator
;
19613 -- Start of processing for Provide_Shift_Operators
19617 Check_Arg_Count
(1);
19618 Check_Arg_Is_Local_Name
(Arg1
);
19620 Arg1
:= Get_Pragma_Arg
(Arg1
);
19622 -- We must have an entity name
19624 if not Is_Entity_Name
(Arg1
) then
19626 ("pragma % must apply to integer first subtype", Arg1
);
19629 -- If no Entity, means there was a prior error so ignore
19631 if Present
(Entity
(Arg1
)) then
19632 Ent
:= Entity
(Arg1
);
19634 -- Apply error checks
19636 if not Is_First_Subtype
(Ent
) then
19638 ("cannot apply pragma %",
19639 "\& is not a first subtype",
19642 elsif not Is_Integer_Type
(Ent
) then
19644 ("cannot apply pragma %",
19645 "\& is not an integer type",
19648 elsif Has_Shift_Operator
(Ent
) then
19650 ("cannot apply pragma %",
19651 "\& already has declared shift operators",
19654 elsif Is_Frozen
(Ent
) then
19656 ("pragma % appears too late",
19657 "\& is already frozen",
19661 -- Now declare the operators. We do this during analysis rather
19662 -- than expansion, since we want the operators available if we
19663 -- are operating in -gnatc or ASIS mode.
19665 Declare_Shift_Operator
(Name_Rotate_Left
);
19666 Declare_Shift_Operator
(Name_Rotate_Right
);
19667 Declare_Shift_Operator
(Name_Shift_Left
);
19668 Declare_Shift_Operator
(Name_Shift_Right
);
19669 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
19671 end Provide_Shift_Operators
;
19677 -- pragma Psect_Object (
19678 -- [Internal =>] LOCAL_NAME,
19679 -- [, [External =>] EXTERNAL_SYMBOL]
19680 -- [, [Size =>] EXTERNAL_SYMBOL]);
19682 when Pragma_Psect_Object | Pragma_Common_Object
=>
19683 Psect_Object
: declare
19684 Args
: Args_List
(1 .. 3);
19685 Names
: constant Name_List
(1 .. 3) := (
19690 Internal
: Node_Id
renames Args
(1);
19691 External
: Node_Id
renames Args
(2);
19692 Size
: Node_Id
renames Args
(3);
19694 Def_Id
: Entity_Id
;
19696 procedure Check_Arg
(Arg
: Node_Id
);
19697 -- Checks that argument is either a string literal or an
19698 -- identifier, and posts error message if not.
19704 procedure Check_Arg
(Arg
: Node_Id
) is
19706 if not Nkind_In
(Original_Node
(Arg
),
19711 ("inappropriate argument for pragma %", Arg
);
19715 -- Start of processing for Common_Object/Psect_Object
19719 Gather_Associations
(Names
, Args
);
19720 Process_Extended_Import_Export_Internal_Arg
(Internal
);
19722 Def_Id
:= Entity
(Internal
);
19724 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
19726 ("pragma% must designate an object", Internal
);
19729 Check_Arg
(Internal
);
19731 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
19733 ("cannot use pragma% for imported/exported object",
19737 if Is_Concurrent_Type
(Etype
(Internal
)) then
19739 ("cannot specify pragma % for task/protected object",
19743 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
19745 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
19747 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
19750 if Ekind
(Def_Id
) = E_Constant
then
19752 ("cannot specify pragma % for a constant", Internal
);
19755 if Is_Record_Type
(Etype
(Internal
)) then
19761 Ent
:= First_Entity
(Etype
(Internal
));
19762 while Present
(Ent
) loop
19763 Decl
:= Declaration_Node
(Ent
);
19765 if Ekind
(Ent
) = E_Component
19766 and then Nkind
(Decl
) = N_Component_Declaration
19767 and then Present
(Expression
(Decl
))
19768 and then Warn_On_Export_Import
19771 ("?x?object for pragma % has defaults", Internal
);
19781 if Present
(Size
) then
19785 if Present
(External
) then
19786 Check_Arg_Is_External_Name
(External
);
19789 -- If all error tests pass, link pragma on to the rep item chain
19791 Record_Rep_Item
(Def_Id
, N
);
19798 -- pragma Pure [(library_unit_NAME)];
19800 when Pragma_Pure
=> Pure
: declare
19804 Check_Ada_83_Warning
;
19806 -- If the pragma comes from a subprogram instantiation, nothing to
19807 -- check, this can happen at any level of nesting.
19809 if Is_Wrapper_Package
(Current_Scope
) then
19812 Check_Valid_Library_Unit_Pragma
;
19815 if Nkind
(N
) = N_Null_Statement
then
19819 Ent
:= Find_Lib_Unit_Name
;
19821 -- A pragma that applies to a Ghost entity becomes Ghost for the
19822 -- purposes of legality checks and removal of ignored Ghost code.
19824 Mark_Pragma_As_Ghost
(N
, Ent
);
19826 if not Debug_Flag_U
then
19828 Set_Has_Pragma_Pure
(Ent
);
19829 Set_Suppress_Elaboration_Warnings
(Ent
);
19833 -------------------
19834 -- Pure_Function --
19835 -------------------
19837 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19839 when Pragma_Pure_Function
=> Pure_Function
: declare
19840 Def_Id
: Entity_Id
;
19843 Effective
: Boolean := False;
19847 Check_Arg_Count
(1);
19848 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19849 Check_Arg_Is_Local_Name
(Arg1
);
19850 E_Id
:= Get_Pragma_Arg
(Arg1
);
19852 if Error_Posted
(E_Id
) then
19856 -- Loop through homonyms (overloadings) of referenced entity
19858 E
:= Entity
(E_Id
);
19860 -- A pragma that applies to a Ghost entity becomes Ghost for the
19861 -- purposes of legality checks and removal of ignored Ghost code.
19863 Mark_Pragma_As_Ghost
(N
, E
);
19865 if Present
(E
) then
19867 Def_Id
:= Get_Base_Subprogram
(E
);
19869 if not Ekind_In
(Def_Id
, E_Function
,
19870 E_Generic_Function
,
19874 ("pragma% requires a function name", Arg1
);
19877 Set_Is_Pure
(Def_Id
);
19879 if not Has_Pragma_Pure_Function
(Def_Id
) then
19880 Set_Has_Pragma_Pure_Function
(Def_Id
);
19884 exit when From_Aspect_Specification
(N
);
19886 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
19890 and then Warn_On_Redundant_Constructs
19893 ("pragma Pure_Function on& is redundant?r?",
19899 --------------------
19900 -- Queuing_Policy --
19901 --------------------
19903 -- pragma Queuing_Policy (policy_IDENTIFIER);
19905 when Pragma_Queuing_Policy
=> declare
19909 Check_Ada_83_Warning
;
19910 Check_Arg_Count
(1);
19911 Check_No_Identifiers
;
19912 Check_Arg_Is_Queuing_Policy
(Arg1
);
19913 Check_Valid_Configuration_Pragma
;
19914 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19915 QP
:= Fold_Upper
(Name_Buffer
(1));
19917 if Queuing_Policy
/= ' '
19918 and then Queuing_Policy
/= QP
19920 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
19921 Error_Pragma
("queuing policy incompatible with policy#");
19923 -- Set new policy, but always preserve System_Location since we
19924 -- like the error message with the run time name.
19927 Queuing_Policy
:= QP
;
19929 if Queuing_Policy_Sloc
/= System_Location
then
19930 Queuing_Policy_Sloc
:= Loc
;
19939 -- pragma Rational, for compatibility with foreign compiler
19941 when Pragma_Rational
=>
19942 Set_Rational_Profile
;
19944 ---------------------
19945 -- Refined_Depends --
19946 ---------------------
19948 -- pragma Refined_Depends (DEPENDENCY_RELATION);
19950 -- DEPENDENCY_RELATION ::=
19952 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
19954 -- DEPENDENCY_CLAUSE ::=
19955 -- OUTPUT_LIST =>[+] INPUT_LIST
19956 -- | NULL_DEPENDENCY_CLAUSE
19958 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
19960 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
19962 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
19964 -- OUTPUT ::= NAME | FUNCTION_RESULT
19967 -- where FUNCTION_RESULT is a function Result attribute_reference
19969 -- Characteristics:
19971 -- * Analysis - The annotation undergoes initial checks to verify
19972 -- the legal placement and context. Secondary checks fully analyze
19973 -- the dependency clauses/global list in:
19975 -- Analyze_Refined_Depends_In_Decl_Part
19977 -- * Expansion - None.
19979 -- * Template - The annotation utilizes the generic template of the
19980 -- related subprogram body.
19982 -- * Globals - Capture of global references must occur after full
19985 -- * Instance - The annotation is instantiated automatically when
19986 -- the related generic subprogram body is instantiated.
19988 when Pragma_Refined_Depends
=> Refined_Depends
: declare
19989 Body_Id
: Entity_Id
;
19991 Spec_Id
: Entity_Id
;
19994 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
19998 -- Chain the pragma on the contract for further processing by
19999 -- Analyze_Refined_Depends_In_Decl_Part.
20001 Add_Contract_Item
(N
, Body_Id
);
20003 -- The legality checks of pragmas Refined_Depends and
20004 -- Refined_Global are affected by the SPARK mode in effect and
20005 -- the volatility of the context. In addition these two pragmas
20006 -- are subject to an inherent order:
20008 -- 1) Refined_Global
20009 -- 2) Refined_Depends
20011 -- Analyze all these pragmas in the order outlined above
20013 Analyze_If_Present
(Pragma_SPARK_Mode
);
20014 Analyze_If_Present
(Pragma_Volatile_Function
);
20015 Analyze_If_Present
(Pragma_Refined_Global
);
20016 Analyze_Refined_Depends_In_Decl_Part
(N
);
20018 end Refined_Depends
;
20020 --------------------
20021 -- Refined_Global --
20022 --------------------
20024 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20026 -- GLOBAL_SPECIFICATION ::=
20029 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20031 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20033 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20034 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20035 -- GLOBAL_ITEM ::= NAME
20037 -- Characteristics:
20039 -- * Analysis - The annotation undergoes initial checks to verify
20040 -- the legal placement and context. Secondary checks fully analyze
20041 -- the dependency clauses/global list in:
20043 -- Analyze_Refined_Global_In_Decl_Part
20045 -- * Expansion - None.
20047 -- * Template - The annotation utilizes the generic template of the
20048 -- related subprogram body.
20050 -- * Globals - Capture of global references must occur after full
20053 -- * Instance - The annotation is instantiated automatically when
20054 -- the related generic subprogram body is instantiated.
20056 when Pragma_Refined_Global
=> Refined_Global
: declare
20057 Body_Id
: Entity_Id
;
20059 Spec_Id
: Entity_Id
;
20062 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20066 -- Chain the pragma on the contract for further processing by
20067 -- Analyze_Refined_Global_In_Decl_Part.
20069 Add_Contract_Item
(N
, Body_Id
);
20071 -- The legality checks of pragmas Refined_Depends and
20072 -- Refined_Global are affected by the SPARK mode in effect and
20073 -- the volatility of the context. In addition these two pragmas
20074 -- are subject to an inherent order:
20076 -- 1) Refined_Global
20077 -- 2) Refined_Depends
20079 -- Analyze all these pragmas in the order outlined above
20081 Analyze_If_Present
(Pragma_SPARK_Mode
);
20082 Analyze_If_Present
(Pragma_Volatile_Function
);
20083 Analyze_Refined_Global_In_Decl_Part
(N
);
20084 Analyze_If_Present
(Pragma_Refined_Depends
);
20086 end Refined_Global
;
20092 -- pragma Refined_Post (boolean_EXPRESSION);
20094 -- Characteristics:
20096 -- * Analysis - The annotation is fully analyzed immediately upon
20097 -- elaboration as it cannot forward reference entities.
20099 -- * Expansion - The annotation is expanded during the expansion of
20100 -- the related subprogram body contract as performed in:
20102 -- Expand_Subprogram_Contract
20104 -- * Template - The annotation utilizes the generic template of the
20105 -- related subprogram body.
20107 -- * Globals - Capture of global references must occur after full
20110 -- * Instance - The annotation is instantiated automatically when
20111 -- the related generic subprogram body is instantiated.
20113 when Pragma_Refined_Post
=> Refined_Post
: declare
20114 Body_Id
: Entity_Id
;
20116 Spec_Id
: Entity_Id
;
20119 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20121 -- Fully analyze the pragma when it appears inside a subprogram
20122 -- body because it cannot benefit from forward references.
20126 -- Chain the pragma on the contract for completeness
20128 Add_Contract_Item
(N
, Body_Id
);
20130 -- The legality checks of pragma Refined_Post are affected by
20131 -- the SPARK mode in effect and the volatility of the context.
20132 -- Analyze all pragmas in a specific order.
20134 Analyze_If_Present
(Pragma_SPARK_Mode
);
20135 Analyze_If_Present
(Pragma_Volatile_Function
);
20136 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
20138 -- Currently it is not possible to inline pre/postconditions on
20139 -- a subprogram subject to pragma Inline_Always.
20141 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
20145 -------------------
20146 -- Refined_State --
20147 -------------------
20149 -- pragma Refined_State (REFINEMENT_LIST);
20151 -- REFINEMENT_LIST ::=
20152 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20154 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20156 -- CONSTITUENT_LIST ::=
20159 -- | (CONSTITUENT {, CONSTITUENT})
20161 -- CONSTITUENT ::= object_NAME | state_NAME
20163 -- Characteristics:
20165 -- * Analysis - The annotation undergoes initial checks to verify
20166 -- the legal placement and context. Secondary checks preanalyze the
20167 -- refinement clauses in:
20169 -- Analyze_Refined_State_In_Decl_Part
20171 -- * Expansion - None.
20173 -- * Template - The annotation utilizes the template of the related
20176 -- * Globals - Capture of global references must occur after full
20179 -- * Instance - The annotation is instantiated automatically when
20180 -- the related generic package body is instantiated.
20182 when Pragma_Refined_State
=> Refined_State
: declare
20183 Pack_Decl
: Node_Id
;
20184 Spec_Id
: Entity_Id
;
20188 Check_No_Identifiers
;
20189 Check_Arg_Count
(1);
20191 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
20193 -- Ensure the proper placement of the pragma. Refined states must
20194 -- be associated with a package body.
20196 if Nkind
(Pack_Decl
) = N_Package_Body
then
20199 -- Otherwise the pragma is associated with an illegal construct
20206 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
20208 -- Chain the pragma on the contract for further processing by
20209 -- Analyze_Refined_State_In_Decl_Part.
20211 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
20213 -- The legality checks of pragma Refined_State are affected by the
20214 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20216 Analyze_If_Present
(Pragma_SPARK_Mode
);
20218 -- A pragma that applies to a Ghost entity becomes Ghost for the
20219 -- purposes of legality checks and removal of ignored Ghost code.
20221 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
20223 -- State refinement is allowed only when the corresponding package
20224 -- declaration has non-null pragma Abstract_State. Refinement not
20225 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20227 if SPARK_Mode
/= Off
20229 (No
(Abstract_States
(Spec_Id
))
20230 or else Has_Null_Abstract_State
(Spec_Id
))
20233 ("useless refinement, package & does not define abstract "
20234 & "states", N
, Spec_Id
);
20239 -----------------------
20240 -- Relative_Deadline --
20241 -----------------------
20243 -- pragma Relative_Deadline (time_span_EXPRESSION);
20245 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
20246 P
: constant Node_Id
:= Parent
(N
);
20251 Check_No_Identifiers
;
20252 Check_Arg_Count
(1);
20254 Arg
:= Get_Pragma_Arg
(Arg1
);
20256 -- The expression must be analyzed in the special manner described
20257 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20259 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
20263 if Nkind
(P
) = N_Subprogram_Body
then
20264 Check_In_Main_Program
;
20266 -- Only Task and subprogram cases allowed
20268 elsif Nkind
(P
) /= N_Task_Definition
then
20272 -- Check duplicate pragma before we set the corresponding flag
20274 if Has_Relative_Deadline_Pragma
(P
) then
20275 Error_Pragma
("duplicate pragma% not allowed");
20278 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20279 -- Relative_Deadline pragma node cannot be inserted in the Rep
20280 -- Item chain of Ent since it is rewritten by the expander as a
20281 -- procedure call statement that will break the chain.
20283 Set_Has_Relative_Deadline_Pragma
(P
);
20284 end Relative_Deadline
;
20286 ------------------------
20287 -- Remote_Access_Type --
20288 ------------------------
20290 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20292 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
20297 Check_Arg_Count
(1);
20298 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20299 Check_Arg_Is_Local_Name
(Arg1
);
20301 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
20303 -- A pragma that applies to a Ghost entity becomes Ghost for the
20304 -- purposes of legality checks and removal of ignored Ghost code.
20306 Mark_Pragma_As_Ghost
(N
, E
);
20308 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
20309 and then Ekind
(E
) = E_General_Access_Type
20310 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
20311 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
20313 and then Is_Valid_Remote_Object_Type
20314 (Root_Type
(Directly_Designated_Type
(E
)))
20316 Set_Is_Remote_Types
(E
);
20320 ("pragma% applies only to formal access-to-class-wide types",
20323 end Remote_Access_Type
;
20325 ---------------------------
20326 -- Remote_Call_Interface --
20327 ---------------------------
20329 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20331 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
20332 Cunit_Node
: Node_Id
;
20333 Cunit_Ent
: Entity_Id
;
20337 Check_Ada_83_Warning
;
20338 Check_Valid_Library_Unit_Pragma
;
20340 if Nkind
(N
) = N_Null_Statement
then
20344 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20345 K
:= Nkind
(Unit
(Cunit_Node
));
20346 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20348 -- A pragma that applies to a Ghost entity becomes Ghost for the
20349 -- purposes of legality checks and removal of ignored Ghost code.
20351 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
20353 if K
= N_Package_Declaration
20354 or else K
= N_Generic_Package_Declaration
20355 or else K
= N_Subprogram_Declaration
20356 or else K
= N_Generic_Subprogram_Declaration
20357 or else (K
= N_Subprogram_Body
20358 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
20363 "pragma% must apply to package or subprogram declaration");
20366 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
20367 end Remote_Call_Interface
;
20373 -- pragma Remote_Types [(library_unit_NAME)];
20375 when Pragma_Remote_Types
=> Remote_Types
: declare
20376 Cunit_Node
: Node_Id
;
20377 Cunit_Ent
: Entity_Id
;
20380 Check_Ada_83_Warning
;
20381 Check_Valid_Library_Unit_Pragma
;
20383 if Nkind
(N
) = N_Null_Statement
then
20387 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20388 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20390 -- A pragma that applies to a Ghost entity becomes Ghost for the
20391 -- purposes of legality checks and removal of ignored Ghost code.
20393 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
20395 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20396 N_Generic_Package_Declaration
)
20399 ("pragma% can only apply to a package declaration");
20402 Set_Is_Remote_Types
(Cunit_Ent
);
20409 -- pragma Ravenscar;
20411 when Pragma_Ravenscar
=>
20413 Check_Arg_Count
(0);
20414 Check_Valid_Configuration_Pragma
;
20415 Set_Ravenscar_Profile
(Ravenscar
, N
);
20417 if Warn_On_Obsolescent_Feature
then
20419 ("pragma Ravenscar is an obsolescent feature?j?", N
);
20421 ("|use pragma Profile (Ravenscar) instead?j?", N
);
20424 -------------------------
20425 -- Restricted_Run_Time --
20426 -------------------------
20428 -- pragma Restricted_Run_Time;
20430 when Pragma_Restricted_Run_Time
=>
20432 Check_Arg_Count
(0);
20433 Check_Valid_Configuration_Pragma
;
20434 Set_Profile_Restrictions
20435 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
20437 if Warn_On_Obsolescent_Feature
then
20439 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20442 ("|use pragma Profile (Restricted) instead?j?", N
);
20449 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20452 -- restriction_IDENTIFIER
20453 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20455 when Pragma_Restrictions
=>
20456 Process_Restrictions_Or_Restriction_Warnings
20457 (Warn
=> Treat_Restrictions_As_Warnings
);
20459 --------------------------
20460 -- Restriction_Warnings --
20461 --------------------------
20463 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20466 -- restriction_IDENTIFIER
20467 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20469 when Pragma_Restriction_Warnings
=>
20471 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
20477 -- pragma Reviewable;
20479 when Pragma_Reviewable
=>
20480 Check_Ada_83_Warning
;
20481 Check_Arg_Count
(0);
20483 -- Call dummy debugging function rv. This is done to assist front
20484 -- end debugging. By placing a Reviewable pragma in the source
20485 -- program, a breakpoint on rv catches this place in the source,
20486 -- allowing convenient stepping to the point of interest.
20490 --------------------------
20491 -- Short_Circuit_And_Or --
20492 --------------------------
20494 -- pragma Short_Circuit_And_Or;
20496 when Pragma_Short_Circuit_And_Or
=>
20498 Check_Arg_Count
(0);
20499 Check_Valid_Configuration_Pragma
;
20500 Short_Circuit_And_Or
:= True;
20502 -------------------
20503 -- Share_Generic --
20504 -------------------
20506 -- pragma Share_Generic (GNAME {, GNAME});
20508 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20510 when Pragma_Share_Generic
=>
20512 Process_Generic_List
;
20518 -- pragma Shared (LOCAL_NAME);
20520 when Pragma_Shared
=>
20522 Process_Atomic_Independent_Shared_Volatile
;
20524 --------------------
20525 -- Shared_Passive --
20526 --------------------
20528 -- pragma Shared_Passive [(library_unit_NAME)];
20530 -- Set the flag Is_Shared_Passive of program unit name entity
20532 when Pragma_Shared_Passive
=> Shared_Passive
: declare
20533 Cunit_Node
: Node_Id
;
20534 Cunit_Ent
: Entity_Id
;
20537 Check_Ada_83_Warning
;
20538 Check_Valid_Library_Unit_Pragma
;
20540 if Nkind
(N
) = N_Null_Statement
then
20544 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20545 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20547 -- A pragma that applies to a Ghost entity becomes Ghost for the
20548 -- purposes of legality checks and removal of ignored Ghost code.
20550 Mark_Pragma_As_Ghost
(N
, Cunit_Ent
);
20552 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20553 N_Generic_Package_Declaration
)
20556 ("pragma% can only apply to a package declaration");
20559 Set_Is_Shared_Passive
(Cunit_Ent
);
20560 end Shared_Passive
;
20562 -----------------------
20563 -- Short_Descriptors --
20564 -----------------------
20566 -- pragma Short_Descriptors;
20568 -- Recognize and validate, but otherwise ignore
20570 when Pragma_Short_Descriptors
=>
20572 Check_Arg_Count
(0);
20573 Check_Valid_Configuration_Pragma
;
20575 ------------------------------
20576 -- Simple_Storage_Pool_Type --
20577 ------------------------------
20579 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20581 when Pragma_Simple_Storage_Pool_Type
=>
20582 Simple_Storage_Pool_Type
: declare
20588 Check_Arg_Count
(1);
20589 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20591 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20592 Find_Type
(Type_Id
);
20593 Typ
:= Entity
(Type_Id
);
20595 if Typ
= Any_Type
then
20599 -- A pragma that applies to a Ghost entity becomes Ghost for the
20600 -- purposes of legality checks and removal of ignored Ghost code.
20602 Mark_Pragma_As_Ghost
(N
, Typ
);
20604 -- We require the pragma to apply to a type declared in a package
20605 -- declaration, but not (immediately) within a package body.
20607 if Ekind
(Current_Scope
) /= E_Package
20608 or else In_Package_Body
(Current_Scope
)
20611 ("pragma% can only apply to type declared immediately "
20612 & "within a package declaration");
20615 -- A simple storage pool type must be an immutably limited record
20616 -- or private type. If the pragma is given for a private type,
20617 -- the full type is similarly restricted (which is checked later
20618 -- in Freeze_Entity).
20620 if Is_Record_Type
(Typ
)
20621 and then not Is_Limited_View
(Typ
)
20624 ("pragma% can only apply to explicitly limited record type");
20626 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
20628 ("pragma% can only apply to a private type that is limited");
20630 elsif not Is_Record_Type
(Typ
)
20631 and then not Is_Private_Type
(Typ
)
20634 ("pragma% can only apply to limited record or private type");
20637 Record_Rep_Item
(Typ
, N
);
20638 end Simple_Storage_Pool_Type
;
20640 ----------------------
20641 -- Source_File_Name --
20642 ----------------------
20644 -- There are five forms for this pragma:
20646 -- pragma Source_File_Name (
20647 -- [UNIT_NAME =>] unit_NAME,
20648 -- BODY_FILE_NAME => STRING_LITERAL
20649 -- [, [INDEX =>] INTEGER_LITERAL]);
20651 -- pragma Source_File_Name (
20652 -- [UNIT_NAME =>] unit_NAME,
20653 -- SPEC_FILE_NAME => STRING_LITERAL
20654 -- [, [INDEX =>] INTEGER_LITERAL]);
20656 -- pragma Source_File_Name (
20657 -- BODY_FILE_NAME => STRING_LITERAL
20658 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20659 -- [, CASING => CASING_SPEC]);
20661 -- pragma Source_File_Name (
20662 -- SPEC_FILE_NAME => STRING_LITERAL
20663 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20664 -- [, CASING => CASING_SPEC]);
20666 -- pragma Source_File_Name (
20667 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20668 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20669 -- [, CASING => CASING_SPEC]);
20671 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20673 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20674 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20675 -- only be used when no project file is used, while SFNP can only be
20676 -- used when a project file is used.
20678 -- No processing here. Processing was completed during parsing, since
20679 -- we need to have file names set as early as possible. Units are
20680 -- loaded well before semantic processing starts.
20682 -- The only processing we defer to this point is the check for
20683 -- correct placement.
20685 when Pragma_Source_File_Name
=>
20687 Check_Valid_Configuration_Pragma
;
20689 ------------------------------
20690 -- Source_File_Name_Project --
20691 ------------------------------
20693 -- See Source_File_Name for syntax
20695 -- No processing here. Processing was completed during parsing, since
20696 -- we need to have file names set as early as possible. Units are
20697 -- loaded well before semantic processing starts.
20699 -- The only processing we defer to this point is the check for
20700 -- correct placement.
20702 when Pragma_Source_File_Name_Project
=>
20704 Check_Valid_Configuration_Pragma
;
20706 -- Check that a pragma Source_File_Name_Project is used only in a
20707 -- configuration pragmas file.
20709 -- Pragmas Source_File_Name_Project should only be generated by
20710 -- the Project Manager in configuration pragmas files.
20712 -- This is really an ugly test. It seems to depend on some
20713 -- accidental and undocumented property. At the very least it
20714 -- needs to be documented, but it would be better to have a
20715 -- clean way of testing if we are in a configuration file???
20717 if Present
(Parent
(N
)) then
20719 ("pragma% can only appear in a configuration pragmas file");
20722 ----------------------
20723 -- Source_Reference --
20724 ----------------------
20726 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20728 -- Nothing to do, all processing completed in Par.Prag, since we need
20729 -- the information for possible parser messages that are output.
20731 when Pragma_Source_Reference
=>
20738 -- pragma SPARK_Mode [(On | Off)];
20740 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
20741 Mode_Id
: SPARK_Mode_Type
;
20743 procedure Check_Pragma_Conformance
20744 (Context_Pragma
: Node_Id
;
20745 Entity
: Entity_Id
;
20746 Entity_Pragma
: Node_Id
);
20747 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20748 -- conformance of pragma N depending the following scenarios:
20750 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20751 -- compatible with the pragma Context_Pragma that was inherited
20752 -- from the context:
20753 -- * If the mode of Context_Pragma is ON, then the new mode can
20755 -- * If the mode of Context_Pragma is OFF, then the only allowed
20756 -- new mode is also OFF. Emit error if this is not the case.
20758 -- If Entity is not Empty, verify that pragma N is compatible with
20759 -- pragma Entity_Pragma that belongs to Entity.
20760 -- * If Entity_Pragma is Empty, always issue an error as this
20761 -- corresponds to the case where a previous section of Entity
20762 -- has no SPARK_Mode set.
20763 -- * If the mode of Entity_Pragma is ON, then the new mode can
20765 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20766 -- new mode is also OFF. Emit error if this is not the case.
20768 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
20769 -- Subsidiary to routines Process_xxx. Verify that the related
20770 -- entity E subject to pragma SPARK_Mode is library-level.
20772 procedure Process_Body
(Decl
: Node_Id
);
20773 -- Verify the legality of pragma SPARK_Mode when it appears as the
20774 -- top of the body declarations of entry, package, protected unit,
20775 -- subprogram or task unit body denoted by Decl.
20777 procedure Process_Overloadable
(Decl
: Node_Id
);
20778 -- Verify the legality of pragma SPARK_Mode when it applies to an
20779 -- entry or [generic] subprogram declaration denoted by Decl.
20781 procedure Process_Private_Part
(Decl
: Node_Id
);
20782 -- Verify the legality of pragma SPARK_Mode when it appears at the
20783 -- top of the private declarations of a package spec, protected or
20784 -- task unit declaration denoted by Decl.
20786 procedure Process_Statement_Part
(Decl
: Node_Id
);
20787 -- Verify the legality of pragma SPARK_Mode when it appears at the
20788 -- top of the statement sequence of a package body denoted by node
20791 procedure Process_Visible_Part
(Decl
: Node_Id
);
20792 -- Verify the legality of pragma SPARK_Mode when it appears at the
20793 -- top of the visible declarations of a package spec, protected or
20794 -- task unit declaration denoted by Decl. The routine is also used
20795 -- on protected or task units declared without a definition.
20797 procedure Set_SPARK_Context
;
20798 -- Subsidiary to routines Process_xxx. Set the global variables
20799 -- which represent the mode of the context from pragma N. Ensure
20800 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20802 ------------------------------
20803 -- Check_Pragma_Conformance --
20804 ------------------------------
20806 procedure Check_Pragma_Conformance
20807 (Context_Pragma
: Node_Id
;
20808 Entity
: Entity_Id
;
20809 Entity_Pragma
: Node_Id
)
20811 Err_Id
: Entity_Id
;
20815 -- The current pragma may appear without an argument. If this
20816 -- is the case, associate all error messages with the pragma
20819 if Present
(Arg1
) then
20825 -- The mode of the current pragma is compared against that of
20826 -- an enclosing context.
20828 if Present
(Context_Pragma
) then
20829 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
20831 -- Issue an error if the new mode is less restrictive than
20832 -- that of the context.
20834 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
20835 and then Get_SPARK_Mode_From_Annotation
(N
) = On
20838 ("cannot change SPARK_Mode from Off to On", Err_N
);
20839 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
20840 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
20845 -- The mode of the current pragma is compared against that of
20846 -- an initial package, protected type, subprogram or task type
20849 if Present
(Entity
) then
20851 -- A simple protected or task type is transformed into an
20852 -- anonymous type whose name cannot be used to issue error
20853 -- messages. Recover the original entity of the type.
20855 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
20858 (Original_Node
(Unit_Declaration_Node
(Entity
)));
20863 -- Both the initial declaration and the completion carry
20864 -- SPARK_Mode pragmas.
20866 if Present
(Entity_Pragma
) then
20867 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
20869 -- Issue an error if the new mode is less restrictive
20870 -- than that of the initial declaration.
20872 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
20873 and then Get_SPARK_Mode_From_Annotation
(N
) = On
20875 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20876 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
20878 ("\value Off was set for SPARK_Mode on&#",
20883 -- Otherwise the initial declaration lacks a SPARK_Mode
20884 -- pragma in which case the current pragma is illegal as
20885 -- it cannot "complete".
20888 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
20889 Error_Msg_Sloc
:= Sloc
(Err_Id
);
20891 ("\no value was set for SPARK_Mode on&#",
20896 end Check_Pragma_Conformance
;
20898 --------------------------------
20899 -- Check_Library_Level_Entity --
20900 --------------------------------
20902 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
20903 procedure Add_Entity_To_Name_Buffer
;
20904 -- Add the E_Kind of entity E to the name buffer
20906 -------------------------------
20907 -- Add_Entity_To_Name_Buffer --
20908 -------------------------------
20910 procedure Add_Entity_To_Name_Buffer
is
20912 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
20913 Add_Str_To_Name_Buffer
("entry");
20915 elsif Ekind_In
(E
, E_Generic_Package
,
20919 Add_Str_To_Name_Buffer
("package");
20921 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
20922 Add_Str_To_Name_Buffer
("protected type");
20924 elsif Ekind_In
(E
, E_Function
,
20925 E_Generic_Function
,
20926 E_Generic_Procedure
,
20930 Add_Str_To_Name_Buffer
("subprogram");
20933 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
20934 Add_Str_To_Name_Buffer
("task type");
20936 end Add_Entity_To_Name_Buffer
;
20940 Msg_1
: constant String := "incorrect placement of pragma%";
20943 -- Start of processing for Check_Library_Level_Entity
20946 if not Is_Library_Level_Entity
(E
) then
20947 Error_Msg_Name_1
:= Pname
;
20948 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
20951 Add_Str_To_Name_Buffer
("\& is not a library-level ");
20952 Add_Entity_To_Name_Buffer
;
20954 Msg_2
:= Name_Find
;
20955 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
20959 end Check_Library_Level_Entity
;
20965 procedure Process_Body
(Decl
: Node_Id
) is
20966 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
20967 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
20970 -- Ignore pragma when applied to the special body created for
20971 -- inlining, recognized by its internal name _Parent.
20973 if Chars
(Body_Id
) = Name_uParent
then
20977 Check_Library_Level_Entity
(Body_Id
);
20979 -- For entry bodies, verify the legality against:
20980 -- * The mode of the context
20981 -- * The mode of the spec (if any)
20983 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
20985 -- A stand alone subprogram body
20987 if Body_Id
= Spec_Id
then
20988 Check_Pragma_Conformance
20989 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
20991 Entity_Pragma
=> Empty
);
20993 -- An entry or subprogram body that completes a previous
20997 Check_Pragma_Conformance
20998 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21000 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21004 Set_SPARK_Pragma
(Body_Id
, N
);
21005 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21007 -- For package bodies, verify the legality against:
21008 -- * The mode of the context
21009 -- * The mode of the private part
21011 -- This case is separated from protected and task bodies
21012 -- because the statement part of the package body inherits
21013 -- the mode of the body declarations.
21015 elsif Nkind
(Decl
) = N_Package_Body
then
21016 Check_Pragma_Conformance
21017 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21019 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21022 Set_SPARK_Pragma
(Body_Id
, N
);
21023 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21024 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21025 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
21027 -- For protected and task bodies, verify the legality against:
21028 -- * The mode of the context
21029 -- * The mode of the private part
21033 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
21035 Check_Pragma_Conformance
21036 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21038 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21041 Set_SPARK_Pragma
(Body_Id
, N
);
21042 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21046 --------------------------
21047 -- Process_Overloadable --
21048 --------------------------
21050 procedure Process_Overloadable
(Decl
: Node_Id
) is
21051 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21052 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
21055 Check_Library_Level_Entity
(Spec_Id
);
21057 -- Verify the legality against:
21058 -- * The mode of the context
21060 Check_Pragma_Conformance
21061 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21063 Entity_Pragma
=> Empty
);
21065 Set_SPARK_Pragma
(Spec_Id
, N
);
21066 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21068 -- When the pragma applies to the anonymous object created for
21069 -- a single task type, decorate the type as well. This scenario
21070 -- arises when the single task type lacks a task definition,
21071 -- therefore there is no issue with respect to a potential
21072 -- pragma SPARK_Mode in the private part.
21074 -- task type Anon_Task_Typ;
21075 -- Obj : Anon_Task_Typ;
21076 -- pragma SPARK_Mode ...;
21078 if Is_Single_Task_Object
(Spec_Id
) then
21079 Set_SPARK_Pragma
(Spec_Typ
, N
);
21080 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
21081 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
21082 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
21084 end Process_Overloadable
;
21086 --------------------------
21087 -- Process_Private_Part --
21088 --------------------------
21090 procedure Process_Private_Part
(Decl
: Node_Id
) is
21091 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21094 Check_Library_Level_Entity
(Spec_Id
);
21096 -- Verify the legality against:
21097 -- * The mode of the visible declarations
21099 Check_Pragma_Conformance
21100 (Context_Pragma
=> Empty
,
21102 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21105 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21106 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
21107 end Process_Private_Part
;
21109 ----------------------------
21110 -- Process_Statement_Part --
21111 ----------------------------
21113 procedure Process_Statement_Part
(Decl
: Node_Id
) is
21114 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21117 Check_Library_Level_Entity
(Body_Id
);
21119 -- Verify the legality against:
21120 -- * The mode of the body declarations
21122 Check_Pragma_Conformance
21123 (Context_Pragma
=> Empty
,
21125 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
21128 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21129 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
21130 end Process_Statement_Part
;
21132 --------------------------
21133 -- Process_Visible_Part --
21134 --------------------------
21136 procedure Process_Visible_Part
(Decl
: Node_Id
) is
21137 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21138 Obj_Id
: Entity_Id
;
21141 Check_Library_Level_Entity
(Spec_Id
);
21143 -- Verify the legality against:
21144 -- * The mode of the context
21146 Check_Pragma_Conformance
21147 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21149 Entity_Pragma
=> Empty
);
21151 -- A task unit declared without a definition does not set the
21152 -- SPARK_Mode of the context because the task does not have any
21153 -- entries that could inherit the mode.
21155 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
21156 N_Task_Type_Declaration
)
21161 Set_SPARK_Pragma
(Spec_Id
, N
);
21162 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21163 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21164 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
21166 -- When the pragma applies to a single protected or task type,
21167 -- decorate the corresponding anonymous object as well.
21169 -- protected Anon_Prot_Typ is
21170 -- pragma SPARK_Mode ...;
21172 -- end Anon_Prot_Typ;
21174 -- Obj : Anon_Prot_Typ;
21176 if Is_Single_Concurrent_Type
(Spec_Id
) then
21177 Obj_Id
:= Anonymous_Object
(Spec_Id
);
21179 Set_SPARK_Pragma
(Obj_Id
, N
);
21180 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
21182 end Process_Visible_Part
;
21184 -----------------------
21185 -- Set_SPARK_Context --
21186 -----------------------
21188 procedure Set_SPARK_Context
is
21190 SPARK_Mode
:= Mode_Id
;
21191 SPARK_Mode_Pragma
:= N
;
21192 end Set_SPARK_Context
;
21200 -- Start of processing for Do_SPARK_Mode
21203 -- When a SPARK_Mode pragma appears inside an instantiation whose
21204 -- enclosing context has SPARK_Mode set to "off", the pragma has
21205 -- no semantic effect.
21207 if Ignore_Pragma_SPARK_Mode
then
21208 Rewrite
(N
, Make_Null_Statement
(Loc
));
21214 Check_No_Identifiers
;
21215 Check_At_Most_N_Arguments
(1);
21217 -- Check the legality of the mode (no argument = ON)
21219 if Arg_Count
= 1 then
21220 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21221 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
21226 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
21227 Context
:= Parent
(N
);
21229 -- The pragma appears in a configuration file
21231 if No
(Context
) then
21232 Check_Valid_Configuration_Pragma
;
21234 if Present
(SPARK_Mode_Pragma
) then
21235 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21236 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
21242 -- The pragma acts as a configuration pragma in a compilation unit
21244 -- pragma SPARK_Mode ...;
21245 -- package Pack is ...;
21247 elsif Nkind
(Context
) = N_Compilation_Unit
21248 and then List_Containing
(N
) = Context_Items
(Context
)
21250 Check_Valid_Configuration_Pragma
;
21253 -- Otherwise the placement of the pragma within the tree dictates
21254 -- its associated construct. Inspect the declarative list where
21255 -- the pragma resides to find a potential construct.
21259 while Present
(Stmt
) loop
21261 -- Skip prior pragmas, but check for duplicates. Note that
21262 -- this also takes care of pragmas generated for aspects.
21264 if Nkind
(Stmt
) = N_Pragma
then
21265 if Pragma_Name
(Stmt
) = Pname
then
21266 Error_Msg_Name_1
:= Pname
;
21267 Error_Msg_Sloc
:= Sloc
(Stmt
);
21268 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
21272 -- The pragma applies to an expression function that has
21273 -- already been rewritten into a subprogram declaration.
21275 -- function Expr_Func return ... is (...);
21276 -- pragma SPARK_Mode ...;
21278 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
21279 and then Nkind
(Original_Node
(Stmt
)) =
21280 N_Expression_Function
21282 Process_Overloadable
(Stmt
);
21285 -- The pragma applies to the anonymous object created for a
21286 -- single concurrent type.
21288 -- protected type Anon_Prot_Typ ...;
21289 -- Obj : Anon_Prot_Typ;
21290 -- pragma SPARK_Mode ...;
21292 elsif Nkind
(Stmt
) = N_Object_Declaration
21293 and then Is_Single_Concurrent_Object
21294 (Defining_Entity
(Stmt
))
21296 Process_Overloadable
(Stmt
);
21299 -- Skip internally generated code
21301 elsif not Comes_From_Source
(Stmt
) then
21304 -- The pragma applies to an entry or [generic] subprogram
21308 -- pragma SPARK_Mode ...;
21311 -- procedure Proc ...;
21312 -- pragma SPARK_Mode ...;
21314 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
21315 N_Subprogram_Declaration
)
21316 or else (Nkind
(Stmt
) = N_Entry_Declaration
21317 and then Is_Protected_Type
21318 (Scope
(Defining_Entity
(Stmt
))))
21320 Process_Overloadable
(Stmt
);
21323 -- Otherwise the pragma does not apply to a legal construct
21324 -- or it does not appear at the top of a declarative or a
21325 -- statement list. Issue an error and stop the analysis.
21335 -- The pragma applies to a package or a subprogram that acts as
21336 -- a compilation unit.
21338 -- procedure Proc ...;
21339 -- pragma SPARK_Mode ...;
21341 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
21342 Context
:= Unit
(Parent
(Context
));
21345 -- The pragma appears at the top of entry, package, protected
21346 -- unit, subprogram or task unit body declarations.
21348 -- entry Ent when ... is
21349 -- pragma SPARK_Mode ...;
21351 -- package body Pack is
21352 -- pragma SPARK_Mode ...;
21354 -- procedure Proc ... is
21355 -- pragma SPARK_Mode;
21357 -- protected body Prot is
21358 -- pragma SPARK_Mode ...;
21360 if Nkind_In
(Context
, N_Entry_Body
,
21366 Process_Body
(Context
);
21368 -- The pragma appears at the top of the visible or private
21369 -- declaration of a package spec, protected or task unit.
21372 -- pragma SPARK_Mode ...;
21374 -- pragma SPARK_Mode ...;
21376 -- protected [type] Prot is
21377 -- pragma SPARK_Mode ...;
21379 -- pragma SPARK_Mode ...;
21381 elsif Nkind_In
(Context
, N_Package_Specification
,
21382 N_Protected_Definition
,
21385 if List_Containing
(N
) = Visible_Declarations
(Context
) then
21386 Process_Visible_Part
(Parent
(Context
));
21388 Process_Private_Part
(Parent
(Context
));
21391 -- The pragma appears at the top of package body statements
21393 -- package body Pack is
21395 -- pragma SPARK_Mode;
21397 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
21398 and then Nkind
(Parent
(Context
)) = N_Package_Body
21400 Process_Statement_Part
(Parent
(Context
));
21402 -- The pragma appeared as an aspect of a [generic] subprogram
21403 -- declaration that acts as a compilation unit.
21406 -- procedure Proc ...;
21407 -- pragma SPARK_Mode ...;
21409 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
21410 N_Subprogram_Declaration
)
21412 Process_Overloadable
(Context
);
21414 -- The pragma does not apply to a legal construct, issue error
21422 --------------------------------
21423 -- Static_Elaboration_Desired --
21424 --------------------------------
21426 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21428 when Pragma_Static_Elaboration_Desired
=>
21430 Check_At_Most_N_Arguments
(1);
21432 if Is_Compilation_Unit
(Current_Scope
)
21433 and then Ekind
(Current_Scope
) = E_Package
21435 Set_Static_Elaboration_Desired
(Current_Scope
, True);
21437 Error_Pragma
("pragma% must apply to a library-level package");
21444 -- pragma Storage_Size (EXPRESSION);
21446 when Pragma_Storage_Size
=> Storage_Size
: declare
21447 P
: constant Node_Id
:= Parent
(N
);
21451 Check_No_Identifiers
;
21452 Check_Arg_Count
(1);
21454 -- The expression must be analyzed in the special manner described
21455 -- in "Handling of Default Expressions" in sem.ads.
21457 Arg
:= Get_Pragma_Arg
(Arg1
);
21458 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21460 if not Is_OK_Static_Expression
(Arg
) then
21461 Check_Restriction
(Static_Storage_Size
, Arg
);
21464 if Nkind
(P
) /= N_Task_Definition
then
21469 if Has_Storage_Size_Pragma
(P
) then
21470 Error_Pragma
("duplicate pragma% not allowed");
21472 Set_Has_Storage_Size_Pragma
(P
, True);
21475 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
21483 -- pragma Storage_Unit (NUMERIC_LITERAL);
21485 -- Only permitted argument is System'Storage_Unit value
21487 when Pragma_Storage_Unit
=>
21488 Check_No_Identifiers
;
21489 Check_Arg_Count
(1);
21490 Check_Arg_Is_Integer_Literal
(Arg1
);
21492 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
21493 UI_From_Int
(Ttypes
.System_Storage_Unit
)
21495 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
21497 ("the only allowed argument for pragma% is ^", Arg1
);
21500 --------------------
21501 -- Stream_Convert --
21502 --------------------
21504 -- pragma Stream_Convert (
21505 -- [Entity =>] type_LOCAL_NAME,
21506 -- [Read =>] function_NAME,
21507 -- [Write =>] function NAME);
21509 when Pragma_Stream_Convert
=> Stream_Convert
: declare
21511 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
21512 -- Check that the given argument is the name of a local function
21513 -- of one argument that is not overloaded earlier in the current
21514 -- local scope. A check is also made that the argument is a
21515 -- function with one parameter.
21517 --------------------------------------
21518 -- Check_OK_Stream_Convert_Function --
21519 --------------------------------------
21521 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
21525 Check_Arg_Is_Local_Name
(Arg
);
21526 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
21528 if Has_Homonym
(Ent
) then
21530 ("argument for pragma% may not be overloaded", Arg
);
21533 if Ekind
(Ent
) /= E_Function
21534 or else No
(First_Formal
(Ent
))
21535 or else Present
(Next_Formal
(First_Formal
(Ent
)))
21538 ("argument for pragma% must be function of one argument",
21541 end Check_OK_Stream_Convert_Function
;
21543 -- Start of processing for Stream_Convert
21547 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
21548 Check_Arg_Count
(3);
21549 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21550 Check_Optional_Identifier
(Arg2
, Name_Read
);
21551 Check_Optional_Identifier
(Arg3
, Name_Write
);
21552 Check_Arg_Is_Local_Name
(Arg1
);
21553 Check_OK_Stream_Convert_Function
(Arg2
);
21554 Check_OK_Stream_Convert_Function
(Arg3
);
21557 Typ
: constant Entity_Id
:=
21558 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
21559 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
21560 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
21563 Check_First_Subtype
(Arg1
);
21565 -- Check for too early or too late. Note that we don't enforce
21566 -- the rule about primitive operations in this case, since, as
21567 -- is the case for explicit stream attributes themselves, these
21568 -- restrictions are not appropriate. Note that the chaining of
21569 -- the pragma by Rep_Item_Too_Late is actually the critical
21570 -- processing done for this pragma.
21572 if Rep_Item_Too_Early
(Typ
, N
)
21574 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
21579 -- Return if previous error
21581 if Etype
(Typ
) = Any_Type
21583 Etype
(Read
) = Any_Type
21585 Etype
(Write
) = Any_Type
21592 if Underlying_Type
(Etype
(Read
)) /= Typ
then
21594 ("incorrect return type for function&", Arg2
);
21597 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
21599 ("incorrect parameter type for function&", Arg3
);
21602 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
21603 Underlying_Type
(Etype
(Write
))
21606 ("result type of & does not match Read parameter type",
21610 end Stream_Convert
;
21616 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21618 -- This is processed by the parser since some of the style checks
21619 -- take place during source scanning and parsing. This means that
21620 -- we don't need to issue error messages here.
21622 when Pragma_Style_Checks
=> Style_Checks
: declare
21623 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21629 Check_No_Identifiers
;
21631 -- Two argument form
21633 if Arg_Count
= 2 then
21634 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21641 E_Id
:= Get_Pragma_Arg
(Arg2
);
21644 if not Is_Entity_Name
(E_Id
) then
21646 ("second argument of pragma% must be entity name",
21650 E
:= Entity
(E_Id
);
21652 if not Ignore_Style_Checks_Pragmas
then
21657 Set_Suppress_Style_Checks
21658 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
21659 exit when No
(Homonym
(E
));
21666 -- One argument form
21669 Check_Arg_Count
(1);
21671 if Nkind
(A
) = N_String_Literal
then
21675 Slen
: constant Natural := Natural (String_Length
(S
));
21676 Options
: String (1 .. Slen
);
21682 C
:= Get_String_Char
(S
, Pos
(J
));
21683 exit when not In_Character_Range
(C
);
21684 Options
(J
) := Get_Character
(C
);
21686 -- If at end of string, set options. As per discussion
21687 -- above, no need to check for errors, since we issued
21688 -- them in the parser.
21691 if not Ignore_Style_Checks_Pragmas
then
21692 Set_Style_Check_Options
(Options
);
21702 elsif Nkind
(A
) = N_Identifier
then
21703 if Chars
(A
) = Name_All_Checks
then
21704 if not Ignore_Style_Checks_Pragmas
then
21706 Set_GNAT_Style_Check_Options
;
21708 Set_Default_Style_Check_Options
;
21712 elsif Chars
(A
) = Name_On
then
21713 if not Ignore_Style_Checks_Pragmas
then
21714 Style_Check
:= True;
21717 elsif Chars
(A
) = Name_Off
then
21718 if not Ignore_Style_Checks_Pragmas
then
21719 Style_Check
:= False;
21730 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21732 when Pragma_Subtitle
=>
21734 Check_Arg_Count
(1);
21735 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
21736 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21743 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21745 when Pragma_Suppress
=>
21746 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
21752 -- pragma Suppress_All;
21754 -- The only check made here is that the pragma has no arguments.
21755 -- There are no placement rules, and the processing required (setting
21756 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21757 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21758 -- then creates and inserts a pragma Suppress (All_Checks).
21760 when Pragma_Suppress_All
=>
21762 Check_Arg_Count
(0);
21764 -------------------------
21765 -- Suppress_Debug_Info --
21766 -------------------------
21768 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21770 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
21771 Nam_Id
: Entity_Id
;
21775 Check_Arg_Count
(1);
21776 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21777 Check_Arg_Is_Local_Name
(Arg1
);
21779 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21781 -- A pragma that applies to a Ghost entity becomes Ghost for the
21782 -- purposes of legality checks and removal of ignored Ghost code.
21784 Mark_Pragma_As_Ghost
(N
, Nam_Id
);
21785 Set_Debug_Info_Off
(Nam_Id
);
21786 end Suppress_Debug_Info
;
21788 ----------------------------------
21789 -- Suppress_Exception_Locations --
21790 ----------------------------------
21792 -- pragma Suppress_Exception_Locations;
21794 when Pragma_Suppress_Exception_Locations
=>
21796 Check_Arg_Count
(0);
21797 Check_Valid_Configuration_Pragma
;
21798 Exception_Locations_Suppressed
:= True;
21800 -----------------------------
21801 -- Suppress_Initialization --
21802 -----------------------------
21804 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21806 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
21812 Check_Arg_Count
(1);
21813 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21814 Check_Arg_Is_Local_Name
(Arg1
);
21816 E_Id
:= Get_Pragma_Arg
(Arg1
);
21818 if Etype
(E_Id
) = Any_Type
then
21822 E
:= Entity
(E_Id
);
21824 -- A pragma that applies to a Ghost entity becomes Ghost for the
21825 -- purposes of legality checks and removal of ignored Ghost code.
21827 Mark_Pragma_As_Ghost
(N
, E
);
21829 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
21831 ("pragma% requires variable, type or subtype", Arg1
);
21834 if Rep_Item_Too_Early
(E
, N
)
21836 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
21841 -- For incomplete/private type, set flag on full view
21843 if Is_Incomplete_Or_Private_Type
(E
) then
21844 if No
(Full_View
(Base_Type
(E
))) then
21846 ("argument of pragma% cannot be an incomplete type", Arg1
);
21848 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
21851 -- For first subtype, set flag on base type
21853 elsif Is_First_Subtype
(E
) then
21854 Set_Suppress_Initialization
(Base_Type
(E
));
21856 -- For other than first subtype, set flag on subtype or variable
21859 Set_Suppress_Initialization
(E
);
21867 -- pragma System_Name (DIRECT_NAME);
21869 -- Syntax check: one argument, which must be the identifier GNAT or
21870 -- the identifier GCC, no other identifiers are acceptable.
21872 when Pragma_System_Name
=>
21874 Check_No_Identifiers
;
21875 Check_Arg_Count
(1);
21876 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
21878 -----------------------------
21879 -- Task_Dispatching_Policy --
21880 -----------------------------
21882 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
21884 when Pragma_Task_Dispatching_Policy
=> declare
21888 Check_Ada_83_Warning
;
21889 Check_Arg_Count
(1);
21890 Check_No_Identifiers
;
21891 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
21892 Check_Valid_Configuration_Pragma
;
21893 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
21894 DP
:= Fold_Upper
(Name_Buffer
(1));
21896 if Task_Dispatching_Policy
/= ' '
21897 and then Task_Dispatching_Policy
/= DP
21899 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
21901 ("task dispatching policy incompatible with policy#");
21903 -- Set new policy, but always preserve System_Location since we
21904 -- like the error message with the run time name.
21907 Task_Dispatching_Policy
:= DP
;
21909 if Task_Dispatching_Policy_Sloc
/= System_Location
then
21910 Task_Dispatching_Policy_Sloc
:= Loc
;
21919 -- pragma Task_Info (EXPRESSION);
21921 when Pragma_Task_Info
=> Task_Info
: declare
21922 P
: constant Node_Id
:= Parent
(N
);
21928 if Warn_On_Obsolescent_Feature
then
21930 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
21931 & "instead?j?", N
);
21934 if Nkind
(P
) /= N_Task_Definition
then
21935 Error_Pragma
("pragma% must appear in task definition");
21938 Check_No_Identifiers
;
21939 Check_Arg_Count
(1);
21941 Analyze_And_Resolve
21942 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
21944 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
21948 Ent
:= Defining_Identifier
(Parent
(P
));
21950 -- Check duplicate pragma before we chain the pragma in the Rep
21951 -- Item chain of Ent.
21954 (Ent
, Name_Task_Info
, Check_Parents
=> False)
21956 Error_Pragma
("duplicate pragma% not allowed");
21959 Record_Rep_Item
(Ent
, N
);
21966 -- pragma Task_Name (string_EXPRESSION);
21968 when Pragma_Task_Name
=> Task_Name
: declare
21969 P
: constant Node_Id
:= Parent
(N
);
21974 Check_No_Identifiers
;
21975 Check_Arg_Count
(1);
21977 Arg
:= Get_Pragma_Arg
(Arg1
);
21979 -- The expression is used in the call to Create_Task, and must be
21980 -- expanded there, not in the context of the current spec. It must
21981 -- however be analyzed to capture global references, in case it
21982 -- appears in a generic context.
21984 Preanalyze_And_Resolve
(Arg
, Standard_String
);
21986 if Nkind
(P
) /= N_Task_Definition
then
21990 Ent
:= Defining_Identifier
(Parent
(P
));
21992 -- Check duplicate pragma before we chain the pragma in the Rep
21993 -- Item chain of Ent.
21996 (Ent
, Name_Task_Name
, Check_Parents
=> False)
21998 Error_Pragma
("duplicate pragma% not allowed");
22001 Record_Rep_Item
(Ent
, N
);
22008 -- pragma Task_Storage (
22009 -- [Task_Type =>] LOCAL_NAME,
22010 -- [Top_Guard =>] static_integer_EXPRESSION);
22012 when Pragma_Task_Storage
=> Task_Storage
: declare
22013 Args
: Args_List
(1 .. 2);
22014 Names
: constant Name_List
(1 .. 2) := (
22018 Task_Type
: Node_Id
renames Args
(1);
22019 Top_Guard
: Node_Id
renames Args
(2);
22025 Gather_Associations
(Names
, Args
);
22027 if No
(Task_Type
) then
22029 ("missing task_type argument for pragma%");
22032 Check_Arg_Is_Local_Name
(Task_Type
);
22034 Ent
:= Entity
(Task_Type
);
22036 if not Is_Task_Type
(Ent
) then
22038 ("argument for pragma% must be task type", Task_Type
);
22041 if No
(Top_Guard
) then
22043 ("pragma% takes two arguments", Task_Type
);
22045 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
22048 Check_First_Subtype
(Task_Type
);
22050 if Rep_Item_Too_Late
(Ent
, N
) then
22059 -- pragma Test_Case
22060 -- ([Name =>] Static_String_EXPRESSION
22061 -- ,[Mode =>] MODE_TYPE
22062 -- [, Requires => Boolean_EXPRESSION]
22063 -- [, Ensures => Boolean_EXPRESSION]);
22065 -- MODE_TYPE ::= Nominal | Robustness
22067 -- Characteristics:
22069 -- * Analysis - The annotation undergoes initial checks to verify
22070 -- the legal placement and context. Secondary checks preanalyze the
22073 -- Analyze_Test_Case_In_Decl_Part
22075 -- * Expansion - None.
22077 -- * Template - The annotation utilizes the generic template of the
22078 -- related subprogram when it is:
22080 -- aspect on subprogram declaration
22082 -- The annotation must prepare its own template when it is:
22084 -- pragma on subprogram declaration
22086 -- * Globals - Capture of global references must occur after full
22089 -- * Instance - The annotation is instantiated automatically when
22090 -- the related generic subprogram is instantiated except for the
22091 -- "pragma on subprogram declaration" case. In that scenario the
22092 -- annotation must instantiate itself.
22094 when Pragma_Test_Case
=> Test_Case
: declare
22095 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
22096 -- Ensure that the contract of subprogram Subp_Id does not contain
22097 -- another Test_Case pragma with the same Name as the current one.
22099 -------------------------
22100 -- Check_Distinct_Name --
22101 -------------------------
22103 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
22104 Items
: constant Node_Id
:= Contract
(Subp_Id
);
22105 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
22109 -- Inspect all Test_Case pragma of the related subprogram
22110 -- looking for one with a duplicate "Name" argument.
22112 if Present
(Items
) then
22113 Prag
:= Contract_Test_Cases
(Items
);
22114 while Present
(Prag
) loop
22115 if Pragma_Name
(Prag
) = Name_Test_Case
22117 and then String_Equal
22118 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
22120 Error_Msg_Sloc
:= Sloc
(Prag
);
22121 Error_Pragma
("name for pragma % is already used #");
22124 Prag
:= Next_Pragma
(Prag
);
22127 end Check_Distinct_Name
;
22131 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
22134 Subp_Decl
: Node_Id
;
22135 Subp_Id
: Entity_Id
;
22137 -- Start of processing for Test_Case
22141 Check_At_Least_N_Arguments
(2);
22142 Check_At_Most_N_Arguments
(4);
22144 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
22148 Check_Optional_Identifier
(Arg1
, Name_Name
);
22149 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22153 Check_Optional_Identifier
(Arg2
, Name_Mode
);
22154 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
22156 -- Arguments "Requires" and "Ensures"
22158 if Present
(Arg3
) then
22159 if Present
(Arg4
) then
22160 Check_Identifier
(Arg3
, Name_Requires
);
22161 Check_Identifier
(Arg4
, Name_Ensures
);
22163 Check_Identifier_Is_One_Of
22164 (Arg3
, Name_Requires
, Name_Ensures
);
22168 -- Pragma Test_Case must be associated with a subprogram declared
22169 -- in a library-level package. First determine whether the current
22170 -- compilation unit is a legal context.
22172 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
22173 N_Generic_Package_Declaration
)
22177 -- Otherwise the placement is illegal
22181 ("pragma % must be specified within a package declaration");
22185 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
22187 -- Find the enclosing context
22189 Context
:= Parent
(Subp_Decl
);
22191 if Present
(Context
) then
22192 Context
:= Parent
(Context
);
22195 -- Verify the placement of the pragma
22197 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
22199 ("pragma % cannot be applied to abstract subprogram");
22202 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
22203 Error_Pragma
("pragma % cannot be applied to entry");
22206 -- The context is a [generic] subprogram declared at the top level
22207 -- of the [generic] package unit.
22209 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
22210 N_Subprogram_Declaration
)
22211 and then Present
(Context
)
22212 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
22213 N_Package_Declaration
)
22217 -- Otherwise the placement is illegal
22221 ("pragma % must be applied to a library-level subprogram "
22226 Subp_Id
:= Defining_Entity
(Subp_Decl
);
22228 -- Chain the pragma on the contract for further processing by
22229 -- Analyze_Test_Case_In_Decl_Part.
22231 Add_Contract_Item
(N
, Subp_Id
);
22233 -- A pragma that applies to a Ghost entity becomes Ghost for the
22234 -- purposes of legality checks and removal of ignored Ghost code.
22236 Mark_Pragma_As_Ghost
(N
, Subp_Id
);
22238 -- Preanalyze the original aspect argument "Name" for ASIS or for
22239 -- a generic subprogram to properly capture global references.
22241 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
22242 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
22244 if Present
(Asp_Arg
) then
22246 -- The argument appears with an identifier in association
22249 if Nkind
(Asp_Arg
) = N_Component_Association
then
22250 Asp_Arg
:= Expression
(Asp_Arg
);
22253 Check_Expr_Is_OK_Static_Expression
22254 (Asp_Arg
, Standard_String
);
22258 -- Ensure that the all Test_Case pragmas of the related subprogram
22259 -- have distinct names.
22261 Check_Distinct_Name
(Subp_Id
);
22263 -- Fully analyze the pragma when it appears inside an entry
22264 -- or subprogram body because it cannot benefit from forward
22267 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
22269 N_Subprogram_Body_Stub
)
22271 -- The legality checks of pragma Test_Case are affected by the
22272 -- SPARK mode in effect and the volatility of the context.
22273 -- Analyze all pragmas in a specific order.
22275 Analyze_If_Present
(Pragma_SPARK_Mode
);
22276 Analyze_If_Present
(Pragma_Volatile_Function
);
22277 Analyze_Test_Case_In_Decl_Part
(N
);
22281 --------------------------
22282 -- Thread_Local_Storage --
22283 --------------------------
22285 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22287 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
22293 Check_Arg_Count
(1);
22294 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22295 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22297 Id
:= Get_Pragma_Arg
(Arg1
);
22300 if not Is_Entity_Name
(Id
)
22301 or else Ekind
(Entity
(Id
)) /= E_Variable
22303 Error_Pragma_Arg
("local variable name required", Arg1
);
22308 -- A pragma that applies to a Ghost entity becomes Ghost for the
22309 -- purposes of legality checks and removal of ignored Ghost code.
22311 Mark_Pragma_As_Ghost
(N
, E
);
22313 if Rep_Item_Too_Early
(E
, N
)
22315 Rep_Item_Too_Late
(E
, N
)
22320 Set_Has_Pragma_Thread_Local_Storage
(E
);
22321 Set_Has_Gigi_Rep_Item
(E
);
22322 end Thread_Local_Storage
;
22328 -- pragma Time_Slice (static_duration_EXPRESSION);
22330 when Pragma_Time_Slice
=> Time_Slice
: declare
22336 Check_Arg_Count
(1);
22337 Check_No_Identifiers
;
22338 Check_In_Main_Program
;
22339 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
22341 if not Error_Posted
(Arg1
) then
22343 while Present
(Nod
) loop
22344 if Nkind
(Nod
) = N_Pragma
22345 and then Pragma_Name
(Nod
) = Name_Time_Slice
22347 Error_Msg_Name_1
:= Pname
;
22348 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
22355 -- Process only if in main unit
22357 if Get_Source_Unit
(Loc
) = Main_Unit
then
22358 Opt
.Time_Slice_Set
:= True;
22359 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
22361 if Val
<= Ureal_0
then
22362 Opt
.Time_Slice_Value
:= 0;
22364 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
22365 Opt
.Time_Slice_Value
:= 1_000_000_000
;
22368 Opt
.Time_Slice_Value
:=
22369 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
22378 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22380 -- TITLING_OPTION ::=
22381 -- [Title =>] STRING_LITERAL
22382 -- | [Subtitle =>] STRING_LITERAL
22384 when Pragma_Title
=> Title
: declare
22385 Args
: Args_List
(1 .. 2);
22386 Names
: constant Name_List
(1 .. 2) := (
22392 Gather_Associations
(Names
, Args
);
22395 for J
in 1 .. 2 loop
22396 if Present
(Args
(J
)) then
22397 Check_Arg_Is_OK_Static_Expression
22398 (Args
(J
), Standard_String
);
22403 ----------------------------
22404 -- Type_Invariant[_Class] --
22405 ----------------------------
22407 -- pragma Type_Invariant[_Class]
22408 -- ([Entity =>] type_LOCAL_NAME,
22409 -- [Check =>] EXPRESSION);
22411 when Pragma_Type_Invariant |
22412 Pragma_Type_Invariant_Class
=>
22413 Type_Invariant
: declare
22414 I_Pragma
: Node_Id
;
22417 Check_Arg_Count
(2);
22419 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22420 -- setting Class_Present for the Type_Invariant_Class case.
22422 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
22423 I_Pragma
:= New_Copy
(N
);
22424 Set_Pragma_Identifier
22425 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
22426 Rewrite
(N
, I_Pragma
);
22427 Set_Analyzed
(N
, False);
22429 end Type_Invariant
;
22431 ---------------------
22432 -- Unchecked_Union --
22433 ---------------------
22435 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22437 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
22438 Assoc
: constant Node_Id
:= Arg1
;
22439 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
22449 Check_No_Identifiers
;
22450 Check_Arg_Count
(1);
22451 Check_Arg_Is_Local_Name
(Arg1
);
22453 Find_Type
(Type_Id
);
22455 Typ
:= Entity
(Type_Id
);
22457 -- A pragma that applies to a Ghost entity becomes Ghost for the
22458 -- purposes of legality checks and removal of ignored Ghost code.
22460 Mark_Pragma_As_Ghost
(N
, Typ
);
22463 or else Rep_Item_Too_Early
(Typ
, N
)
22467 Typ
:= Underlying_Type
(Typ
);
22470 if Rep_Item_Too_Late
(Typ
, N
) then
22474 Check_First_Subtype
(Arg1
);
22476 -- Note remaining cases are references to a type in the current
22477 -- declarative part. If we find an error, we post the error on
22478 -- the relevant type declaration at an appropriate point.
22480 if not Is_Record_Type
(Typ
) then
22481 Error_Msg_N
("unchecked union must be record type", Typ
);
22484 elsif Is_Tagged_Type
(Typ
) then
22485 Error_Msg_N
("unchecked union must not be tagged", Typ
);
22488 elsif not Has_Discriminants
(Typ
) then
22490 ("unchecked union must have one discriminant", Typ
);
22493 -- Note: in previous versions of GNAT we used to check for limited
22494 -- types and give an error, but in fact the standard does allow
22495 -- Unchecked_Union on limited types, so this check was removed.
22497 -- Similarly, GNAT used to require that all discriminants have
22498 -- default values, but this is not mandated by the RM.
22500 -- Proceed with basic error checks completed
22503 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
22504 Clist
:= Component_List
(Tdef
);
22506 -- Check presence of component list and variant part
22508 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
22510 ("unchecked union must have variant part", Tdef
);
22514 -- Check components
22516 Comp
:= First
(Component_Items
(Clist
));
22517 while Present
(Comp
) loop
22518 Check_Component
(Comp
, Typ
);
22522 -- Check variant part
22524 Vpart
:= Variant_Part
(Clist
);
22526 Variant
:= First
(Variants
(Vpart
));
22527 while Present
(Variant
) loop
22528 Check_Variant
(Variant
, Typ
);
22533 Set_Is_Unchecked_Union
(Typ
);
22534 Set_Convention
(Typ
, Convention_C
);
22535 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
22536 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
22537 end Unchecked_Union
;
22539 ----------------------------
22540 -- Unevaluated_Use_Of_Old --
22541 ----------------------------
22543 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22545 when Pragma_Unevaluated_Use_Of_Old
=>
22547 Check_Arg_Count
(1);
22548 Check_No_Identifiers
;
22549 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
22551 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22552 -- a declarative part or a package spec.
22554 if not Is_Configuration_Pragma
then
22555 Check_Is_In_Decl_Part_Or_Package_Spec
;
22558 -- Store proper setting of Uneval_Old
22560 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22561 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
22563 ------------------------
22564 -- Unimplemented_Unit --
22565 ------------------------
22567 -- pragma Unimplemented_Unit;
22569 -- Note: this only gives an error if we are generating code, or if
22570 -- we are in a generic library unit (where the pragma appears in the
22571 -- body, not in the spec).
22573 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
22574 Cunitent
: constant Entity_Id
:=
22575 Cunit_Entity
(Get_Source_Unit
(Loc
));
22576 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
22580 Check_Arg_Count
(0);
22582 if Operating_Mode
= Generate_Code
22583 or else Ent_Kind
= E_Generic_Function
22584 or else Ent_Kind
= E_Generic_Procedure
22585 or else Ent_Kind
= E_Generic_Package
22587 Get_Name_String
(Chars
(Cunitent
));
22588 Set_Casing
(Mixed_Case
);
22589 Write_Str
(Name_Buffer
(1 .. Name_Len
));
22590 Write_Str
(" is not supported in this configuration");
22592 raise Unrecoverable_Error
;
22594 end Unimplemented_Unit
;
22596 ------------------------
22597 -- Universal_Aliasing --
22598 ------------------------
22600 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22602 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
22607 Check_Arg_Count
(1);
22608 Check_Optional_Identifier
(Arg2
, Name_Entity
);
22609 Check_Arg_Is_Local_Name
(Arg1
);
22610 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22612 if E_Id
= Any_Type
then
22614 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
22615 Error_Pragma_Arg
("pragma% requires type", Arg1
);
22618 -- A pragma that applies to a Ghost entity becomes Ghost for the
22619 -- purposes of legality checks and removal of ignored Ghost code.
22621 Mark_Pragma_As_Ghost
(N
, E_Id
);
22622 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
22623 Record_Rep_Item
(E_Id
, N
);
22624 end Universal_Alias
;
22626 --------------------
22627 -- Universal_Data --
22628 --------------------
22630 -- pragma Universal_Data [(library_unit_NAME)];
22632 when Pragma_Universal_Data
=>
22634 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
22640 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22642 when Pragma_Unmodified
=>
22643 Analyze_Unmodified_Or_Unused
;
22649 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22651 -- or when used in a context clause:
22653 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22655 when Pragma_Unreferenced
=>
22656 Analyze_Unreferenced_Or_Unused
;
22658 --------------------------
22659 -- Unreferenced_Objects --
22660 --------------------------
22662 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22664 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
22666 Arg_Expr
: Node_Id
;
22667 Arg_Id
: Entity_Id
;
22669 Ghost_Error_Posted
: Boolean := False;
22670 -- Flag set when an error concerning the illegal mix of Ghost and
22671 -- non-Ghost types is emitted.
22673 Ghost_Id
: Entity_Id
:= Empty
;
22674 -- The entity of the first Ghost type encountered while processing
22675 -- the arguments of the pragma.
22679 Check_At_Least_N_Arguments
(1);
22682 while Present
(Arg
) loop
22683 Check_No_Identifier
(Arg
);
22684 Check_Arg_Is_Local_Name
(Arg
);
22685 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22687 if Is_Entity_Name
(Arg_Expr
) then
22688 Arg_Id
:= Entity
(Arg_Expr
);
22690 if Is_Type
(Arg_Id
) then
22691 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
22693 -- A pragma that applies to a Ghost entity becomes Ghost
22694 -- for the purposes of legality checks and removal of
22695 -- ignored Ghost code.
22697 Mark_Pragma_As_Ghost
(N
, Arg_Id
);
22699 -- Capture the entity of the first Ghost type being
22700 -- processed for error detection purposes.
22702 if Is_Ghost_Entity
(Arg_Id
) then
22703 if No
(Ghost_Id
) then
22704 Ghost_Id
:= Arg_Id
;
22707 -- Otherwise the type is non-Ghost. It is illegal to mix
22708 -- references to Ghost and non-Ghost entities
22711 elsif Present
(Ghost_Id
)
22712 and then not Ghost_Error_Posted
22714 Ghost_Error_Posted
:= True;
22716 Error_Msg_Name_1
:= Pname
;
22718 ("pragma % cannot mention ghost and non-ghost types",
22721 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22722 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22724 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22725 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22729 ("argument for pragma% must be type or subtype", Arg
);
22733 ("argument for pragma% must be type or subtype", Arg
);
22738 end Unreferenced_Objects
;
22740 ------------------------------
22741 -- Unreserve_All_Interrupts --
22742 ------------------------------
22744 -- pragma Unreserve_All_Interrupts;
22746 when Pragma_Unreserve_All_Interrupts
=>
22748 Check_Arg_Count
(0);
22750 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
22751 Unreserve_All_Interrupts
:= True;
22758 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22760 when Pragma_Unsuppress
=>
22762 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
22768 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
22770 when Pragma_Unused
=>
22771 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
22772 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
22774 -------------------
22775 -- Use_VADS_Size --
22776 -------------------
22778 -- pragma Use_VADS_Size;
22780 when Pragma_Use_VADS_Size
=>
22782 Check_Arg_Count
(0);
22783 Check_Valid_Configuration_Pragma
;
22784 Use_VADS_Size
:= True;
22786 ---------------------
22787 -- Validity_Checks --
22788 ---------------------
22790 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22792 when Pragma_Validity_Checks
=> Validity_Checks
: declare
22793 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22799 Check_Arg_Count
(1);
22800 Check_No_Identifiers
;
22802 -- Pragma always active unless in CodePeer or GNATprove modes,
22803 -- which use a fixed configuration of validity checks.
22805 if not (CodePeer_Mode
or GNATprove_Mode
) then
22806 if Nkind
(A
) = N_String_Literal
then
22810 Slen
: constant Natural := Natural (String_Length
(S
));
22811 Options
: String (1 .. Slen
);
22815 -- Couldn't we use a for loop here over Options'Range???
22819 C
:= Get_String_Char
(S
, Pos
(J
));
22821 -- This is a weird test, it skips setting validity
22822 -- checks entirely if any element of S is out of
22823 -- range of Character, what is that about ???
22825 exit when not In_Character_Range
(C
);
22826 Options
(J
) := Get_Character
(C
);
22829 Set_Validity_Check_Options
(Options
);
22837 elsif Nkind
(A
) = N_Identifier
then
22838 if Chars
(A
) = Name_All_Checks
then
22839 Set_Validity_Check_Options
("a");
22840 elsif Chars
(A
) = Name_On
then
22841 Validity_Checks_On
:= True;
22842 elsif Chars
(A
) = Name_Off
then
22843 Validity_Checks_On
:= False;
22847 end Validity_Checks
;
22853 -- pragma Volatile (LOCAL_NAME);
22855 when Pragma_Volatile
=>
22856 Process_Atomic_Independent_Shared_Volatile
;
22858 -------------------------
22859 -- Volatile_Components --
22860 -------------------------
22862 -- pragma Volatile_Components (array_LOCAL_NAME);
22864 -- Volatile is handled by the same circuit as Atomic_Components
22866 --------------------------
22867 -- Volatile_Full_Access --
22868 --------------------------
22870 -- pragma Volatile_Full_Access (LOCAL_NAME);
22872 when Pragma_Volatile_Full_Access
=>
22874 Process_Atomic_Independent_Shared_Volatile
;
22876 -----------------------
22877 -- Volatile_Function --
22878 -----------------------
22880 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
22882 when Pragma_Volatile_Function
=> Volatile_Function
: declare
22883 Over_Id
: Entity_Id
;
22884 Spec_Id
: Entity_Id
;
22885 Subp_Decl
: Node_Id
;
22889 Check_No_Identifiers
;
22890 Check_At_Most_N_Arguments
(1);
22893 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
22895 -- Generic subprogram
22897 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
22900 -- Body acts as spec
22902 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
22903 and then No
(Corresponding_Spec
(Subp_Decl
))
22907 -- Body stub acts as spec
22909 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
22910 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
22916 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
22924 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
22926 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
22931 -- Chain the pragma on the contract for completeness
22933 Add_Contract_Item
(N
, Spec_Id
);
22935 -- The legality checks of pragma Volatile_Function are affected by
22936 -- the SPARK mode in effect. Analyze all pragmas in a specific
22939 Analyze_If_Present
(Pragma_SPARK_Mode
);
22941 -- A pragma that applies to a Ghost entity becomes Ghost for the
22942 -- purposes of legality checks and removal of ignored Ghost code.
22944 Mark_Pragma_As_Ghost
(N
, Spec_Id
);
22946 -- A volatile function cannot override a non-volatile function
22947 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
22948 -- in New_Overloaded_Entity, however at that point the pragma has
22949 -- not been processed yet.
22951 Over_Id
:= Overridden_Operation
(Spec_Id
);
22953 if Present
(Over_Id
)
22954 and then not Is_Volatile_Function
(Over_Id
)
22957 ("incompatible volatile function values in effect", Spec_Id
);
22959 Error_Msg_Sloc
:= Sloc
(Over_Id
);
22961 ("\& declared # with Volatile_Function value False",
22964 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
22966 ("\overridden # with Volatile_Function value True",
22970 -- Analyze the Boolean expression (if any)
22972 if Present
(Arg1
) then
22973 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
22975 end Volatile_Function
;
22977 ----------------------
22978 -- Warning_As_Error --
22979 ----------------------
22981 -- pragma Warning_As_Error (static_string_EXPRESSION);
22983 when Pragma_Warning_As_Error
=>
22985 Check_Arg_Count
(1);
22986 Check_No_Identifiers
;
22987 Check_Valid_Configuration_Pragma
;
22989 if not Is_Static_String_Expression
(Arg1
) then
22991 ("argument of pragma% must be static string expression",
22994 -- OK static string expression
22997 Acquire_Warning_Match_String
(Arg1
);
22998 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
22999 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
23000 new String'(Name_Buffer (1 .. Name_Len));
23007 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23009 -- DETAILS ::= On | Off
23010 -- DETAILS ::= On | Off, local_NAME
23011 -- DETAILS ::= static_string_EXPRESSION
23012 -- DETAILS ::= On | Off, static_string_EXPRESSION
23014 -- TOOL_NAME ::= GNAT | GNATProve
23016 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23018 -- Note: If the first argument matches an allowed tool name, it is
23019 -- always considered to be a tool name, even if there is a string
23020 -- variable of that name.
23022 -- Note if the second argument of DETAILS is a local_NAME then the
23023 -- second form is always understood. If the intention is to use
23024 -- the fourth form, then you can write NAME & "" to force the
23025 -- intepretation as a static_string_EXPRESSION.
23027 when Pragma_Warnings => Warnings : declare
23028 Reason : String_Id;
23032 Check_At_Least_N_Arguments (1);
23034 -- See if last argument is labeled Reason. If so, make sure we
23035 -- have a string literal or a concatenation of string literals,
23036 -- and acquire the REASON string. Then remove the REASON argument
23037 -- by decreasing Num_Args by one; Remaining processing looks only
23038 -- at first Num_Args arguments).
23041 Last_Arg : constant Node_Id :=
23042 Last (Pragma_Argument_Associations (N));
23045 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23046 and then Chars (Last_Arg) = Name_Reason
23049 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23050 Reason := End_String;
23051 Arg_Count := Arg_Count - 1;
23053 -- Not allowed in compiler units (bootstrap issues)
23055 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23057 -- No REASON string, set null string as reason
23060 Reason := Null_String_Id;
23064 -- Now proceed with REASON taken care of and eliminated
23066 Check_No_Identifiers;
23068 -- If debug flag -gnatd.i is set, pragma is ignored
23070 if Debug_Flag_Dot_I then
23074 -- Process various forms of the pragma
23077 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23078 Shifted_Args : List_Id;
23081 -- See if first argument is a tool name, currently either
23082 -- GNAT or GNATprove. If so, either ignore the pragma if the
23083 -- tool used does not match, or continue as if no tool name
23084 -- was given otherwise, by shifting the arguments.
23086 if Nkind (Argx) = N_Identifier
23087 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23089 if Chars (Argx) = Name_Gnat then
23090 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23091 Rewrite (N, Make_Null_Statement (Loc));
23096 elsif Chars (Argx) = Name_Gnatprove then
23097 if not GNATprove_Mode then
23098 Rewrite (N, Make_Null_Statement (Loc));
23104 raise Program_Error;
23107 -- At this point, the pragma Warnings applies to the tool,
23108 -- so continue with shifted arguments.
23110 Arg_Count := Arg_Count - 1;
23112 if Arg_Count = 1 then
23113 Shifted_Args := New_List (New_Copy (Arg2));
23114 elsif Arg_Count = 2 then
23115 Shifted_Args := New_List (New_Copy (Arg2),
23117 elsif Arg_Count = 3 then
23118 Shifted_Args := New_List (New_Copy (Arg2),
23122 raise Program_Error;
23127 Chars => Name_Warnings,
23128 Pragma_Argument_Associations => Shifted_Args));
23133 -- One argument case
23135 if Arg_Count = 1 then
23137 -- On/Off one argument case was processed by parser
23139 if Nkind (Argx) = N_Identifier
23140 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23144 -- One argument case must be ON/OFF or static string expr
23146 elsif not Is_Static_String_Expression (Arg1) then
23148 ("argument of pragma% must be On/Off or static string "
23149 & "expression", Arg1);
23151 -- One argument string expression case
23155 Lit : constant Node_Id := Expr_Value_S (Argx);
23156 Str : constant String_Id := Strval (Lit);
23157 Len : constant Nat := String_Length (Str);
23165 while J <= Len loop
23166 C := Get_String_Char (Str, J);
23167 OK := In_Character_Range (C);
23170 Chr := Get_Character (C);
23172 -- Dash case: only -Wxxx is accepted
23179 C := Get_String_Char (Str, J);
23180 Chr := Get_Character (C);
23181 exit when Chr = 'W
';
23186 elsif J < Len and then Chr = '.' then
23188 C := Get_String_Char (Str, J);
23189 Chr := Get_Character (C);
23191 if not Set_Dot_Warning_Switch (Chr) then
23193 ("invalid warning switch character "
23194 & '.' & Chr, Arg1);
23200 OK := Set_Warning_Switch (Chr);
23206 ("invalid warning switch character " & Chr,
23215 -- Two or more arguments (must be two)
23218 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23219 Check_Arg_Count (2);
23227 E_Id := Get_Pragma_Arg (Arg2);
23230 -- In the expansion of an inlined body, a reference to
23231 -- the formal may be wrapped in a conversion if the
23232 -- actual is a conversion. Retrieve the real entity name.
23234 if (In_Instance_Body or In_Inlined_Body)
23235 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23237 E_Id := Expression (E_Id);
23240 -- Entity name case
23242 if Is_Entity_Name (E_Id) then
23243 E := Entity (E_Id);
23250 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23253 -- For OFF case, make entry in warnings off
23254 -- pragma table for later processing. But we do
23255 -- not do that within an instance, since these
23256 -- warnings are about what is needed in the
23257 -- template, not an instance of it.
23259 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23260 and then Warn_On_Warnings_Off
23261 and then not In_Instance
23263 Warnings_Off_Pragmas.Append ((N, E, Reason));
23266 if Is_Enumeration_Type (E) then
23270 Lit := First_Literal (E);
23271 while Present (Lit) loop
23272 Set_Warnings_Off (Lit);
23273 Next_Literal (Lit);
23278 exit when No (Homonym (E));
23283 -- Error if not entity or static string expression case
23285 elsif not Is_Static_String_Expression (Arg2) then
23287 ("second argument of pragma% must be entity name "
23288 & "or static string expression", Arg2);
23290 -- Static string expression case
23293 Acquire_Warning_Match_String (Arg2);
23295 -- Note on configuration pragma case: If this is a
23296 -- configuration pragma, then for an OFF pragma, we
23297 -- just set Config True in the call, which is all
23298 -- that needs to be done. For the case of ON, this
23299 -- is normally an error, unless it is canceling the
23300 -- effect of a previous OFF pragma in the same file.
23301 -- In any other case, an error will be signalled (ON
23302 -- with no matching OFF).
23304 -- Note: We set Used if we are inside a generic to
23305 -- disable the test that the non-config case actually
23306 -- cancels a warning. That's because we can't be sure
23307 -- there isn't an instantiation in some other unit
23308 -- where a warning is suppressed.
23310 -- We could do a little better here by checking if the
23311 -- generic unit we are inside is public, but for now
23312 -- we don't bother with that refinement.
23314 if Chars (Argx) = Name_Off then
23315 Set_Specific_Warning_Off
23316 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23317 Config => Is_Configuration_Pragma,
23318 Used => Inside_A_Generic or else In_Instance);
23320 elsif Chars (Argx) = Name_On then
23321 Set_Specific_Warning_On
23322 (Loc, Name_Buffer (1 .. Name_Len), Err);
23326 ("??pragma Warnings On with no matching "
23327 & "Warnings Off", Loc);
23336 -------------------
23337 -- Weak_External --
23338 -------------------
23340 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23342 when Pragma_Weak_External => Weak_External : declare
23347 Check_Arg_Count (1);
23348 Check_Optional_Identifier (Arg1, Name_Entity);
23349 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23350 Ent := Entity (Get_Pragma_Arg (Arg1));
23352 if Rep_Item_Too_Early (Ent, N) then
23355 Ent := Underlying_Type (Ent);
23358 -- The only processing required is to link this item on to the
23359 -- list of rep items for the given entity. This is accomplished
23360 -- by the call to Rep_Item_Too_Late (when no error is detected
23361 -- and False is returned).
23363 if Rep_Item_Too_Late (Ent, N) then
23366 Set_Has_Gigi_Rep_Item (Ent);
23370 -----------------------------
23371 -- Wide_Character_Encoding --
23372 -----------------------------
23374 -- pragma Wide_Character_Encoding (IDENTIFIER);
23376 when Pragma_Wide_Character_Encoding =>
23379 -- Nothing to do, handled in parser. Note that we do not enforce
23380 -- configuration pragma placement, this pragma can appear at any
23381 -- place in the source, allowing mixed encodings within a single
23386 --------------------
23387 -- Unknown_Pragma --
23388 --------------------
23390 -- Should be impossible, since the case of an unknown pragma is
23391 -- separately processed before the case statement is entered.
23393 when Unknown_Pragma =>
23394 raise Program_Error;
23397 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23398 -- until AI is formally approved.
23400 -- Check_Order_Dependence;
23403 when Pragma_Exit => null;
23404 end Analyze_Pragma;
23406 ---------------------------------------------
23407 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23408 ---------------------------------------------
23410 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23412 Freeze_Id : Entity_Id := Empty)
23414 Disp_Typ : Entity_Id;
23415 -- The dispatching type of the subprogram subject to the pre- or
23418 function Check_References (Nod : Node_Id) return Traverse_Result;
23419 -- Check that expression Nod does not mention non-primitives of the
23420 -- type, global objects of the type, or other illegalities described
23421 -- and implied by AI12-0113.
23423 ----------------------
23424 -- Check_References --
23425 ----------------------
23427 function Check_References (Nod : Node_Id) return Traverse_Result is
23429 if Nkind (Nod) = N_Function_Call
23430 and then Is_Entity_Name (Name (Nod))
23433 Func : constant Entity_Id := Entity (Name (Nod));
23437 -- An operation of the type must be a primitive
23439 if No (Find_Dispatching_Type (Func)) then
23440 Form := First_Formal (Func);
23441 while Present (Form) loop
23442 if Etype (Form) = Disp_Typ then
23444 ("operation in class-wide condition must be "
23445 & "primitive of &", Nod, Disp_Typ);
23448 Next_Formal (Form);
23451 -- A return object of the type is illegal as well
23453 if Etype (Func) = Disp_Typ
23454 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23457 ("operation in class-wide condition must be primitive "
23458 & "of &", Nod, Disp_Typ);
23463 elsif Is_Entity_Name (Nod)
23465 (Etype (Nod) = Disp_Typ
23466 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23467 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23470 ("object in class-wide condition must be formal of type &",
23473 elsif Nkind (Nod) = N_Explicit_Dereference
23474 and then (Etype (Nod) = Disp_Typ
23475 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23476 and then (not Is_Entity_Name (Prefix (Nod))
23477 or else not Is_Formal (Entity (Prefix (Nod))))
23480 ("operation in class-wide condition must be primitive of &",
23485 end Check_References;
23487 procedure Check_Class_Wide_Condition is
23488 new Traverse_Proc (Check_References);
23492 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23493 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23494 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23496 Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode;
23499 Restore_Scope : Boolean := False;
23501 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23504 -- Do not analyze the pragma multiple times
23506 if Is_Analyzed_Pragma (N) then
23510 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23511 -- analysis of the pragma, the Ghost mode at point of declaration and
23512 -- point of analysis may not necessarily be the same. Use the mode in
23513 -- effect at the point of declaration.
23515 Set_Ghost_Mode (N);
23517 -- Ensure that the subprogram and its formals are visible when analyzing
23518 -- the expression of the pragma.
23520 if not In_Open_Scopes (Spec_Id) then
23521 Restore_Scope := True;
23522 Push_Scope (Spec_Id);
23524 if Is_Generic_Subprogram (Spec_Id) then
23525 Install_Generic_Formals (Spec_Id);
23527 Install_Formals (Spec_Id);
23531 Errors := Serious_Errors_Detected;
23532 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23534 -- Emit a clarification message when the expression contains at least
23535 -- one undefined reference, possibly due to contract "freezing".
23537 if Errors /= Serious_Errors_Detected
23538 and then Present (Freeze_Id)
23539 and then Has_Undefined_Reference (Expr)
23541 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23544 if Class_Present (N) then
23546 -- Verify that a class-wide condition is legal, i.e. the operation is
23547 -- a primitive of a tagged type. Note that a generic subprogram is
23548 -- not a primitive operation.
23550 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23552 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23553 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23555 if From_Aspect_Specification (N) then
23557 ("aspect % can only be specified for a primitive operation "
23558 & "of a tagged type", Corresponding_Aspect (N));
23560 -- The pragma is a source construct
23564 ("pragma % can only be specified for a primitive operation "
23565 & "of a tagged type", N);
23568 -- Remaining semantic checks require a full tree traversal
23571 Check_Class_Wide_Condition (Expr);
23576 if Restore_Scope then
23580 -- Currently it is not possible to inline pre/postconditions on a
23581 -- subprogram subject to pragma Inline_Always.
23583 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23584 Ghost_Mode := Save_Ghost_Mode;
23586 Set_Is_Analyzed_Pragma (N);
23587 end Analyze_Pre_Post_Condition_In_Decl_Part;
23589 ------------------------------------------
23590 -- Analyze_Refined_Depends_In_Decl_Part --
23591 ------------------------------------------
23593 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23594 Body_Inputs : Elist_Id := No_Elist;
23595 Body_Outputs : Elist_Id := No_Elist;
23596 -- The inputs and outputs of the subprogram body synthesized from pragma
23597 -- Refined_Depends.
23599 Dependencies : List_Id := No_List;
23601 -- The corresponding Depends pragma along with its clauses
23603 Matched_Items : Elist_Id := No_Elist;
23604 -- A list containing the entities of all successfully matched items
23605 -- found in pragma Depends.
23607 Refinements : List_Id := No_List;
23608 -- The clauses of pragma Refined_Depends
23610 Spec_Id : Entity_Id;
23611 -- The entity of the subprogram subject to pragma Refined_Depends
23613 Spec_Inputs : Elist_Id := No_Elist;
23614 Spec_Outputs : Elist_Id := No_Elist;
23615 -- The inputs and outputs of the subprogram spec synthesized from pragma
23618 procedure Check_Dependency_Clause
23619 (States : Elist_Id;
23620 Dep_Clause : Node_Id);
23621 -- Try to match a single dependency clause Dep_Clause against one or
23622 -- more refinement clauses found in list Refinements. Each successful
23623 -- match eliminates at least one refinement clause from Refinements.
23624 -- States is a list of states appearing in dependencies obtained by
23625 -- calling Get_States_Seen.
23627 procedure Check_Output_States;
23628 -- Determine whether pragma Depends contains an output state with a
23629 -- visible refinement and if so, ensure that pragma Refined_Depends
23630 -- mentions all its constituents as outputs.
23632 function Get_States_Seen (Dependencies : List_Id) return Elist_Id;
23633 -- Given a normalized list of dependencies obtained from calling
23634 -- Normalize_Clauses, return a list containing the entities of all
23635 -- states appearing in dependencies. It helps in checking refinements
23636 -- involving a state and a corresponding constituent which is not a
23637 -- direct constituent of the state.
23639 procedure Normalize_Clauses (Clauses : List_Id);
23640 -- Given a list of dependence or refinement clauses Clauses, normalize
23641 -- each clause by creating multiple dependencies with exactly one input
23644 procedure Report_Extra_Clauses;
23645 -- Emit an error for each extra clause found in list Refinements
23647 -----------------------------
23648 -- Check_Dependency_Clause --
23649 -----------------------------
23651 procedure Check_Dependency_Clause
23652 (States : Elist_Id;
23653 Dep_Clause : Node_Id)
23655 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23656 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23658 function Is_In_Out_State_Clause return Boolean;
23659 -- Determine whether dependence clause Dep_Clause denotes an abstract
23660 -- state that depends on itself (State => State).
23662 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23663 -- Determine whether item Item denotes an abstract state with visible
23664 -- null refinement.
23666 procedure Match_Items
23667 (Dep_Item : Node_Id;
23668 Ref_Item : Node_Id;
23669 Matched : out Boolean);
23670 -- Try to match dependence item Dep_Item against refinement item
23671 -- Ref_Item. To match against a possible null refinement (see 2, 9),
23672 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23673 -- the following conformance scenarios is in effect:
23674 -- 1) Both items denote null
23675 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23676 -- 3) Both items denote attribute 'Result
23677 -- 4) Both items denote the same object
23678 -- 5) Both items denote the same formal parameter
23679 -- 6) Both items denote the same current instance of a type
23680 -- 7) Both items denote the same discriminant
23681 -- 8) Dep_Item is an abstract state with visible null refinement
23682 -- and Ref_Item denotes null.
23683 -- 9) Dep_Item is an abstract state with visible null refinement
23684 -- and Ref_Item is Empty (special case).
23685 -- 10) Dep_Item is an abstract state with full or partial visible
23686 -- non-null refinement and Ref_Item denotes one of its
23688 -- 11) Dep_Item is an abstract state without a full visible
23689 -- refinement and Ref_Item denotes the same state.
23690 -- When scenario 10 is in effect, the entity of the abstract state
23691 -- denoted by Dep_Item is added to list Refined_States.
23693 procedure Record_Item
(Item_Id
: Entity_Id
);
23694 -- Store the entity of an item denoted by Item_Id in Matched_Items
23696 ----------------------------
23697 -- Is_In_Out_State_Clause --
23698 ----------------------------
23700 function Is_In_Out_State_Clause
return Boolean is
23701 Dep_Input_Id
: Entity_Id
;
23702 Dep_Output_Id
: Entity_Id
;
23705 -- Detect the following clause:
23708 if Is_Entity_Name
(Dep_Input
)
23709 and then Is_Entity_Name
(Dep_Output
)
23711 -- Handle abstract views generated for limited with clauses
23713 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
23714 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
23717 Ekind
(Dep_Input_Id
) = E_Abstract_State
23718 and then Dep_Input_Id
= Dep_Output_Id
;
23722 end Is_In_Out_State_Clause
;
23724 ---------------------------
23725 -- Is_Null_Refined_State --
23726 ---------------------------
23728 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
23729 Item_Id
: Entity_Id
;
23732 if Is_Entity_Name
(Item
) then
23734 -- Handle abstract views generated for limited with clauses
23736 Item_Id
:= Available_View
(Entity_Of
(Item
));
23739 Ekind
(Item_Id
) = E_Abstract_State
23740 and then Has_Null_Visible_Refinement
(Item_Id
);
23744 end Is_Null_Refined_State
;
23750 procedure Match_Items
23751 (Dep_Item
: Node_Id
;
23752 Ref_Item
: Node_Id
;
23753 Matched
: out Boolean)
23755 Dep_Item_Id
: Entity_Id
;
23756 Ref_Item_Id
: Entity_Id
;
23759 -- Assume that the two items do not match
23763 -- A null matches null or Empty (special case)
23765 if Nkind
(Dep_Item
) = N_Null
23766 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23770 -- Attribute 'Result matches attribute 'Result
23772 elsif Is_Attribute_Result
(Dep_Item
)
23773 and then Is_Attribute_Result
(Dep_Item
)
23777 -- Abstract states, current instances of concurrent types,
23778 -- discriminants, formal parameters and objects.
23780 elsif Is_Entity_Name
(Dep_Item
) then
23782 -- Handle abstract views generated for limited with clauses
23784 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
23786 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
23788 -- An abstract state with visible null refinement matches
23789 -- null or Empty (special case).
23791 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
23792 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23794 Record_Item
(Dep_Item_Id
);
23797 -- An abstract state with visible non-null refinement
23798 -- matches one of its constituents, or itself for an
23799 -- abstract state with partial visible refinement.
23801 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
23802 if Is_Entity_Name
(Ref_Item
) then
23803 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
23805 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
23808 and then Present
(Encapsulating_State
(Ref_Item_Id
))
23809 and then Find_Encapsulating_State
23810 (States
, Ref_Item_Id
) = Dep_Item_Id
23812 Record_Item
(Dep_Item_Id
);
23815 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
23816 and then Ref_Item_Id
= Dep_Item_Id
23818 Record_Item
(Dep_Item_Id
);
23823 -- An abstract state without a visible refinement matches
23826 elsif Is_Entity_Name
(Ref_Item
)
23827 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23829 Record_Item
(Dep_Item_Id
);
23833 -- A current instance of a concurrent type, discriminant,
23834 -- formal parameter or an object matches itself.
23836 elsif Is_Entity_Name
(Ref_Item
)
23837 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
23839 Record_Item
(Dep_Item_Id
);
23849 procedure Record_Item
(Item_Id
: Entity_Id
) is
23851 if not Contains
(Matched_Items
, Item_Id
) then
23852 Append_New_Elmt
(Item_Id
, Matched_Items
);
23858 Clause_Matched
: Boolean := False;
23859 Dummy
: Boolean := False;
23860 Inputs_Match
: Boolean;
23861 Next_Ref_Clause
: Node_Id
;
23862 Outputs_Match
: Boolean;
23863 Ref_Clause
: Node_Id
;
23864 Ref_Input
: Node_Id
;
23865 Ref_Output
: Node_Id
;
23867 -- Start of processing for Check_Dependency_Clause
23870 -- Do not perform this check in an instance because it was already
23871 -- performed successfully in the generic template.
23873 if Is_Generic_Instance
(Spec_Id
) then
23877 -- Examine all refinement clauses and compare them against the
23878 -- dependence clause.
23880 Ref_Clause
:= First
(Refinements
);
23881 while Present
(Ref_Clause
) loop
23882 Next_Ref_Clause
:= Next
(Ref_Clause
);
23884 -- Obtain the attributes of the current refinement clause
23886 Ref_Input
:= Expression
(Ref_Clause
);
23887 Ref_Output
:= First
(Choices
(Ref_Clause
));
23889 -- The current refinement clause matches the dependence clause
23890 -- when both outputs match and both inputs match. See routine
23891 -- Match_Items for all possible conformance scenarios.
23893 -- Depends Dep_Output => Dep_Input
23897 -- Refined_Depends Ref_Output => Ref_Input
23900 (Dep_Item
=> Dep_Input
,
23901 Ref_Item
=> Ref_Input
,
23902 Matched
=> Inputs_Match
);
23905 (Dep_Item
=> Dep_Output
,
23906 Ref_Item
=> Ref_Output
,
23907 Matched
=> Outputs_Match
);
23909 -- An In_Out state clause may be matched against a refinement with
23910 -- a null input or null output as long as the non-null side of the
23911 -- relation contains a valid constituent of the In_Out_State.
23913 if Is_In_Out_State_Clause
then
23915 -- Depends => (State => State)
23916 -- Refined_Depends => (null => Constit) -- OK
23919 and then not Outputs_Match
23920 and then Nkind
(Ref_Output
) = N_Null
23922 Outputs_Match
:= True;
23925 -- Depends => (State => State)
23926 -- Refined_Depends => (Constit => null) -- OK
23928 if not Inputs_Match
23929 and then Outputs_Match
23930 and then Nkind
(Ref_Input
) = N_Null
23932 Inputs_Match
:= True;
23936 -- The current refinement clause is legally constructed following
23937 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
23938 -- the pool of candidates. The seach continues because a single
23939 -- dependence clause may have multiple matching refinements.
23941 if Inputs_Match
and Outputs_Match
then
23942 Clause_Matched
:= True;
23943 Remove
(Ref_Clause
);
23946 Ref_Clause
:= Next_Ref_Clause
;
23949 -- Depending on the order or composition of refinement clauses, an
23950 -- In_Out state clause may not be directly refinable.
23952 -- Depends => ((Output, State) => (Input, State))
23953 -- Refined_State => (State => (Constit_1, Constit_2))
23954 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
23956 -- Matching normalized clause (State => State) fails because there is
23957 -- no direct refinement capable of satisfying this relation. Another
23958 -- similar case arises when clauses (Constit_1 => Input) and (Output
23959 -- => Constit_2) are matched first, leaving no candidates for clause
23960 -- (State => State). Both scenarios are legal as long as one of the
23961 -- previous clauses mentioned a valid constituent of State.
23963 if not Clause_Matched
23964 and then Is_In_Out_State_Clause
23966 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
23968 Clause_Matched
:= True;
23971 -- A clause where the input is an abstract state with visible null
23972 -- refinement is implicitly matched when the output has already been
23973 -- matched in a previous clause.
23975 -- Depends => (Output => State) -- implicitly OK
23976 -- Refined_State => (State => null)
23977 -- Refined_Depends => (Output => ...)
23979 if not Clause_Matched
23980 and then Is_Null_Refined_State
(Dep_Input
)
23981 and then Is_Entity_Name
(Dep_Output
)
23983 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
23985 Clause_Matched
:= True;
23988 -- A clause where the output is an abstract state with visible null
23989 -- refinement is implicitly matched when the input has already been
23990 -- matched in a previous clause.
23992 -- Depends => (State => Input) -- implicitly OK
23993 -- Refined_State => (State => null)
23994 -- Refined_Depends => (... => Input)
23996 if not Clause_Matched
23997 and then Is_Null_Refined_State
(Dep_Output
)
23998 and then Is_Entity_Name
(Dep_Input
)
24000 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
24002 Clause_Matched
:= True;
24005 -- At this point either all refinement clauses have been examined or
24006 -- pragma Refined_Depends contains a solitary null. Only an abstract
24007 -- state with null refinement can possibly match these cases.
24009 -- Depends => (State => null)
24010 -- Refined_State => (State => null)
24011 -- Refined_Depends => null -- OK
24013 if not Clause_Matched
then
24015 (Dep_Item
=> Dep_Input
,
24017 Matched
=> Inputs_Match
);
24020 (Dep_Item
=> Dep_Output
,
24022 Matched
=> Outputs_Match
);
24024 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
24027 -- If the contents of Refined_Depends are legal, then the current
24028 -- dependence clause should be satisfied either by an explicit match
24029 -- or by one of the special cases.
24031 if not Clause_Matched
then
24033 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
24034 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
24036 end Check_Dependency_Clause
;
24038 -------------------------
24039 -- Check_Output_States --
24040 -------------------------
24042 procedure Check_Output_States
is
24043 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24044 -- Determine whether all constituents of state State_Id with full
24045 -- visible refinement are used as outputs in pragma Refined_Depends.
24046 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24048 -----------------------------
24049 -- Check_Constituent_Usage --
24050 -----------------------------
24052 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24053 Constits
: constant Elist_Id
:=
24054 Partial_Refinement_Constituents
(State_Id
);
24055 Constit_Elmt
: Elmt_Id
;
24056 Constit_Id
: Entity_Id
;
24057 Only_Partial
: constant Boolean :=
24058 not Has_Visible_Refinement
(State_Id
);
24059 Posted
: Boolean := False;
24062 if Present
(Constits
) then
24063 Constit_Elmt
:= First_Elmt
(Constits
);
24064 while Present
(Constit_Elmt
) loop
24065 Constit_Id
:= Node
(Constit_Elmt
);
24067 -- Issue an error when a constituent of State_Id is used,
24068 -- and State_Id has only partial visible refinement
24069 -- (SPARK RM 7.2.4(3d)).
24071 if Only_Partial
then
24072 if (Present
(Body_Inputs
)
24073 and then Appears_In
(Body_Inputs
, Constit_Id
))
24075 (Present
(Body_Outputs
)
24076 and then Appears_In
(Body_Outputs
, Constit_Id
))
24078 Error_Msg_Name_1
:= Chars
(State_Id
);
24080 ("constituent & of state % cannot be used in "
24081 & "dependence refinement", N
, Constit_Id
);
24082 Error_Msg_Name_1
:= Chars
(State_Id
);
24083 SPARK_Msg_N
("\use state % instead", N
);
24086 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24088 elsif Present
(Body_Inputs
)
24089 and then Appears_In
(Body_Inputs
, Constit_Id
)
24091 Error_Msg_Name_1
:= Chars
(State_Id
);
24093 ("constituent & of state % must act as output in "
24094 & "dependence refinement", N
, Constit_Id
);
24096 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24098 elsif No
(Body_Outputs
)
24099 or else not Appears_In
(Body_Outputs
, Constit_Id
)
24104 ("output state & must be replaced by all its "
24105 & "constituents in dependence refinement",
24110 ("\constituent & is missing in output list",
24114 Next_Elmt
(Constit_Elmt
);
24117 end Check_Constituent_Usage
;
24122 Item_Elmt
: Elmt_Id
;
24123 Item_Id
: Entity_Id
;
24125 -- Start of processing for Check_Output_States
24128 -- Do not perform this check in an instance because it was already
24129 -- performed successfully in the generic template.
24131 if Is_Generic_Instance
(Spec_Id
) then
24134 -- Inspect the outputs of pragma Depends looking for a state with a
24135 -- visible refinement.
24137 elsif Present
(Spec_Outputs
) then
24138 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
24139 while Present
(Item_Elmt
) loop
24140 Item
:= Node
(Item_Elmt
);
24142 -- Deal with the mixed nature of the input and output lists
24144 if Nkind
(Item
) = N_Defining_Identifier
then
24147 Item_Id
:= Available_View
(Entity_Of
(Item
));
24150 if Ekind
(Item_Id
) = E_Abstract_State
then
24152 -- The state acts as an input-output, skip it
24154 if Present
(Spec_Inputs
)
24155 and then Appears_In
(Spec_Inputs
, Item_Id
)
24159 -- Ensure that all of the constituents are utilized as
24160 -- outputs in pragma Refined_Depends.
24162 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
24163 Check_Constituent_Usage
(Item_Id
);
24167 Next_Elmt
(Item_Elmt
);
24170 end Check_Output_States
;
24172 ---------------------
24173 -- Get_States_Seen --
24174 ---------------------
24176 function Get_States_Seen
(Dependencies
: List_Id
) return Elist_Id
is
24177 States_Seen
: Elist_Id
:= No_Elist
;
24179 procedure Get_State
(Glob_Item
: Node_Id
);
24180 -- Add global item to States_Seen when it corresponds to a state
24186 procedure Get_State
(Glob_Item
: Node_Id
) is
24189 if Is_Entity_Name
(Glob_Item
) then
24190 Id
:= Entity_Of
(Glob_Item
);
24192 if Ekind
(Id
) = E_Abstract_State
then
24193 Append_New_Elmt
(Id
, States_Seen
);
24200 Dep_Clause
: Node_Id
;
24201 Dep_Input
: Node_Id
;
24202 Dep_Output
: Node_Id
;
24204 -- Start of processing for Get_States_Seen
24207 Dep_Clause
:= First
(Dependencies
);
24208 while Present
(Dep_Clause
) loop
24209 Dep_Input
:= Expression
(Dep_Clause
);
24210 Dep_Output
:= First
(Choices
(Dep_Clause
));
24212 Get_State
(Dep_Input
);
24213 Get_State
(Dep_Output
);
24218 return States_Seen
;
24219 end Get_States_Seen
;
24221 -----------------------
24222 -- Normalize_Clauses --
24223 -----------------------
24225 procedure Normalize_Clauses
(Clauses
: List_Id
) is
24226 procedure Normalize_Inputs
(Clause
: Node_Id
);
24227 -- Normalize clause Clause by creating multiple clauses for each
24228 -- input item of Clause. It is assumed that Clause has exactly one
24229 -- output. The transformation is as follows:
24231 -- Output => (Input_1, Input_2) -- original
24233 -- Output => Input_1 -- normalizations
24234 -- Output => Input_2
24236 procedure Normalize_Outputs
(Clause
: Node_Id
);
24237 -- Normalize clause Clause by creating multiple clause for each
24238 -- output item of Clause. The transformation is as follows:
24240 -- (Output_1, Output_2) => Input -- original
24242 -- Output_1 => Input -- normalization
24243 -- Output_2 => Input
24245 ----------------------
24246 -- Normalize_Inputs --
24247 ----------------------
24249 procedure Normalize_Inputs
(Clause
: Node_Id
) is
24250 Inputs
: constant Node_Id
:= Expression
(Clause
);
24251 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24252 Output
: constant List_Id
:= Choices
(Clause
);
24253 Last_Input
: Node_Id
;
24255 New_Clause
: Node_Id
;
24256 Next_Input
: Node_Id
;
24259 -- Normalization is performed only when the original clause has
24260 -- more than one input. Multiple inputs appear as an aggregate.
24262 if Nkind
(Inputs
) = N_Aggregate
then
24263 Last_Input
:= Last
(Expressions
(Inputs
));
24265 -- Create a new clause for each input
24267 Input
:= First
(Expressions
(Inputs
));
24268 while Present
(Input
) loop
24269 Next_Input
:= Next
(Input
);
24271 -- Unhook the current input from the original input list
24272 -- because it will be relocated to a new clause.
24276 -- Special processing for the last input. At this point the
24277 -- original aggregate has been stripped down to one element.
24278 -- Replace the aggregate by the element itself.
24280 if Input
= Last_Input
then
24281 Rewrite
(Inputs
, Input
);
24283 -- Generate a clause of the form:
24288 Make_Component_Association
(Loc
,
24289 Choices
=> New_Copy_List_Tree
(Output
),
24290 Expression
=> Input
);
24292 -- The new clause contains replicated content that has
24293 -- already been analyzed, mark the clause as analyzed.
24295 Set_Analyzed
(New_Clause
);
24296 Insert_After
(Clause
, New_Clause
);
24299 Input
:= Next_Input
;
24302 end Normalize_Inputs
;
24304 -----------------------
24305 -- Normalize_Outputs --
24306 -----------------------
24308 procedure Normalize_Outputs
(Clause
: Node_Id
) is
24309 Inputs
: constant Node_Id
:= Expression
(Clause
);
24310 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24311 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
24312 Last_Output
: Node_Id
;
24313 New_Clause
: Node_Id
;
24314 Next_Output
: Node_Id
;
24318 -- Multiple outputs appear as an aggregate. Nothing to do when
24319 -- the clause has exactly one output.
24321 if Nkind
(Outputs
) = N_Aggregate
then
24322 Last_Output
:= Last
(Expressions
(Outputs
));
24324 -- Create a clause for each output. Note that each time a new
24325 -- clause is created, the original output list slowly shrinks
24326 -- until there is one item left.
24328 Output
:= First
(Expressions
(Outputs
));
24329 while Present
(Output
) loop
24330 Next_Output
:= Next
(Output
);
24332 -- Unhook the output from the original output list as it
24333 -- will be relocated to a new clause.
24337 -- Special processing for the last output. At this point
24338 -- the original aggregate has been stripped down to one
24339 -- element. Replace the aggregate by the element itself.
24341 if Output
= Last_Output
then
24342 Rewrite
(Outputs
, Output
);
24345 -- Generate a clause of the form:
24346 -- (Output => Inputs)
24349 Make_Component_Association
(Loc
,
24350 Choices
=> New_List
(Output
),
24351 Expression
=> New_Copy_Tree
(Inputs
));
24353 -- The new clause contains replicated content that has
24354 -- already been analyzed. There is not need to reanalyze
24357 Set_Analyzed
(New_Clause
);
24358 Insert_After
(Clause
, New_Clause
);
24361 Output
:= Next_Output
;
24364 end Normalize_Outputs
;
24370 -- Start of processing for Normalize_Clauses
24373 Clause
:= First
(Clauses
);
24374 while Present
(Clause
) loop
24375 Normalize_Outputs
(Clause
);
24379 Clause
:= First
(Clauses
);
24380 while Present
(Clause
) loop
24381 Normalize_Inputs
(Clause
);
24384 end Normalize_Clauses
;
24386 --------------------------
24387 -- Report_Extra_Clauses --
24388 --------------------------
24390 procedure Report_Extra_Clauses
is
24394 -- Do not perform this check in an instance because it was already
24395 -- performed successfully in the generic template.
24397 if Is_Generic_Instance
(Spec_Id
) then
24400 elsif Present
(Refinements
) then
24401 Clause
:= First
(Refinements
);
24402 while Present
(Clause
) loop
24404 -- Do not complain about a null input refinement, since a null
24405 -- input legitimately matches anything.
24407 if Nkind
(Clause
) = N_Component_Association
24408 and then Nkind
(Expression
(Clause
)) = N_Null
24414 ("unmatched or extra clause in dependence refinement",
24421 end Report_Extra_Clauses
;
24425 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
24426 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
24427 Errors
: constant Nat
:= Serious_Errors_Detected
;
24432 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24435 -- Do not analyze the pragma multiple times
24437 if Is_Analyzed_Pragma
(N
) then
24441 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
24443 -- Use the anonymous object as the proper spec when Refined_Depends
24444 -- applies to the body of a single task type. The object carries the
24445 -- proper Chars as well as all non-refined versions of pragmas.
24447 if Is_Single_Concurrent_Type
(Spec_Id
) then
24448 Spec_Id
:= Anonymous_Object
(Spec_Id
);
24451 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
24453 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24454 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24456 if No
(Depends
) then
24458 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
24459 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
24463 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
24465 -- A null dependency relation renders the refinement useless because it
24466 -- cannot possibly mention abstract states with visible refinement. Note
24467 -- that the inverse is not true as states may be refined to null
24468 -- (SPARK RM 7.2.5(2)).
24470 if Nkind
(Deps
) = N_Null
then
24472 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
24473 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
24477 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24478 -- This ensures that the categorization of all refined dependency items
24479 -- is consistent with their role.
24481 Analyze_Depends_In_Decl_Part
(N
);
24483 -- Do not match dependencies against refinements if Refined_Depends is
24484 -- illegal to avoid emitting misleading error.
24486 if Serious_Errors_Detected
= Errors
then
24488 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24489 -- the inputs and outputs of the subprogram spec and body to verify
24490 -- the use of states with visible refinement and their constituents.
24492 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
24493 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
24495 Collect_Subprogram_Inputs_Outputs
24496 (Subp_Id
=> Spec_Id
,
24497 Synthesize
=> True,
24498 Subp_Inputs
=> Spec_Inputs
,
24499 Subp_Outputs
=> Spec_Outputs
,
24500 Global_Seen
=> Dummy
);
24502 Collect_Subprogram_Inputs_Outputs
24503 (Subp_Id
=> Body_Id
,
24504 Synthesize
=> True,
24505 Subp_Inputs
=> Body_Inputs
,
24506 Subp_Outputs
=> Body_Outputs
,
24507 Global_Seen
=> Dummy
);
24509 -- For an output state with a visible refinement, ensure that all
24510 -- constituents appear as outputs in the dependency refinement.
24512 Check_Output_States
;
24515 -- Matching is disabled in ASIS because clauses are not normalized as
24516 -- this is a tree altering activity similar to expansion.
24522 -- Multiple dependency clauses appear as component associations of an
24523 -- aggregate. Note that the clauses are copied because the algorithm
24524 -- modifies them and this should not be visible in Depends.
24526 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
24527 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
24528 Normalize_Clauses
(Dependencies
);
24530 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
24532 if Nkind
(Refs
) = N_Null
then
24533 Refinements
:= No_List
;
24535 -- Multiple dependency clauses appear as component associations of an
24536 -- aggregate. Note that the clauses are copied because the algorithm
24537 -- modifies them and this should not be visible in Refined_Depends.
24539 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
24540 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
24541 Normalize_Clauses
(Refinements
);
24544 -- At this point the clauses of pragmas Depends and Refined_Depends
24545 -- have been normalized into simple dependencies between one output
24546 -- and one input. Examine all clauses of pragma Depends looking for
24547 -- matching clauses in pragma Refined_Depends.
24550 States_Seen
: constant Elist_Id
:= Get_States_Seen
(Dependencies
);
24554 Clause
:= First
(Dependencies
);
24555 while Present
(Clause
) loop
24556 Check_Dependency_Clause
(States_Seen
, Clause
);
24561 if Serious_Errors_Detected
= Errors
then
24562 Report_Extra_Clauses
;
24567 Set_Is_Analyzed_Pragma
(N
);
24568 end Analyze_Refined_Depends_In_Decl_Part
;
24570 -----------------------------------------
24571 -- Analyze_Refined_Global_In_Decl_Part --
24572 -----------------------------------------
24574 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
24576 -- The corresponding Global pragma
24578 Has_In_State
: Boolean := False;
24579 Has_In_Out_State
: Boolean := False;
24580 Has_Out_State
: Boolean := False;
24581 Has_Proof_In_State
: Boolean := False;
24582 -- These flags are set when the corresponding Global pragma has a state
24583 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24586 Has_Null_State
: Boolean := False;
24587 -- This flag is set when the corresponding Global pragma has at least
24588 -- one state with a null refinement.
24590 In_Constits
: Elist_Id
:= No_Elist
;
24591 In_Out_Constits
: Elist_Id
:= No_Elist
;
24592 Out_Constits
: Elist_Id
:= No_Elist
;
24593 Proof_In_Constits
: Elist_Id
:= No_Elist
;
24594 -- These lists contain the entities of all Input, In_Out, Output and
24595 -- Proof_In constituents that appear in Refined_Global and participate
24596 -- in state refinement.
24598 In_Items
: Elist_Id
:= No_Elist
;
24599 In_Out_Items
: Elist_Id
:= No_Elist
;
24600 Out_Items
: Elist_Id
:= No_Elist
;
24601 Proof_In_Items
: Elist_Id
:= No_Elist
;
24602 -- These list contain the entities of all Input, In_Out, Output and
24603 -- Proof_In items defined in the corresponding Global pragma.
24605 Repeat_Items
: Elist_Id
:= No_Elist
;
24606 -- A list of all global items without full visible refinement found
24607 -- in pragma Global. These states should be repeated in the global
24608 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
24609 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
24611 Spec_Id
: Entity_Id
;
24612 -- The entity of the subprogram subject to pragma Refined_Global
24614 States
: Elist_Id
:= No_Elist
;
24615 -- A list of all states with full or partial visible refinement found in
24618 procedure Check_In_Out_States
;
24619 -- Determine whether the corresponding Global pragma mentions In_Out
24620 -- states with visible refinement and if so, ensure that one of the
24621 -- following completions apply to the constituents of the state:
24622 -- 1) there is at least one constituent of mode In_Out
24623 -- 2) there is at least one Input and one Output constituent
24624 -- 3) not all constituents are present and one of them is of mode
24626 -- This routine may remove elements from In_Constits, In_Out_Constits,
24627 -- Out_Constits and Proof_In_Constits.
24629 procedure Check_Input_States
;
24630 -- Determine whether the corresponding Global pragma mentions Input
24631 -- states with visible refinement and if so, ensure that at least one of
24632 -- its constituents appears as an Input item in Refined_Global.
24633 -- This routine may remove elements from In_Constits, In_Out_Constits,
24634 -- Out_Constits and Proof_In_Constits.
24636 procedure Check_Output_States
;
24637 -- Determine whether the corresponding Global pragma mentions Output
24638 -- states with visible refinement and if so, ensure that all of its
24639 -- constituents appear as Output items in Refined_Global.
24640 -- This routine may remove elements from In_Constits, In_Out_Constits,
24641 -- Out_Constits and Proof_In_Constits.
24643 procedure Check_Proof_In_States
;
24644 -- Determine whether the corresponding Global pragma mentions Proof_In
24645 -- states with visible refinement and if so, ensure that at least one of
24646 -- its constituents appears as a Proof_In item in Refined_Global.
24647 -- This routine may remove elements from In_Constits, In_Out_Constits,
24648 -- Out_Constits and Proof_In_Constits.
24650 procedure Check_Refined_Global_List
24652 Global_Mode
: Name_Id
:= Name_Input
);
24653 -- Verify the legality of a single global list declaration. Global_Mode
24654 -- denotes the current mode in effect.
24656 procedure Collect_Global_Items
24658 Mode
: Name_Id
:= Name_Input
);
24659 -- Gather all input, in out, output and Proof_In items from node List
24660 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24661 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24662 -- and Has_Proof_In_State are set when there is at least one abstract
24663 -- state with full or partial visible refinement available in the
24664 -- corresponding mode. Flag Has_Null_State is set when at least state
24665 -- has a null refinement. Mode denotes the current global mode in
24668 function Present_Then_Remove
24670 Item
: Entity_Id
) return Boolean;
24671 -- Search List for a particular entity Item. If Item has been found,
24672 -- remove it from List. This routine is used to strip lists In_Constits,
24673 -- In_Out_Constits and Out_Constits of valid constituents.
24675 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
24676 -- Same as function Present_Then_Remove, but do not report the presence
24677 -- of Item in List.
24679 procedure Report_Extra_Constituents
;
24680 -- Emit an error for each constituent found in lists In_Constits,
24681 -- In_Out_Constits and Out_Constits.
24683 procedure Report_Missing_Items
;
24684 -- Emit an error for each global item not repeated found in list
24687 -------------------------
24688 -- Check_In_Out_States --
24689 -------------------------
24691 procedure Check_In_Out_States
is
24692 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24693 -- Determine whether one of the following coverage scenarios is in
24695 -- 1) there is at least one constituent of mode In_Out or Output
24696 -- 2) there is at least one pair of constituents with modes Input
24697 -- and Output, or Proof_In and Output.
24698 -- 3) there is at least one constituent of mode Output and not all
24699 -- constituents are present.
24700 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24702 -----------------------------
24703 -- Check_Constituent_Usage --
24704 -----------------------------
24706 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24707 Constits
: constant Elist_Id
:=
24708 Partial_Refinement_Constituents
(State_Id
);
24709 Constit_Elmt
: Elmt_Id
;
24710 Constit_Id
: Entity_Id
;
24711 Has_Missing
: Boolean := False;
24712 In_Out_Seen
: Boolean := False;
24713 Input_Seen
: Boolean := False;
24714 Output_Seen
: Boolean := False;
24715 Proof_In_Seen
: Boolean := False;
24718 -- Process all the constituents of the state and note their modes
24719 -- within the global refinement.
24721 if Present
(Constits
) then
24722 Constit_Elmt
:= First_Elmt
(Constits
);
24723 while Present
(Constit_Elmt
) loop
24724 Constit_Id
:= Node
(Constit_Elmt
);
24726 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24727 Input_Seen
:= True;
24729 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
24730 In_Out_Seen
:= True;
24732 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24733 Output_Seen
:= True;
24735 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24737 Proof_In_Seen
:= True;
24740 Has_Missing
:= True;
24743 Next_Elmt
(Constit_Elmt
);
24747 -- An In_Out constituent is a valid completion
24749 if In_Out_Seen
then
24752 -- A pair of one Input/Proof_In and one Output constituent is a
24753 -- valid completion.
24755 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
24758 elsif Output_Seen
then
24760 -- A single Output constituent is a valid completion only when
24761 -- some of the other constituents are missing.
24763 if Has_Missing
then
24766 -- Otherwise all constituents are of mode Output
24770 ("global refinement of state & must include at least one "
24771 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24775 -- The state lacks a completion. When full refinement is visible,
24776 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
24777 -- refinement is visible, emit an error if the abstract state
24778 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
24779 -- both are utilized, Check_State_And_Constituent_Use. will issue
24782 elsif not Input_Seen
24783 and then not In_Out_Seen
24784 and then not Output_Seen
24785 and then not Proof_In_Seen
24787 if Has_Visible_Refinement
(State_Id
)
24788 or else Contains
(Repeat_Items
, State_Id
)
24791 ("missing global refinement of state &", N
, State_Id
);
24794 -- Otherwise the state has a malformed completion where at least
24795 -- one of the constituents has a different mode.
24799 ("global refinement of state & redefines the mode of its "
24800 & "constituents", N
, State_Id
);
24802 end Check_Constituent_Usage
;
24806 Item_Elmt
: Elmt_Id
;
24807 Item_Id
: Entity_Id
;
24809 -- Start of processing for Check_In_Out_States
24812 -- Do not perform this check in an instance because it was already
24813 -- performed successfully in the generic template.
24815 if Is_Generic_Instance
(Spec_Id
) then
24818 -- Inspect the In_Out items of the corresponding Global pragma
24819 -- looking for a state with a visible refinement.
24821 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
24822 Item_Elmt
:= First_Elmt
(In_Out_Items
);
24823 while Present
(Item_Elmt
) loop
24824 Item_Id
:= Node
(Item_Elmt
);
24826 -- Ensure that one of the three coverage variants is satisfied
24828 if Ekind
(Item_Id
) = E_Abstract_State
24829 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24831 Check_Constituent_Usage
(Item_Id
);
24834 Next_Elmt
(Item_Elmt
);
24837 end Check_In_Out_States
;
24839 ------------------------
24840 -- Check_Input_States --
24841 ------------------------
24843 procedure Check_Input_States
is
24844 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24845 -- Determine whether at least one constituent of state State_Id with
24846 -- full or partial visible refinement is used and has mode Input.
24847 -- Ensure that the remaining constituents do not have In_Out or
24848 -- Output modes. Emit an error if this is not the case
24849 -- (SPARK RM 7.2.4(5)).
24851 -----------------------------
24852 -- Check_Constituent_Usage --
24853 -----------------------------
24855 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24856 Constits
: constant Elist_Id
:=
24857 Partial_Refinement_Constituents
(State_Id
);
24858 Constit_Elmt
: Elmt_Id
;
24859 Constit_Id
: Entity_Id
;
24860 In_Seen
: Boolean := False;
24863 if Present
(Constits
) then
24864 Constit_Elmt
:= First_Elmt
(Constits
);
24865 while Present
(Constit_Elmt
) loop
24866 Constit_Id
:= Node
(Constit_Elmt
);
24868 -- At least one of the constituents appears as an Input
24870 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24873 -- A Proof_In constituent can refine an Input state as long
24874 -- as there is at least one Input constituent present.
24876 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24880 -- The constituent appears in the global refinement, but has
24881 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
24883 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24884 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
24886 Error_Msg_Name_1
:= Chars
(State_Id
);
24888 ("constituent & of state % must have mode `Input` in "
24889 & "global refinement", N
, Constit_Id
);
24892 Next_Elmt
(Constit_Elmt
);
24896 -- Not one of the constituents appeared as Input. Always emit an
24897 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
24898 -- When only partial refinement is visible, emit an error if the
24899 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
24900 -- the case where both are utilized, an error will be issued in
24901 -- Check_State_And_Constituent_Use.
24904 and then (Has_Visible_Refinement
(State_Id
)
24905 or else Contains
(Repeat_Items
, State_Id
))
24908 ("global refinement of state & must include at least one "
24909 & "constituent of mode `Input`", N
, State_Id
);
24911 end Check_Constituent_Usage
;
24915 Item_Elmt
: Elmt_Id
;
24916 Item_Id
: Entity_Id
;
24918 -- Start of processing for Check_Input_States
24921 -- Do not perform this check in an instance because it was already
24922 -- performed successfully in the generic template.
24924 if Is_Generic_Instance
(Spec_Id
) then
24927 -- Inspect the Input items of the corresponding Global pragma looking
24928 -- for a state with a visible refinement.
24930 elsif Has_In_State
and then Present
(In_Items
) then
24931 Item_Elmt
:= First_Elmt
(In_Items
);
24932 while Present
(Item_Elmt
) loop
24933 Item_Id
:= Node
(Item_Elmt
);
24935 -- When full refinement is visible, ensure that at least one of
24936 -- the constituents is utilized and is of mode Input. When only
24937 -- partial refinement is visible, ensure that either one of
24938 -- the constituents is utilized and is of mode Input, or the
24939 -- abstract state is repeated and no constituent is utilized.
24941 if Ekind
(Item_Id
) = E_Abstract_State
24942 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
24944 Check_Constituent_Usage
(Item_Id
);
24947 Next_Elmt
(Item_Elmt
);
24950 end Check_Input_States
;
24952 -------------------------
24953 -- Check_Output_States --
24954 -------------------------
24956 procedure Check_Output_States
is
24957 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24958 -- Determine whether all constituents of state State_Id with full
24959 -- visible refinement are used and have mode Output. Emit an error
24960 -- if this is not the case (SPARK RM 7.2.4(5)).
24962 -----------------------------
24963 -- Check_Constituent_Usage --
24964 -----------------------------
24966 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24967 Constits
: constant Elist_Id
:=
24968 Partial_Refinement_Constituents
(State_Id
);
24969 Only_Partial
: constant Boolean :=
24970 not Has_Visible_Refinement
(State_Id
);
24971 Constit_Elmt
: Elmt_Id
;
24972 Constit_Id
: Entity_Id
;
24973 Posted
: Boolean := False;
24976 if Present
(Constits
) then
24977 Constit_Elmt
:= First_Elmt
(Constits
);
24978 while Present
(Constit_Elmt
) loop
24979 Constit_Id
:= Node
(Constit_Elmt
);
24981 -- Issue an error when a constituent of State_Id is utilized
24982 -- and State_Id has only partial visible refinement
24983 -- (SPARK RM 7.2.4(3d)).
24985 if Only_Partial
then
24986 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
24987 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
24989 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
24991 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24993 Error_Msg_Name_1
:= Chars
(State_Id
);
24995 ("constituent & of state % cannot be used in global "
24996 & "refinement", N
, Constit_Id
);
24997 Error_Msg_Name_1
:= Chars
(State_Id
);
24998 SPARK_Msg_N
("\use state % instead", N
);
25001 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25004 -- The constituent appears in the global refinement, but has
25005 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25007 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25008 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25009 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25011 Error_Msg_Name_1
:= Chars
(State_Id
);
25013 ("constituent & of state % must have mode `Output` in "
25014 & "global refinement", N
, Constit_Id
);
25016 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25022 ("`Output` state & must be replaced by all its "
25023 & "constituents in global refinement", N
, State_Id
);
25027 ("\constituent & is missing in output list",
25031 Next_Elmt
(Constit_Elmt
);
25034 end Check_Constituent_Usage
;
25038 Item_Elmt
: Elmt_Id
;
25039 Item_Id
: Entity_Id
;
25041 -- Start of processing for Check_Output_States
25044 -- Do not perform this check in an instance because it was already
25045 -- performed successfully in the generic template.
25047 if Is_Generic_Instance
(Spec_Id
) then
25050 -- Inspect the Output items of the corresponding Global pragma
25051 -- looking for a state with a visible refinement.
25053 elsif Has_Out_State
and then Present
(Out_Items
) then
25054 Item_Elmt
:= First_Elmt
(Out_Items
);
25055 while Present
(Item_Elmt
) loop
25056 Item_Id
:= Node
(Item_Elmt
);
25058 -- When full refinement is visible, ensure that all of the
25059 -- constituents are utilized and they have mode Output. When
25060 -- only partial refinement is visible, ensure that no
25061 -- constituent is utilized.
25063 if Ekind
(Item_Id
) = E_Abstract_State
25064 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25066 Check_Constituent_Usage
(Item_Id
);
25069 Next_Elmt
(Item_Elmt
);
25072 end Check_Output_States
;
25074 ---------------------------
25075 -- Check_Proof_In_States --
25076 ---------------------------
25078 procedure Check_Proof_In_States
is
25079 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25080 -- Determine whether at least one constituent of state State_Id with
25081 -- full or partial visible refinement is used and has mode Proof_In.
25082 -- Ensure that the remaining constituents do not have Input, In_Out,
25083 -- or Output modes. Emit an error if this is not the case
25084 -- (SPARK RM 7.2.4(5)).
25086 -----------------------------
25087 -- Check_Constituent_Usage --
25088 -----------------------------
25090 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25091 Constits
: constant Elist_Id
:=
25092 Partial_Refinement_Constituents
(State_Id
);
25093 Constit_Elmt
: Elmt_Id
;
25094 Constit_Id
: Entity_Id
;
25095 Proof_In_Seen
: Boolean := False;
25098 if Present
(Constits
) then
25099 Constit_Elmt
:= First_Elmt
(Constits
);
25100 while Present
(Constit_Elmt
) loop
25101 Constit_Id
:= Node
(Constit_Elmt
);
25103 -- At least one of the constituents appears as Proof_In
25105 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
25106 Proof_In_Seen
:= True;
25108 -- The constituent appears in the global refinement, but has
25109 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25111 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25112 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25113 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25115 Error_Msg_Name_1
:= Chars
(State_Id
);
25117 ("constituent & of state % must have mode `Proof_In` "
25118 & "in global refinement", N
, Constit_Id
);
25121 Next_Elmt
(Constit_Elmt
);
25125 -- Not one of the constituents appeared as Proof_In. Always emit
25126 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25127 -- When only partial refinement is visible, emit an error if the
25128 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25129 -- the case where both are utilized, an error will be issued by
25130 -- Check_State_And_Constituent_Use.
25132 if not Proof_In_Seen
25133 and then (Has_Visible_Refinement
(State_Id
)
25134 or else Contains
(Repeat_Items
, State_Id
))
25137 ("global refinement of state & must include at least one "
25138 & "constituent of mode `Proof_In`", N
, State_Id
);
25140 end Check_Constituent_Usage
;
25144 Item_Elmt
: Elmt_Id
;
25145 Item_Id
: Entity_Id
;
25147 -- Start of processing for Check_Proof_In_States
25150 -- Do not perform this check in an instance because it was already
25151 -- performed successfully in the generic template.
25153 if Is_Generic_Instance
(Spec_Id
) then
25156 -- Inspect the Proof_In items of the corresponding Global pragma
25157 -- looking for a state with a visible refinement.
25159 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
25160 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
25161 while Present
(Item_Elmt
) loop
25162 Item_Id
:= Node
(Item_Elmt
);
25164 -- Ensure that at least one of the constituents is utilized
25165 -- and is of mode Proof_In. When only partial refinement is
25166 -- visible, ensure that either one of the constituents is
25167 -- utilized and is of mode Proof_In, or the abstract state
25168 -- is repeated and no constituent is utilized.
25170 if Ekind
(Item_Id
) = E_Abstract_State
25171 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25173 Check_Constituent_Usage
(Item_Id
);
25176 Next_Elmt
(Item_Elmt
);
25179 end Check_Proof_In_States
;
25181 -------------------------------
25182 -- Check_Refined_Global_List --
25183 -------------------------------
25185 procedure Check_Refined_Global_List
25187 Global_Mode
: Name_Id
:= Name_Input
)
25189 procedure Check_Refined_Global_Item
25191 Global_Mode
: Name_Id
);
25192 -- Verify the legality of a single global item declaration. Parameter
25193 -- Global_Mode denotes the current mode in effect.
25195 -------------------------------
25196 -- Check_Refined_Global_Item --
25197 -------------------------------
25199 procedure Check_Refined_Global_Item
25201 Global_Mode
: Name_Id
)
25203 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
25205 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
25206 -- Issue a common error message for all mode mismatches. Expect
25207 -- denotes the expected mode.
25209 -----------------------------
25210 -- Inconsistent_Mode_Error --
25211 -----------------------------
25213 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
25216 ("global item & has inconsistent modes", Item
, Item_Id
);
25218 Error_Msg_Name_1
:= Global_Mode
;
25219 Error_Msg_Name_2
:= Expect
;
25220 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
25221 end Inconsistent_Mode_Error
;
25225 Enc_State
: Entity_Id
:= Empty
;
25226 -- Encapsulating state for constituent, Empty otherwise
25228 -- Start of processing for Check_Refined_Global_Item
25231 if Ekind_In
(Item_Id
, E_Abstract_State
,
25235 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
25238 -- When the state or object acts as a constituent of another
25239 -- state with a visible refinement, collect it for the state
25240 -- completeness checks performed later on. Note that the item
25241 -- acts as a constituent only when the encapsulating state is
25242 -- present in pragma Global.
25244 if Present
(Enc_State
)
25245 and then (Has_Visible_Refinement
(Enc_State
)
25246 or else Has_Partial_Visible_Refinement
(Enc_State
))
25247 and then Contains
(States
, Enc_State
)
25249 -- If the state has only partial visible refinement, remove it
25250 -- from the list of items that should be repeated from pragma
25253 if not Has_Visible_Refinement
(Enc_State
) then
25254 Present_Then_Remove
(Repeat_Items
, Enc_State
);
25257 if Global_Mode
= Name_Input
then
25258 Append_New_Elmt
(Item_Id
, In_Constits
);
25260 elsif Global_Mode
= Name_In_Out
then
25261 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
25263 elsif Global_Mode
= Name_Output
then
25264 Append_New_Elmt
(Item_Id
, Out_Constits
);
25266 elsif Global_Mode
= Name_Proof_In
then
25267 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
25270 -- When not a constituent, ensure that both occurrences of the
25271 -- item in pragmas Global and Refined_Global match. Also remove
25272 -- it when present from the list of items that should be repeated
25273 -- from pragma Global.
25276 Present_Then_Remove
(Repeat_Items
, Item_Id
);
25278 if Contains
(In_Items
, Item_Id
) then
25279 if Global_Mode
/= Name_Input
then
25280 Inconsistent_Mode_Error
(Name_Input
);
25283 elsif Contains
(In_Out_Items
, Item_Id
) then
25284 if Global_Mode
/= Name_In_Out
then
25285 Inconsistent_Mode_Error
(Name_In_Out
);
25288 elsif Contains
(Out_Items
, Item_Id
) then
25289 if Global_Mode
/= Name_Output
then
25290 Inconsistent_Mode_Error
(Name_Output
);
25293 elsif Contains
(Proof_In_Items
, Item_Id
) then
25296 -- The item does not appear in the corresponding Global pragma,
25297 -- it must be an extra (SPARK RM 7.2.4(3)).
25300 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
25303 end Check_Refined_Global_Item
;
25309 -- Start of processing for Check_Refined_Global_List
25312 -- Do not perform this check in an instance because it was already
25313 -- performed successfully in the generic template.
25315 if Is_Generic_Instance
(Spec_Id
) then
25318 elsif Nkind
(List
) = N_Null
then
25321 -- Single global item declaration
25323 elsif Nkind_In
(List
, N_Expanded_Name
,
25325 N_Selected_Component
)
25327 Check_Refined_Global_Item
(List
, Global_Mode
);
25329 -- Simple global list or moded global list declaration
25331 elsif Nkind
(List
) = N_Aggregate
then
25333 -- The declaration of a simple global list appear as a collection
25336 if Present
(Expressions
(List
)) then
25337 Item
:= First
(Expressions
(List
));
25338 while Present
(Item
) loop
25339 Check_Refined_Global_Item
(Item
, Global_Mode
);
25343 -- The declaration of a moded global list appears as a collection
25344 -- of component associations where individual choices denote
25347 elsif Present
(Component_Associations
(List
)) then
25348 Item
:= First
(Component_Associations
(List
));
25349 while Present
(Item
) loop
25350 Check_Refined_Global_List
25351 (List
=> Expression
(Item
),
25352 Global_Mode
=> Chars
(First
(Choices
(Item
))));
25360 raise Program_Error
;
25366 raise Program_Error
;
25368 end Check_Refined_Global_List
;
25370 --------------------------
25371 -- Collect_Global_Items --
25372 --------------------------
25374 procedure Collect_Global_Items
25376 Mode
: Name_Id
:= Name_Input
)
25378 procedure Collect_Global_Item
25380 Item_Mode
: Name_Id
);
25381 -- Add a single item to the appropriate list. Item_Mode denotes the
25382 -- current mode in effect.
25384 -------------------------
25385 -- Collect_Global_Item --
25386 -------------------------
25388 procedure Collect_Global_Item
25390 Item_Mode
: Name_Id
)
25392 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
25393 -- The above handles abstract views of variables and states built
25394 -- for limited with clauses.
25397 -- Signal that the global list contains at least one abstract
25398 -- state with a visible refinement. Note that the refinement may
25399 -- be null in which case there are no constituents.
25401 if Ekind
(Item_Id
) = E_Abstract_State
then
25402 if Has_Null_Visible_Refinement
(Item_Id
) then
25403 Has_Null_State
:= True;
25405 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25406 Append_New_Elmt
(Item_Id
, States
);
25408 if Item_Mode
= Name_Input
then
25409 Has_In_State
:= True;
25410 elsif Item_Mode
= Name_In_Out
then
25411 Has_In_Out_State
:= True;
25412 elsif Item_Mode
= Name_Output
then
25413 Has_Out_State
:= True;
25414 elsif Item_Mode
= Name_Proof_In
then
25415 Has_Proof_In_State
:= True;
25420 -- Record global items without full visible refinement found in
25421 -- pragma Global which should be repeated in the global refinement
25422 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
25424 if Ekind
(Item_Id
) /= E_Abstract_State
25425 or else not Has_Visible_Refinement
(Item_Id
)
25427 Append_New_Elmt
(Item_Id
, Repeat_Items
);
25430 -- Add the item to the proper list
25432 if Item_Mode
= Name_Input
then
25433 Append_New_Elmt
(Item_Id
, In_Items
);
25434 elsif Item_Mode
= Name_In_Out
then
25435 Append_New_Elmt
(Item_Id
, In_Out_Items
);
25436 elsif Item_Mode
= Name_Output
then
25437 Append_New_Elmt
(Item_Id
, Out_Items
);
25438 elsif Item_Mode
= Name_Proof_In
then
25439 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
25441 end Collect_Global_Item
;
25447 -- Start of processing for Collect_Global_Items
25450 if Nkind
(List
) = N_Null
then
25453 -- Single global item declaration
25455 elsif Nkind_In
(List
, N_Expanded_Name
,
25457 N_Selected_Component
)
25459 Collect_Global_Item
(List
, Mode
);
25461 -- Single global list or moded global list declaration
25463 elsif Nkind
(List
) = N_Aggregate
then
25465 -- The declaration of a simple global list appear as a collection
25468 if Present
(Expressions
(List
)) then
25469 Item
:= First
(Expressions
(List
));
25470 while Present
(Item
) loop
25471 Collect_Global_Item
(Item
, Mode
);
25475 -- The declaration of a moded global list appears as a collection
25476 -- of component associations where individual choices denote mode.
25478 elsif Present
(Component_Associations
(List
)) then
25479 Item
:= First
(Component_Associations
(List
));
25480 while Present
(Item
) loop
25481 Collect_Global_Items
25482 (List
=> Expression
(Item
),
25483 Mode
=> Chars
(First
(Choices
(Item
))));
25491 raise Program_Error
;
25494 -- To accomodate partial decoration of disabled SPARK features, this
25495 -- routine may be called with illegal input. If this is the case, do
25496 -- not raise Program_Error.
25501 end Collect_Global_Items
;
25503 -------------------------
25504 -- Present_Then_Remove --
25505 -------------------------
25507 function Present_Then_Remove
25509 Item
: Entity_Id
) return Boolean
25514 if Present
(List
) then
25515 Elmt
:= First_Elmt
(List
);
25516 while Present
(Elmt
) loop
25517 if Node
(Elmt
) = Item
then
25518 Remove_Elmt
(List
, Elmt
);
25527 end Present_Then_Remove
;
25529 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
25532 Ignore
:= Present_Then_Remove
(List
, Item
);
25533 end Present_Then_Remove
;
25535 -------------------------------
25536 -- Report_Extra_Constituents --
25537 -------------------------------
25539 procedure Report_Extra_Constituents
is
25540 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
25541 -- Emit an error for every element of List
25543 ---------------------------------------
25544 -- Report_Extra_Constituents_In_List --
25545 ---------------------------------------
25547 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
25548 Constit_Elmt
: Elmt_Id
;
25551 if Present
(List
) then
25552 Constit_Elmt
:= First_Elmt
(List
);
25553 while Present
(Constit_Elmt
) loop
25554 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
25555 Next_Elmt
(Constit_Elmt
);
25558 end Report_Extra_Constituents_In_List
;
25560 -- Start of processing for Report_Extra_Constituents
25563 -- Do not perform this check in an instance because it was already
25564 -- performed successfully in the generic template.
25566 if Is_Generic_Instance
(Spec_Id
) then
25570 Report_Extra_Constituents_In_List
(In_Constits
);
25571 Report_Extra_Constituents_In_List
(In_Out_Constits
);
25572 Report_Extra_Constituents_In_List
(Out_Constits
);
25573 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
25575 end Report_Extra_Constituents
;
25577 --------------------------
25578 -- Report_Missing_Items --
25579 --------------------------
25581 procedure Report_Missing_Items
is
25582 Item_Elmt
: Elmt_Id
;
25583 Item_Id
: Entity_Id
;
25586 -- Do not perform this check in an instance because it was already
25587 -- performed successfully in the generic template.
25589 if Is_Generic_Instance
(Spec_Id
) then
25593 if Present
(Repeat_Items
) then
25594 Item_Elmt
:= First_Elmt
(Repeat_Items
);
25595 while Present
(Item_Elmt
) loop
25596 Item_Id
:= Node
(Item_Elmt
);
25597 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
25598 Next_Elmt
(Item_Elmt
);
25602 end Report_Missing_Items
;
25606 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25607 Errors
: constant Nat
:= Serious_Errors_Detected
;
25609 No_Constit
: Boolean;
25611 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25614 -- Do not analyze the pragma multiple times
25616 if Is_Analyzed_Pragma
(N
) then
25620 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25622 -- Use the anonymous object as the proper spec when Refined_Global
25623 -- applies to the body of a single task type. The object carries the
25624 -- proper Chars as well as all non-refined versions of pragmas.
25626 if Is_Single_Concurrent_Type
(Spec_Id
) then
25627 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25630 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25631 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
25633 -- The subprogram declaration lacks pragma Global. This renders
25634 -- Refined_Global useless as there is nothing to refine.
25636 if No
(Global
) then
25638 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25639 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
25643 -- Extract all relevant items from the corresponding Global pragma
25645 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
25647 -- Package and subprogram bodies are instantiated individually in
25648 -- a separate compiler pass. Due to this mode of instantiation, the
25649 -- refinement of a state may no longer be visible when a subprogram
25650 -- body contract is instantiated. Since the generic template is legal,
25651 -- do not perform this check in the instance to circumvent this oddity.
25653 if Is_Generic_Instance
(Spec_Id
) then
25656 -- Non-instance case
25659 -- The corresponding Global pragma must mention at least one
25660 -- state with a visible refinement at the point Refined_Global
25661 -- is processed. States with null refinements need Refined_Global
25662 -- pragma (SPARK RM 7.2.4(2)).
25664 if not Has_In_State
25665 and then not Has_In_Out_State
25666 and then not Has_Out_State
25667 and then not Has_Proof_In_State
25668 and then not Has_Null_State
25671 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25672 & "depend on abstract state with visible refinement"),
25676 -- The global refinement of inputs and outputs cannot be null when
25677 -- the corresponding Global pragma contains at least one item except
25678 -- in the case where we have states with null refinements.
25680 elsif Nkind
(Items
) = N_Null
25682 (Present
(In_Items
)
25683 or else Present
(In_Out_Items
)
25684 or else Present
(Out_Items
)
25685 or else Present
(Proof_In_Items
))
25686 and then not Has_Null_State
25689 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
25690 & "global items"), N
, Spec_Id
);
25695 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25696 -- This ensures that the categorization of all refined global items is
25697 -- consistent with their role.
25699 Analyze_Global_In_Decl_Part
(N
);
25701 -- Perform all refinement checks with respect to completeness and mode
25704 if Serious_Errors_Detected
= Errors
then
25705 Check_Refined_Global_List
(Items
);
25708 -- Store the information that no constituent is used in the global
25709 -- refinement, prior to calling checking procedures which remove items
25710 -- from the list of constituents.
25714 and then No
(In_Out_Constits
)
25715 and then No
(Out_Constits
)
25716 and then No
(Proof_In_Constits
);
25718 -- For Input states with visible refinement, at least one constituent
25719 -- must be used as an Input in the global refinement.
25721 if Serious_Errors_Detected
= Errors
then
25722 Check_Input_States
;
25725 -- Verify all possible completion variants for In_Out states with
25726 -- visible refinement.
25728 if Serious_Errors_Detected
= Errors
then
25729 Check_In_Out_States
;
25732 -- For Output states with visible refinement, all constituents must be
25733 -- used as Outputs in the global refinement.
25735 if Serious_Errors_Detected
= Errors
then
25736 Check_Output_States
;
25739 -- For Proof_In states with visible refinement, at least one constituent
25740 -- must be used as Proof_In in the global refinement.
25742 if Serious_Errors_Detected
= Errors
then
25743 Check_Proof_In_States
;
25746 -- Emit errors for all constituents that belong to other states with
25747 -- visible refinement that do not appear in Global.
25749 if Serious_Errors_Detected
= Errors
then
25750 Report_Extra_Constituents
;
25753 -- Emit errors for all items in Global that are not repeated in the
25754 -- global refinement and for which there is no full visible refinement
25755 -- and, in the case of states with partial visible refinement, no
25756 -- constituent is mentioned in the global refinement.
25758 if Serious_Errors_Detected
= Errors
then
25759 Report_Missing_Items
;
25762 -- Emit an error if no constituent is used in the global refinement
25763 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
25764 -- one may be issued by the checking procedures. Do not perform this
25765 -- check in an instance because it was already performed successfully
25766 -- in the generic template.
25768 if Serious_Errors_Detected
= Errors
25769 and then not Is_Generic_Instance
(Spec_Id
)
25770 and then not Has_Null_State
25771 and then No_Constit
25773 SPARK_Msg_N
("missing refinement", N
);
25777 Set_Is_Analyzed_Pragma
(N
);
25778 end Analyze_Refined_Global_In_Decl_Part
;
25780 ----------------------------------------
25781 -- Analyze_Refined_State_In_Decl_Part --
25782 ----------------------------------------
25784 procedure Analyze_Refined_State_In_Decl_Part
25786 Freeze_Id
: Entity_Id
:= Empty
)
25788 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
25789 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25790 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
25792 Available_States
: Elist_Id
:= No_Elist
;
25793 -- A list of all abstract states defined in the package declaration that
25794 -- are available for refinement. The list is used to report unrefined
25797 Body_States
: Elist_Id
:= No_Elist
;
25798 -- A list of all hidden states that appear in the body of the related
25799 -- package. The list is used to report unused hidden states.
25801 Constituents_Seen
: Elist_Id
:= No_Elist
;
25802 -- A list that contains all constituents processed so far. The list is
25803 -- used to detect multiple uses of the same constituent.
25805 Freeze_Posted
: Boolean := False;
25806 -- A flag that controls the output of a freezing-related error (see use
25809 Refined_States_Seen
: Elist_Id
:= No_Elist
;
25810 -- A list that contains all refined states processed so far. The list is
25811 -- used to detect duplicate refinements.
25813 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
25814 -- Perform full analysis of a single refinement clause
25816 procedure Report_Unrefined_States
(States
: Elist_Id
);
25817 -- Emit errors for all unrefined abstract states found in list States
25819 -------------------------------
25820 -- Analyze_Refinement_Clause --
25821 -------------------------------
25823 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
25824 AR_Constit
: Entity_Id
:= Empty
;
25825 AW_Constit
: Entity_Id
:= Empty
;
25826 ER_Constit
: Entity_Id
:= Empty
;
25827 EW_Constit
: Entity_Id
:= Empty
;
25828 -- The entities of external constituents that contain one of the
25829 -- following enabled properties: Async_Readers, Async_Writers,
25830 -- Effective_Reads and Effective_Writes.
25832 External_Constit_Seen
: Boolean := False;
25833 -- Flag used to mark when at least one external constituent is part
25834 -- of the state refinement.
25836 Non_Null_Seen
: Boolean := False;
25837 Null_Seen
: Boolean := False;
25838 -- Flags used to detect multiple uses of null in a single clause or a
25839 -- mixture of null and non-null constituents.
25841 Part_Of_Constits
: Elist_Id
:= No_Elist
;
25842 -- A list of all candidate constituents subject to indicator Part_Of
25843 -- where the encapsulating state is the current state.
25846 State_Id
: Entity_Id
;
25847 -- The current state being refined
25849 procedure Analyze_Constituent
(Constit
: Node_Id
);
25850 -- Perform full analysis of a single constituent
25852 procedure Check_External_Property
25853 (Prop_Nam
: Name_Id
;
25855 Constit
: Entity_Id
);
25856 -- Determine whether a property denoted by name Prop_Nam is present
25857 -- in the refined state. Emit an error if this is not the case. Flag
25858 -- Enabled should be set when the property applies to the refined
25859 -- state. Constit denotes the constituent (if any) which introduces
25860 -- the property in the refinement.
25862 procedure Match_State
;
25863 -- Determine whether the state being refined appears in list
25864 -- Available_States. Emit an error when attempting to re-refine the
25865 -- state or when the state is not defined in the package declaration,
25866 -- otherwise remove the state from Available_States.
25868 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
25869 -- Emit errors for all unused Part_Of constituents in list Constits
25871 -------------------------
25872 -- Analyze_Constituent --
25873 -------------------------
25875 procedure Analyze_Constituent
(Constit
: Node_Id
) is
25876 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
25877 -- Determine whether constituent Constit denoted by its entity
25878 -- Constit_Id appears in Body_States. Emit an error when the
25879 -- constituent is not a valid hidden state of the related package
25880 -- or when it is used more than once. Otherwise remove the
25881 -- constituent from Body_States.
25883 -----------------------
25884 -- Match_Constituent --
25885 -----------------------
25887 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
25888 procedure Collect_Constituent
;
25889 -- Verify the legality of constituent Constit_Id and add it to
25890 -- the refinements of State_Id.
25892 -------------------------
25893 -- Collect_Constituent --
25894 -------------------------
25896 procedure Collect_Constituent
is
25897 Constits
: Elist_Id
;
25900 -- The Ghost policy in effect at the point of abstract state
25901 -- declaration and constituent must match (SPARK RM 6.9(15))
25903 Check_Ghost_Refinement
25904 (State
, State_Id
, Constit
, Constit_Id
);
25906 -- A synchronized state must be refined by a synchronized
25907 -- object or another synchronized state (SPARK RM 9.6).
25909 if Is_Synchronized_State
(State_Id
)
25910 and then not Is_Synchronized_Object
(Constit_Id
)
25911 and then not Is_Synchronized_State
(Constit_Id
)
25914 ("constituent of synchronized state & must be "
25915 & "synchronized", Constit
, State_Id
);
25918 -- Add the constituent to the list of processed items to aid
25919 -- with the detection of duplicates.
25921 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
25923 -- Collect the constituent in the list of refinement items
25924 -- and establish a relation between the refined state and
25927 Constits
:= Refinement_Constituents
(State_Id
);
25929 if No
(Constits
) then
25930 Constits
:= New_Elmt_List
;
25931 Set_Refinement_Constituents
(State_Id
, Constits
);
25934 Append_Elmt
(Constit_Id
, Constits
);
25935 Set_Encapsulating_State
(Constit_Id
, State_Id
);
25937 -- The state has at least one legal constituent, mark the
25938 -- start of the refinement region. The region ends when the
25939 -- body declarations end (see routine Analyze_Declarations).
25941 Set_Has_Visible_Refinement
(State_Id
);
25943 -- When the constituent is external, save its relevant
25944 -- property for further checks.
25946 if Async_Readers_Enabled
(Constit_Id
) then
25947 AR_Constit
:= Constit_Id
;
25948 External_Constit_Seen
:= True;
25951 if Async_Writers_Enabled
(Constit_Id
) then
25952 AW_Constit
:= Constit_Id
;
25953 External_Constit_Seen
:= True;
25956 if Effective_Reads_Enabled
(Constit_Id
) then
25957 ER_Constit
:= Constit_Id
;
25958 External_Constit_Seen
:= True;
25961 if Effective_Writes_Enabled
(Constit_Id
) then
25962 EW_Constit
:= Constit_Id
;
25963 External_Constit_Seen
:= True;
25965 end Collect_Constituent
;
25969 State_Elmt
: Elmt_Id
;
25971 -- Start of processing for Match_Constituent
25974 -- Detect a duplicate use of a constituent
25976 if Contains
(Constituents_Seen
, Constit_Id
) then
25978 ("duplicate use of constituent &", Constit
, Constit_Id
);
25982 -- The constituent is subject to a Part_Of indicator
25984 if Present
(Encapsulating_State
(Constit_Id
)) then
25985 if Encapsulating_State
(Constit_Id
) = State_Id
then
25986 Remove
(Part_Of_Constits
, Constit_Id
);
25987 Collect_Constituent
;
25989 -- The constituent is part of another state and is used
25990 -- incorrectly in the refinement of the current state.
25993 Error_Msg_Name_1
:= Chars
(State_Id
);
25995 ("& cannot act as constituent of state %",
25996 Constit
, Constit_Id
);
25998 ("\Part_Of indicator specifies encapsulator &",
25999 Constit
, Encapsulating_State
(Constit_Id
));
26002 -- The only other source of legal constituents is the body
26003 -- state space of the related package.
26006 if Present
(Body_States
) then
26007 State_Elmt
:= First_Elmt
(Body_States
);
26008 while Present
(State_Elmt
) loop
26010 -- Consume a valid constituent to signal that it has
26011 -- been encountered.
26013 if Node
(State_Elmt
) = Constit_Id
then
26014 Remove_Elmt
(Body_States
, State_Elmt
);
26015 Collect_Constituent
;
26019 Next_Elmt
(State_Elmt
);
26023 -- Constants are part of the hidden state of a package, but
26024 -- the compiler cannot determine whether they have variable
26025 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26026 -- hidden state. Accept the constant quietly even if it is
26027 -- a visible state or lacks a Part_Of indicator.
26029 if Ekind
(Constit_Id
) = E_Constant
then
26030 Collect_Constituent
;
26032 -- If we get here, then the constituent is not a hidden
26033 -- state of the related package and may not be used in a
26034 -- refinement (SPARK RM 7.2.2(9)).
26037 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26039 ("cannot use & in refinement, constituent is not a "
26040 & "hidden state of package %", Constit
, Constit_Id
);
26043 end Match_Constituent
;
26047 Constit_Id
: Entity_Id
;
26048 Constits
: Elist_Id
;
26050 -- Start of processing for Analyze_Constituent
26053 -- Detect multiple uses of null in a single refinement clause or a
26054 -- mixture of null and non-null constituents.
26056 if Nkind
(Constit
) = N_Null
then
26059 ("multiple null constituents not allowed", Constit
);
26061 elsif Non_Null_Seen
then
26063 ("cannot mix null and non-null constituents", Constit
);
26068 -- Collect the constituent in the list of refinement items
26070 Constits
:= Refinement_Constituents
(State_Id
);
26072 if No
(Constits
) then
26073 Constits
:= New_Elmt_List
;
26074 Set_Refinement_Constituents
(State_Id
, Constits
);
26077 Append_Elmt
(Constit
, Constits
);
26079 -- The state has at least one legal constituent, mark the
26080 -- start of the refinement region. The region ends when the
26081 -- body declarations end (see Analyze_Declarations).
26083 Set_Has_Visible_Refinement
(State_Id
);
26086 -- Non-null constituents
26089 Non_Null_Seen
:= True;
26093 ("cannot mix null and non-null constituents", Constit
);
26097 Resolve_State
(Constit
);
26099 -- Ensure that the constituent denotes a valid state or a
26100 -- whole object (SPARK RM 7.2.2(5)).
26102 if Is_Entity_Name
(Constit
) then
26103 Constit_Id
:= Entity_Of
(Constit
);
26105 -- When a constituent is declared after a subprogram body
26106 -- that caused "freezing" of the related contract where
26107 -- pragma Refined_State resides, the constituent appears
26108 -- undefined and carries Any_Id as its entity.
26110 -- package body Pack
26111 -- with Refined_State => (State => Constit)
26114 -- with Refined_Global => (Input => Constit)
26122 if Constit_Id
= Any_Id
then
26123 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
26125 -- Emit a specialized info message when the contract of
26126 -- the related package body was "frozen" by another body.
26127 -- Note that it is not possible to precisely identify why
26128 -- the constituent is undefined because it is not visible
26129 -- when pragma Refined_State is analyzed. This message is
26130 -- a reasonable approximation.
26132 if Present
(Freeze_Id
) and then not Freeze_Posted
then
26133 Freeze_Posted
:= True;
26135 Error_Msg_Name_1
:= Chars
(Body_Id
);
26136 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
26138 ("body & declared # freezes the contract of %",
26141 ("\all constituents must be declared before body #",
26144 -- A misplaced constituent is a critical error because
26145 -- pragma Refined_Depends or Refined_Global depends on
26146 -- the proper link between a state and a constituent.
26147 -- Stop the compilation, as this leads to a multitude
26148 -- of misleading cascaded errors.
26150 raise Program_Error
;
26153 -- The constituent is a valid state or object
26155 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
26159 Match_Constituent
(Constit_Id
);
26161 -- The variable may eventually become a constituent of a
26162 -- single protected/task type. Record the reference now
26163 -- and verify its legality when analyzing the contract of
26164 -- the variable (SPARK RM 9.3).
26166 if Ekind
(Constit_Id
) = E_Variable
then
26167 Record_Possible_Part_Of_Reference
26168 (Var_Id
=> Constit_Id
,
26172 -- Otherwise the constituent is illegal
26176 ("constituent & must denote object or state",
26177 Constit
, Constit_Id
);
26180 -- The constituent is illegal
26183 SPARK_Msg_N
("malformed constituent", Constit
);
26186 end Analyze_Constituent
;
26188 -----------------------------
26189 -- Check_External_Property --
26190 -----------------------------
26192 procedure Check_External_Property
26193 (Prop_Nam
: Name_Id
;
26195 Constit
: Entity_Id
)
26198 -- The property is missing in the declaration of the state, but
26199 -- a constituent is introducing it in the state refinement
26200 -- (SPARK RM 7.2.8(2)).
26202 if not Enabled
and then Present
(Constit
) then
26203 Error_Msg_Name_1
:= Prop_Nam
;
26204 Error_Msg_Name_2
:= Chars
(State_Id
);
26206 ("constituent & introduces external property % in refinement "
26207 & "of state %", State
, Constit
);
26209 Error_Msg_Sloc
:= Sloc
(State_Id
);
26211 ("\property is missing in abstract state declaration #",
26214 end Check_External_Property
;
26220 procedure Match_State
is
26221 State_Elmt
: Elmt_Id
;
26224 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
26226 if Contains
(Refined_States_Seen
, State_Id
) then
26228 ("duplicate refinement of state &", State
, State_Id
);
26232 -- Inspect the abstract states defined in the package declaration
26233 -- looking for a match.
26235 State_Elmt
:= First_Elmt
(Available_States
);
26236 while Present
(State_Elmt
) loop
26238 -- A valid abstract state is being refined in the body. Add
26239 -- the state to the list of processed refined states to aid
26240 -- with the detection of duplicate refinements. Remove the
26241 -- state from Available_States to signal that it has already
26244 if Node
(State_Elmt
) = State_Id
then
26245 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
26246 Remove_Elmt
(Available_States
, State_Elmt
);
26250 Next_Elmt
(State_Elmt
);
26253 -- If we get here, we are refining a state that is not defined in
26254 -- the package declaration.
26256 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26258 ("cannot refine state, & is not defined in package %",
26262 --------------------------------
26263 -- Report_Unused_Constituents --
26264 --------------------------------
26266 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
26267 Constit_Elmt
: Elmt_Id
;
26268 Constit_Id
: Entity_Id
;
26269 Posted
: Boolean := False;
26272 if Present
(Constits
) then
26273 Constit_Elmt
:= First_Elmt
(Constits
);
26274 while Present
(Constit_Elmt
) loop
26275 Constit_Id
:= Node
(Constit_Elmt
);
26277 -- Generate an error message of the form:
26279 -- state ... has unused Part_Of constituents
26280 -- abstract state ... defined at ...
26281 -- constant ... defined at ...
26282 -- variable ... defined at ...
26287 ("state & has unused Part_Of constituents",
26291 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
26293 if Ekind
(Constit_Id
) = E_Abstract_State
then
26295 ("\abstract state & defined #", State
, Constit_Id
);
26297 elsif Ekind
(Constit_Id
) = E_Constant
then
26299 ("\constant & defined #", State
, Constit_Id
);
26302 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
26303 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
26306 Next_Elmt
(Constit_Elmt
);
26309 end Report_Unused_Constituents
;
26311 -- Local declarations
26313 Body_Ref
: Node_Id
;
26314 Body_Ref_Elmt
: Elmt_Id
;
26316 Extra_State
: Node_Id
;
26318 -- Start of processing for Analyze_Refinement_Clause
26321 -- A refinement clause appears as a component association where the
26322 -- sole choice is the state and the expressions are the constituents.
26323 -- This is a syntax error, always report.
26325 if Nkind
(Clause
) /= N_Component_Association
then
26326 Error_Msg_N
("malformed state refinement clause", Clause
);
26330 -- Analyze the state name of a refinement clause
26332 State
:= First
(Choices
(Clause
));
26335 Resolve_State
(State
);
26337 -- Ensure that the state name denotes a valid abstract state that is
26338 -- defined in the spec of the related package.
26340 if Is_Entity_Name
(State
) then
26341 State_Id
:= Entity_Of
(State
);
26343 -- When the abstract state is undefined, it appears as Any_Id. Do
26344 -- not continue with the analysis of the clause.
26346 if State_Id
= Any_Id
then
26349 -- Catch any attempts to re-refine a state or refine a state that
26350 -- is not defined in the package declaration.
26352 elsif Ekind
(State_Id
) = E_Abstract_State
then
26356 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
26360 -- References to a state with visible refinement are illegal.
26361 -- When nested packages are involved, detecting such references is
26362 -- tricky because pragma Refined_State is analyzed later than the
26363 -- offending pragma Depends or Global. References that occur in
26364 -- such nested context are stored in a list. Emit errors for all
26365 -- references found in Body_References (SPARK RM 6.1.4(8)).
26367 if Present
(Body_References
(State_Id
)) then
26368 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
26369 while Present
(Body_Ref_Elmt
) loop
26370 Body_Ref
:= Node
(Body_Ref_Elmt
);
26372 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
26373 Error_Msg_Sloc
:= Sloc
(State
);
26374 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
26376 Next_Elmt
(Body_Ref_Elmt
);
26380 -- The state name is illegal. This is a syntax error, always report.
26383 Error_Msg_N
("malformed state name in refinement clause", State
);
26387 -- A refinement clause may only refine one state at a time
26389 Extra_State
:= Next
(State
);
26391 if Present
(Extra_State
) then
26393 ("refinement clause cannot cover multiple states", Extra_State
);
26396 -- Replicate the Part_Of constituents of the refined state because
26397 -- the algorithm will consume items.
26399 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
26401 -- Analyze all constituents of the refinement. Multiple constituents
26402 -- appear as an aggregate.
26404 Constit
:= Expression
(Clause
);
26406 if Nkind
(Constit
) = N_Aggregate
then
26407 if Present
(Component_Associations
(Constit
)) then
26409 ("constituents of refinement clause must appear in "
26410 & "positional form", Constit
);
26412 else pragma Assert
(Present
(Expressions
(Constit
)));
26413 Constit
:= First
(Expressions
(Constit
));
26414 while Present
(Constit
) loop
26415 Analyze_Constituent
(Constit
);
26420 -- Various forms of a single constituent. Note that these may include
26421 -- malformed constituents.
26424 Analyze_Constituent
(Constit
);
26427 -- Verify that external constituents do not introduce new external
26428 -- property in the state refinement (SPARK RM 7.2.8(2)).
26430 if Is_External_State
(State_Id
) then
26431 Check_External_Property
26432 (Prop_Nam
=> Name_Async_Readers
,
26433 Enabled
=> Async_Readers_Enabled
(State_Id
),
26434 Constit
=> AR_Constit
);
26436 Check_External_Property
26437 (Prop_Nam
=> Name_Async_Writers
,
26438 Enabled
=> Async_Writers_Enabled
(State_Id
),
26439 Constit
=> AW_Constit
);
26441 Check_External_Property
26442 (Prop_Nam
=> Name_Effective_Reads
,
26443 Enabled
=> Effective_Reads_Enabled
(State_Id
),
26444 Constit
=> ER_Constit
);
26446 Check_External_Property
26447 (Prop_Nam
=> Name_Effective_Writes
,
26448 Enabled
=> Effective_Writes_Enabled
(State_Id
),
26449 Constit
=> EW_Constit
);
26451 -- When a refined state is not external, it should not have external
26452 -- constituents (SPARK RM 7.2.8(1)).
26454 elsif External_Constit_Seen
then
26456 ("non-external state & cannot contain external constituents in "
26457 & "refinement", State
, State_Id
);
26460 -- Ensure that all Part_Of candidate constituents have been mentioned
26461 -- in the refinement clause.
26463 Report_Unused_Constituents
(Part_Of_Constits
);
26464 end Analyze_Refinement_Clause
;
26466 -----------------------------
26467 -- Report_Unrefined_States --
26468 -----------------------------
26470 procedure Report_Unrefined_States
(States
: Elist_Id
) is
26471 State_Elmt
: Elmt_Id
;
26474 if Present
(States
) then
26475 State_Elmt
:= First_Elmt
(States
);
26476 while Present
(State_Elmt
) loop
26478 ("abstract state & must be refined", Node
(State_Elmt
));
26480 Next_Elmt
(State_Elmt
);
26483 end Report_Unrefined_States
;
26485 -- Local declarations
26487 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
26490 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26493 -- Do not analyze the pragma multiple times
26495 if Is_Analyzed_Pragma
(N
) then
26499 -- Replicate the abstract states declared by the package because the
26500 -- matching algorithm will consume states.
26502 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
26504 -- Gather all abstract states and objects declared in the visible
26505 -- state space of the package body. These items must be utilized as
26506 -- constituents in a state refinement.
26508 Body_States
:= Collect_Body_States
(Body_Id
);
26510 -- Multiple non-null state refinements appear as an aggregate
26512 if Nkind
(Clauses
) = N_Aggregate
then
26513 if Present
(Expressions
(Clauses
)) then
26515 ("state refinements must appear as component associations",
26518 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
26519 Clause
:= First
(Component_Associations
(Clauses
));
26520 while Present
(Clause
) loop
26521 Analyze_Refinement_Clause
(Clause
);
26526 -- Various forms of a single state refinement. Note that these may
26527 -- include malformed refinements.
26530 Analyze_Refinement_Clause
(Clauses
);
26533 -- List all abstract states that were left unrefined
26535 Report_Unrefined_States
(Available_States
);
26537 Set_Is_Analyzed_Pragma
(N
);
26538 end Analyze_Refined_State_In_Decl_Part
;
26540 ------------------------------------
26541 -- Analyze_Test_Case_In_Decl_Part --
26542 ------------------------------------
26544 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
26545 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26546 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26548 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
26549 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26550 -- denoted by Arg_Nam.
26552 ------------------------------
26553 -- Preanalyze_Test_Case_Arg --
26554 ------------------------------
26556 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
26560 -- Preanalyze the original aspect argument for ASIS or for a generic
26561 -- subprogram to properly capture global references.
26563 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
26567 Arg_Nam
=> Arg_Nam
,
26568 From_Aspect
=> True);
26570 if Present
(Arg
) then
26571 Preanalyze_Assert_Expression
26572 (Expression
(Arg
), Standard_Boolean
);
26576 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
26578 if Present
(Arg
) then
26579 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
26581 end Preanalyze_Test_Case_Arg
;
26585 Restore_Scope
: Boolean := False;
26587 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26590 -- Do not analyze the pragma multiple times
26592 if Is_Analyzed_Pragma
(N
) then
26596 -- Ensure that the formal parameters are visible when analyzing all
26597 -- clauses. This falls out of the general rule of aspects pertaining
26598 -- to subprogram declarations.
26600 if not In_Open_Scopes
(Spec_Id
) then
26601 Restore_Scope
:= True;
26602 Push_Scope
(Spec_Id
);
26604 if Is_Generic_Subprogram
(Spec_Id
) then
26605 Install_Generic_Formals
(Spec_Id
);
26607 Install_Formals
(Spec_Id
);
26611 Preanalyze_Test_Case_Arg
(Name_Requires
);
26612 Preanalyze_Test_Case_Arg
(Name_Ensures
);
26614 if Restore_Scope
then
26618 -- Currently it is not possible to inline pre/postconditions on a
26619 -- subprogram subject to pragma Inline_Always.
26621 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
26623 Set_Is_Analyzed_Pragma
(N
);
26624 end Analyze_Test_Case_In_Decl_Part
;
26630 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
26635 if Present
(List
) then
26636 Elmt
:= First_Elmt
(List
);
26637 while Present
(Elmt
) loop
26638 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
26641 Id
:= Entity_Of
(Node
(Elmt
));
26644 if Id
= Item_Id
then
26655 ---------------------------------
26656 -- Build_Class_Wide_Expression --
26657 ---------------------------------
26659 procedure Build_Class_Wide_Expression
26662 Par_Subp
: Entity_Id
;
26663 Adjust_Sloc
: Boolean)
26665 function Replace_Entity
(N
: Node_Id
) return Traverse_Result
;
26666 -- Replace reference to formal of inherited operation or to primitive
26667 -- operation of root type, with corresponding entity for derived type,
26668 -- when constructing the class-wide condition of an overriding
26671 --------------------
26672 -- Replace_Entity --
26673 --------------------
26675 function Replace_Entity
(N
: Node_Id
) return Traverse_Result
is
26679 if Adjust_Sloc
then
26680 Adjust_Inherited_Pragma_Sloc
(N
);
26683 if Nkind
(N
) = N_Identifier
26684 and then Present
(Entity
(N
))
26686 (Is_Formal
(Entity
(N
)) or else Is_Subprogram
(Entity
(N
)))
26688 (Nkind
(Parent
(N
)) /= N_Attribute_Reference
26689 or else Attribute_Name
(Parent
(N
)) /= Name_Class
)
26691 -- The replacement does not apply to dispatching calls within the
26692 -- condition, but only to calls whose static tag is that of the
26695 if Is_Subprogram
(Entity
(N
))
26696 and then Nkind
(Parent
(N
)) = N_Function_Call
26697 and then Present
(Controlling_Argument
(Parent
(N
)))
26702 -- Determine whether entity has a renaming
26704 New_E
:= Primitives_Mapping
.Get
(Entity
(N
));
26706 if Present
(New_E
) then
26707 Rewrite
(N
, New_Occurrence_Of
(New_E
, Sloc
(N
)));
26710 -- Check that there are no calls left to abstract operations if
26711 -- the current subprogram is not abstract.
26713 if Nkind
(Parent
(N
)) = N_Function_Call
26714 and then N
= Name
(Parent
(N
))
26716 if not Is_Abstract_Subprogram
(Subp
)
26717 and then Is_Abstract_Subprogram
(Entity
(N
))
26719 Error_Msg_Sloc
:= Sloc
(Current_Scope
);
26721 ("cannot call abstract subprogram in inherited condition "
26722 & "for&#", N
, Current_Scope
);
26724 -- In SPARK mode, reject an inherited condition for an
26725 -- inherited operation if it contains a call to an overriding
26726 -- operation, because this implies that the pre/postcondition
26727 -- of the inherited operation have changed silently.
26729 elsif SPARK_Mode
= On
26730 and then Warn_On_Suspicious_Contract
26731 and then Present
(Alias
(Subp
))
26732 and then Present
(New_E
)
26733 and then Comes_From_Source
(New_E
)
26736 ("cannot modify inherited condition (SPARK RM 6.1.1(1))",
26738 Error_Msg_Sloc
:= Sloc
(New_E
);
26739 Error_Msg_Node_2
:= Subp
;
26741 ("\overriding of&# forces overriding of&",
26742 Parent
(Subp
), New_E
);
26746 -- Update type of function call node, which should be the same as
26747 -- the function's return type.
26749 if Is_Subprogram
(Entity
(N
))
26750 and then Nkind
(Parent
(N
)) = N_Function_Call
26752 Set_Etype
(Parent
(N
), Etype
(Entity
(N
)));
26755 -- The whole expression will be reanalyzed
26757 elsif Nkind
(N
) in N_Has_Etype
then
26758 Set_Analyzed
(N
, False);
26762 end Replace_Entity
;
26764 procedure Replace_Condition_Entities
is
26765 new Traverse_Proc
(Replace_Entity
);
26769 Par_Formal
: Entity_Id
;
26770 Subp_Formal
: Entity_Id
;
26772 -- Start of processing for Build_Class_Wide_Expression
26775 -- Add mapping from old formals to new formals
26777 Par_Formal
:= First_Formal
(Par_Subp
);
26778 Subp_Formal
:= First_Formal
(Subp
);
26780 while Present
(Par_Formal
) and then Present
(Subp_Formal
) loop
26781 Primitives_Mapping
.Set
(Par_Formal
, Subp_Formal
);
26782 Next_Formal
(Par_Formal
);
26783 Next_Formal
(Subp_Formal
);
26786 Replace_Condition_Entities
(Prag
);
26787 end Build_Class_Wide_Expression
;
26789 -----------------------------------
26790 -- Build_Pragma_Check_Equivalent --
26791 -----------------------------------
26793 function Build_Pragma_Check_Equivalent
26795 Subp_Id
: Entity_Id
:= Empty
;
26796 Inher_Id
: Entity_Id
:= Empty
;
26797 Keep_Pragma_Id
: Boolean := False) return Node_Id
26799 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
26800 -- Detect whether node N references a formal parameter subject to
26801 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26802 -- to False to suppress the generation of a reference when analyzing
26805 ------------------------
26806 -- Suppress_Reference --
26807 ------------------------
26809 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
26810 Formal
: Entity_Id
;
26813 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26814 Formal
:= Entity
(N
);
26816 -- The formal parameter is subject to pragma Unreferenced. Prevent
26817 -- the generation of references by resetting the Comes_From_Source
26820 if Is_Formal
(Formal
)
26821 and then Has_Pragma_Unreferenced
(Formal
)
26823 Set_Comes_From_Source
(N
, False);
26828 end Suppress_Reference
;
26830 procedure Suppress_References
is
26831 new Traverse_Proc
(Suppress_Reference
);
26835 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
26836 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
26837 Check_Prag
: Node_Id
;
26841 -- Start of processing for Build_Pragma_Check_Equivalent
26844 -- When the pre- or postcondition is inherited, map the formals of the
26845 -- inherited subprogram to those of the current subprogram. In addition,
26846 -- map primitive operations of the parent type into the corresponding
26847 -- primitive operations of the descendant.
26849 if Present
(Inher_Id
) then
26850 pragma Assert
(Present
(Subp_Id
));
26852 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
26854 -- Use generic machinery to copy inherited pragma, as if it were an
26855 -- instantiation, resetting source locations appropriately, so that
26856 -- expressions inside the inherited pragma use chained locations.
26857 -- This is used in particular in GNATprove to locate precisely
26858 -- messages on a given inherited pragma.
26860 Set_Copied_Sloc_For_Inherited_Pragma
26861 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
26862 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
26864 -- Build the inherited class-wide condition
26866 Build_Class_Wide_Expression
26867 (Check_Prag
, Subp_Id
, Inher_Id
, Adjust_Sloc
=> True);
26869 -- If not an inherited condition simply copy the original pragma
26872 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
26875 -- Mark the pragma as being internally generated and reset the Analyzed
26878 Set_Analyzed
(Check_Prag
, False);
26879 Set_Comes_From_Source
(Check_Prag
, False);
26881 -- The tree of the original pragma may contain references to the
26882 -- formal parameters of the related subprogram. At the same time
26883 -- the corresponding body may mark the formals as unreferenced:
26885 -- procedure Proc (Formal : ...)
26886 -- with Pre => Formal ...;
26888 -- procedure Proc (Formal : ...) is
26889 -- pragma Unreferenced (Formal);
26892 -- This creates problems because all pragma Check equivalents are
26893 -- analyzed at the end of the body declarations. Since all source
26894 -- references have already been accounted for, reset any references
26895 -- to such formals in the generated pragma Check equivalent.
26897 Suppress_References
(Check_Prag
);
26899 if Present
(Corresponding_Aspect
(Prag
)) then
26900 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
26905 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
26906 -- the copied pragma in the newly created pragma, convert the copy into
26907 -- pragma Check by correcting the name and adding a check_kind argument.
26909 if not Keep_Pragma_Id
then
26910 Set_Class_Present
(Check_Prag
, False);
26912 Set_Pragma_Identifier
26913 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
26915 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
26916 Make_Pragma_Argument_Association
(Loc
,
26917 Expression
=> Make_Identifier
(Loc
, Nam
)));
26920 -- Update the error message when the pragma is inherited
26922 if Present
(Inher_Id
) then
26923 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
26925 if Chars
(Msg_Arg
) = Name_Message
then
26926 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
26928 -- Insert "inherited" to improve the error message
26930 if Name_Buffer
(1 .. 8) = "failed p" then
26931 Insert_Str_In_Name_Buffer
("inherited ", 8);
26932 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
26938 end Build_Pragma_Check_Equivalent
;
26940 -----------------------------
26941 -- Check_Applicable_Policy --
26942 -----------------------------
26944 procedure Check_Applicable_Policy
(N
: Node_Id
) is
26948 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
26951 -- No effect if not valid assertion kind name
26953 if not Is_Valid_Assertion_Kind
(Ename
) then
26957 -- Loop through entries in check policy list
26959 PP
:= Opt
.Check_Policy_List
;
26960 while Present
(PP
) loop
26962 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
26963 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
26967 or else Pnm
= Name_Assertion
26968 or else (Pnm
= Name_Statement_Assertions
26969 and then Nam_In
(Ename
, Name_Assert
,
26970 Name_Assert_And_Cut
,
26972 Name_Loop_Invariant
,
26973 Name_Loop_Variant
))
26975 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
26978 when Name_Off | Name_Ignore
=>
26979 Set_Is_Ignored
(N
, True);
26980 Set_Is_Checked
(N
, False);
26982 when Name_On | Name_Check
=>
26983 Set_Is_Checked
(N
, True);
26984 Set_Is_Ignored
(N
, False);
26986 when Name_Disable
=>
26987 Set_Is_Ignored
(N
, True);
26988 Set_Is_Checked
(N
, False);
26989 Set_Is_Disabled
(N
, True);
26991 -- That should be exhaustive, the null here is a defence
26992 -- against a malformed tree from previous errors.
27001 PP
:= Next_Pragma
(PP
);
27005 -- If there are no specific entries that matched, then we let the
27006 -- setting of assertions govern. Note that this provides the needed
27007 -- compatibility with the RM for the cases of assertion, invariant,
27008 -- precondition, predicate, and postcondition.
27010 if Assertions_Enabled
then
27011 Set_Is_Checked
(N
, True);
27012 Set_Is_Ignored
(N
, False);
27014 Set_Is_Checked
(N
, False);
27015 Set_Is_Ignored
(N
, True);
27017 end Check_Applicable_Policy
;
27019 -------------------------------
27020 -- Check_External_Properties --
27021 -------------------------------
27023 procedure Check_External_Properties
27031 -- All properties enabled
27033 if AR
and AW
and ER
and EW
then
27036 -- Async_Readers + Effective_Writes
27037 -- Async_Readers + Async_Writers + Effective_Writes
27039 elsif AR
and EW
and not ER
then
27042 -- Async_Writers + Effective_Reads
27043 -- Async_Readers + Async_Writers + Effective_Reads
27045 elsif AW
and ER
and not EW
then
27048 -- Async_Readers + Async_Writers
27050 elsif AR
and AW
and not ER
and not EW
then
27055 elsif AR
and not AW
and not ER
and not EW
then
27060 elsif AW
and not AR
and not ER
and not EW
then
27065 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27068 end Check_External_Properties
;
27074 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
27078 -- Loop through entries in check policy list
27080 PP
:= Opt
.Check_Policy_List
;
27081 while Present
(PP
) loop
27083 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27084 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27088 or else (Pnm
= Name_Assertion
27089 and then Is_Valid_Assertion_Kind
(Nam
))
27090 or else (Pnm
= Name_Statement_Assertions
27091 and then Nam_In
(Nam
, Name_Assert
,
27092 Name_Assert_And_Cut
,
27094 Name_Loop_Invariant
,
27095 Name_Loop_Variant
))
27097 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
27098 when Name_On | Name_Check
=>
27100 when Name_Off | Name_Ignore
=>
27101 return Name_Ignore
;
27102 when Name_Disable
=>
27103 return Name_Disable
;
27105 raise Program_Error
;
27109 PP
:= Next_Pragma
(PP
);
27114 -- If there are no specific entries that matched, then we let the
27115 -- setting of assertions govern. Note that this provides the needed
27116 -- compatibility with the RM for the cases of assertion, invariant,
27117 -- precondition, predicate, and postcondition.
27119 if Assertions_Enabled
then
27122 return Name_Ignore
;
27126 ---------------------------
27127 -- Check_Missing_Part_Of --
27128 ---------------------------
27130 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
27131 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
27132 -- Determine whether a package denoted by Pack_Id declares at least one
27135 -----------------------
27136 -- Has_Visible_State --
27137 -----------------------
27139 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
27140 Item_Id
: Entity_Id
;
27143 -- Traverse the entity chain of the package trying to find at least
27144 -- one visible abstract state, variable or a package [instantiation]
27145 -- that declares a visible state.
27147 Item_Id
:= First_Entity
(Pack_Id
);
27148 while Present
(Item_Id
)
27149 and then not In_Private_Part
(Item_Id
)
27151 -- Do not consider internally generated items
27153 if not Comes_From_Source
(Item_Id
) then
27156 -- A visible state has been found
27158 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
27161 -- Recursively peek into nested packages and instantiations
27163 elsif Ekind
(Item_Id
) = E_Package
27164 and then Has_Visible_State
(Item_Id
)
27169 Next_Entity
(Item_Id
);
27173 end Has_Visible_State
;
27177 Pack_Id
: Entity_Id
;
27178 Placement
: State_Space_Kind
;
27180 -- Start of processing for Check_Missing_Part_Of
27183 -- Do not consider abstract states, variables or package instantiations
27184 -- coming from an instance as those always inherit the Part_Of indicator
27185 -- of the instance itself.
27187 if In_Instance
then
27190 -- Do not consider internally generated entities as these can never
27191 -- have a Part_Of indicator.
27193 elsif not Comes_From_Source
(Item_Id
) then
27196 -- Perform these checks only when SPARK_Mode is enabled as they will
27197 -- interfere with standard Ada rules and produce false positives.
27199 elsif SPARK_Mode
/= On
then
27202 -- Do not consider constants, because the compiler cannot accurately
27203 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27204 -- act as a hidden state of a package.
27206 elsif Ekind
(Item_Id
) = E_Constant
then
27210 -- Find where the abstract state, variable or package instantiation
27211 -- lives with respect to the state space.
27213 Find_Placement_In_State_Space
27214 (Item_Id
=> Item_Id
,
27215 Placement
=> Placement
,
27216 Pack_Id
=> Pack_Id
);
27218 -- Items that appear in a non-package construct (subprogram, block, etc)
27219 -- do not require a Part_Of indicator because they can never act as a
27222 if Placement
= Not_In_Package
then
27225 -- An item declared in the body state space of a package always act as a
27226 -- constituent and does not need explicit Part_Of indicator.
27228 elsif Placement
= Body_State_Space
then
27231 -- In general an item declared in the visible state space of a package
27232 -- does not require a Part_Of indicator. The only exception is when the
27233 -- related package is a private child unit in which case Part_Of must
27234 -- denote a state in the parent unit or in one of its descendants.
27236 elsif Placement
= Visible_State_Space
then
27237 if Is_Child_Unit
(Pack_Id
)
27238 and then Is_Private_Descendant
(Pack_Id
)
27240 -- A package instantiation does not need a Part_Of indicator when
27241 -- the related generic template has no visible state.
27243 if Ekind
(Item_Id
) = E_Package
27244 and then Is_Generic_Instance
(Item_Id
)
27245 and then not Has_Visible_State
(Item_Id
)
27249 -- All other cases require Part_Of
27253 ("indicator Part_Of is required in this context "
27254 & "(SPARK RM 7.2.6(3))", Item_Id
);
27255 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27257 ("\& is declared in the visible part of private child "
27258 & "unit %", Item_Id
);
27262 -- When the item appears in the private state space of a packge, it must
27263 -- be a part of some state declared by the said package.
27265 else pragma Assert
(Placement
= Private_State_Space
);
27267 -- The related package does not declare a state, the item cannot act
27268 -- as a Part_Of constituent.
27270 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
27273 -- A package instantiation does not need a Part_Of indicator when the
27274 -- related generic template has no visible state.
27276 elsif Ekind
(Pack_Id
) = E_Package
27277 and then Is_Generic_Instance
(Pack_Id
)
27278 and then not Has_Visible_State
(Pack_Id
)
27282 -- All other cases require Part_Of
27286 ("indicator Part_Of is required in this context "
27287 & "(SPARK RM 7.2.6(2))", Item_Id
);
27288 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27290 ("\& is declared in the private part of package %", Item_Id
);
27293 end Check_Missing_Part_Of
;
27295 ---------------------------------------------------
27296 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27297 ---------------------------------------------------
27299 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27301 Spec_Id
: Entity_Id
)
27304 if Warn_On_Redundant_Constructs
27305 and then Has_Pragma_Inline_Always
(Spec_Id
)
27307 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27309 if From_Aspect_Specification
(Prag
) then
27311 ("aspect % not enforced on inlined subprogram &?r?",
27312 Corresponding_Aspect
(Prag
), Spec_Id
);
27315 ("pragma % not enforced on inlined subprogram &?r?",
27319 end Check_Postcondition_Use_In_Inlined_Subprogram
;
27321 -------------------------------------
27322 -- Check_State_And_Constituent_Use --
27323 -------------------------------------
27325 procedure Check_State_And_Constituent_Use
27326 (States
: Elist_Id
;
27327 Constits
: Elist_Id
;
27330 Constit_Elmt
: Elmt_Id
;
27331 Constit_Id
: Entity_Id
;
27332 State_Id
: Entity_Id
;
27335 -- Nothing to do if there are no states or constituents
27337 if No
(States
) or else No
(Constits
) then
27341 -- Inspect the list of constituents and try to determine whether its
27342 -- encapsulating state is in list States.
27344 Constit_Elmt
:= First_Elmt
(Constits
);
27345 while Present
(Constit_Elmt
) loop
27346 Constit_Id
:= Node
(Constit_Elmt
);
27348 -- Determine whether the constituent is part of an encapsulating
27349 -- state that appears in the same context and if this is the case,
27350 -- emit an error (SPARK RM 7.2.6(7)).
27352 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
27354 if Present
(State_Id
) then
27355 Error_Msg_Name_1
:= Chars
(Constit_Id
);
27357 ("cannot mention state & and its constituent % in the same "
27358 & "context", Context
, State_Id
);
27362 Next_Elmt
(Constit_Elmt
);
27364 end Check_State_And_Constituent_Use
;
27366 ---------------------------------------------
27367 -- Collect_Inherited_Class_Wide_Conditions --
27368 ---------------------------------------------
27370 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
27371 Parent_Subp
: constant Entity_Id
:= Overridden_Operation
(Subp
);
27372 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
27373 In_Spec_Expr
: Boolean;
27374 Installed
: Boolean;
27376 New_Prag
: Node_Id
;
27379 Installed
:= False;
27381 -- Iterate over the contract of the overridden subprogram to find all
27382 -- inherited class-wide pre- and postconditions.
27384 if Present
(Prags
) then
27385 Prag
:= Pre_Post_Conditions
(Prags
);
27387 while Present
(Prag
) loop
27388 if Nam_In
(Pragma_Name
(Prag
), Name_Precondition
,
27389 Name_Postcondition
)
27390 and then Class_Present
(Prag
)
27392 -- The generated pragma must be analyzed in the context of
27393 -- the subprogram, to make its formals visible. In addition,
27394 -- we must inhibit freezing and full analysis because the
27395 -- controlling type of the subprogram is not frozen yet, and
27396 -- may have further primitives.
27398 if not Installed
then
27401 Install_Formals
(Subp
);
27402 In_Spec_Expr
:= In_Spec_Expression
;
27403 In_Spec_Expression
:= True;
27407 Build_Pragma_Check_Equivalent
27408 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
27410 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
27411 Preanalyze
(New_Prag
);
27413 -- Prevent further analysis in subsequent processing of the
27414 -- current list of declarations
27416 Set_Analyzed
(New_Prag
);
27419 Prag
:= Next_Pragma
(Prag
);
27423 In_Spec_Expression
:= In_Spec_Expr
;
27427 end Collect_Inherited_Class_Wide_Conditions
;
27429 ---------------------------------------
27430 -- Collect_Subprogram_Inputs_Outputs --
27431 ---------------------------------------
27433 procedure Collect_Subprogram_Inputs_Outputs
27434 (Subp_Id
: Entity_Id
;
27435 Synthesize
: Boolean := False;
27436 Subp_Inputs
: in out Elist_Id
;
27437 Subp_Outputs
: in out Elist_Id
;
27438 Global_Seen
: out Boolean)
27440 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
27441 -- Collect all relevant items from a dependency clause
27443 procedure Collect_Global_List
27445 Mode
: Name_Id
:= Name_Input
);
27446 -- Collect all relevant items from a global list
27448 -------------------------------
27449 -- Collect_Dependency_Clause --
27450 -------------------------------
27452 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
27453 procedure Collect_Dependency_Item
27455 Is_Input
: Boolean);
27456 -- Add an item to the proper subprogram input or output collection
27458 -----------------------------
27459 -- Collect_Dependency_Item --
27460 -----------------------------
27462 procedure Collect_Dependency_Item
27464 Is_Input
: Boolean)
27469 -- Nothing to collect when the item is null
27471 if Nkind
(Item
) = N_Null
then
27474 -- Ditto for attribute 'Result
27476 elsif Is_Attribute_Result
(Item
) then
27479 -- Multiple items appear as an aggregate
27481 elsif Nkind
(Item
) = N_Aggregate
then
27482 Extra
:= First
(Expressions
(Item
));
27483 while Present
(Extra
) loop
27484 Collect_Dependency_Item
(Extra
, Is_Input
);
27488 -- Otherwise this is a solitary item
27492 Append_New_Elmt
(Item
, Subp_Inputs
);
27494 Append_New_Elmt
(Item
, Subp_Outputs
);
27497 end Collect_Dependency_Item
;
27499 -- Start of processing for Collect_Dependency_Clause
27502 if Nkind
(Clause
) = N_Null
then
27505 -- A dependency cause appears as component association
27507 elsif Nkind
(Clause
) = N_Component_Association
then
27508 Collect_Dependency_Item
27509 (Item
=> Expression
(Clause
),
27512 Collect_Dependency_Item
27513 (Item
=> First
(Choices
(Clause
)),
27514 Is_Input
=> False);
27516 -- To accomodate partial decoration of disabled SPARK features, this
27517 -- routine may be called with illegal input. If this is the case, do
27518 -- not raise Program_Error.
27523 end Collect_Dependency_Clause
;
27525 -------------------------
27526 -- Collect_Global_List --
27527 -------------------------
27529 procedure Collect_Global_List
27531 Mode
: Name_Id
:= Name_Input
)
27533 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
27534 -- Add an item to the proper subprogram input or output collection
27536 -------------------------
27537 -- Collect_Global_Item --
27538 -------------------------
27540 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
27542 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
27543 Append_New_Elmt
(Item
, Subp_Inputs
);
27546 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
27547 Append_New_Elmt
(Item
, Subp_Outputs
);
27549 end Collect_Global_Item
;
27556 -- Start of processing for Collect_Global_List
27559 if Nkind
(List
) = N_Null
then
27562 -- Single global item declaration
27564 elsif Nkind_In
(List
, N_Expanded_Name
,
27566 N_Selected_Component
)
27568 Collect_Global_Item
(List
, Mode
);
27570 -- Simple global list or moded global list declaration
27572 elsif Nkind
(List
) = N_Aggregate
then
27573 if Present
(Expressions
(List
)) then
27574 Item
:= First
(Expressions
(List
));
27575 while Present
(Item
) loop
27576 Collect_Global_Item
(Item
, Mode
);
27581 Assoc
:= First
(Component_Associations
(List
));
27582 while Present
(Assoc
) loop
27583 Collect_Global_List
27584 (List
=> Expression
(Assoc
),
27585 Mode
=> Chars
(First
(Choices
(Assoc
))));
27590 -- To accomodate partial decoration of disabled SPARK features, this
27591 -- routine may be called with illegal input. If this is the case, do
27592 -- not raise Program_Error.
27597 end Collect_Global_List
;
27604 Formal
: Entity_Id
;
27606 Spec_Id
: Entity_Id
;
27607 Subp_Decl
: Node_Id
;
27610 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27613 Global_Seen
:= False;
27615 -- Process all formal parameters of entries, [generic] subprograms, and
27618 if Ekind_In
(Subp_Id
, E_Entry
,
27621 E_Generic_Function
,
27622 E_Generic_Procedure
,
27626 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
27627 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27629 -- Process all [generic] formal parameters
27631 Formal
:= First_Entity
(Spec_Id
);
27632 while Present
(Formal
) loop
27633 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
27634 E_In_Out_Parameter
,
27637 Append_New_Elmt
(Formal
, Subp_Inputs
);
27640 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
27641 E_In_Out_Parameter
,
27644 Append_New_Elmt
(Formal
, Subp_Outputs
);
27646 -- Out parameters can act as inputs when the related type is
27647 -- tagged, unconstrained array, unconstrained record, or record
27648 -- with unconstrained components.
27650 if Ekind
(Formal
) = E_Out_Parameter
27651 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
27653 Append_New_Elmt
(Formal
, Subp_Inputs
);
27657 Next_Entity
(Formal
);
27660 -- Otherwise the input denotes a task type, a task body, or the
27661 -- anonymous object created for a single task type.
27663 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
27664 or else Is_Single_Task_Object
(Subp_Id
)
27666 Subp_Decl
:= Declaration_Node
(Subp_Id
);
27667 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27670 -- When processing an entry, subprogram or task body, look for pragmas
27671 -- Refined_Depends and Refined_Global as they specify the inputs and
27674 if Is_Entry_Body
(Subp_Id
)
27675 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
27677 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
27678 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
27680 -- Subprogram declaration or stand alone body case, look for pragmas
27681 -- Depends and Global
27684 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
27685 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
27688 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27689 -- because it provides finer granularity of inputs and outputs.
27691 if Present
(Global
) then
27692 Global_Seen
:= True;
27693 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
27695 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27696 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27697 -- the inputs and outputs from [Refined_]Depends.
27699 elsif Synthesize
and then Present
(Depends
) then
27700 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
27702 -- Multiple dependency clauses appear as an aggregate
27704 if Nkind
(Clauses
) = N_Aggregate
then
27705 Clause
:= First
(Component_Associations
(Clauses
));
27706 while Present
(Clause
) loop
27707 Collect_Dependency_Clause
(Clause
);
27711 -- Otherwise this is a single dependency clause
27714 Collect_Dependency_Clause
(Clauses
);
27718 -- The current instance of a protected type acts as a formal parameter
27719 -- of mode IN for functions and IN OUT for entries and procedures
27720 -- (SPARK RM 6.1.4).
27722 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
27723 Typ
:= Scope
(Spec_Id
);
27725 -- Use the anonymous object when the type is single protected
27727 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27728 Typ
:= Anonymous_Object
(Typ
);
27731 Append_New_Elmt
(Typ
, Subp_Inputs
);
27733 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
27734 Append_New_Elmt
(Typ
, Subp_Outputs
);
27737 -- The current instance of a task type acts as a formal parameter of
27738 -- mode IN OUT (SPARK RM 6.1.4).
27740 elsif Ekind
(Spec_Id
) = E_Task_Type
then
27743 -- Use the anonymous object when the type is single task
27745 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27746 Typ
:= Anonymous_Object
(Typ
);
27749 Append_New_Elmt
(Typ
, Subp_Inputs
);
27750 Append_New_Elmt
(Typ
, Subp_Outputs
);
27752 elsif Is_Single_Task_Object
(Spec_Id
) then
27753 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
27754 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
27756 end Collect_Subprogram_Inputs_Outputs
;
27758 ---------------------------
27759 -- Contract_Freeze_Error --
27760 ---------------------------
27762 procedure Contract_Freeze_Error
27763 (Contract_Id
: Entity_Id
;
27764 Freeze_Id
: Entity_Id
)
27767 Error_Msg_Name_1
:= Chars
(Contract_Id
);
27768 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27771 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
27773 ("\all contractual items must be declared before body #", Contract_Id
);
27774 end Contract_Freeze_Error
;
27776 ---------------------------------
27777 -- Delay_Config_Pragma_Analyze --
27778 ---------------------------------
27780 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
27782 return Nam_In
(Pragma_Name
(N
), Name_Interrupt_State
,
27783 Name_Priority_Specific_Dispatching
);
27784 end Delay_Config_Pragma_Analyze
;
27786 -----------------------
27787 -- Duplication_Error --
27788 -----------------------
27790 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
27791 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
27792 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
27795 Error_Msg_Sloc
:= Sloc
(Prev
);
27796 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27798 -- Emit a precise message to distinguish between source pragmas and
27799 -- pragmas generated from aspects. The ordering of the two pragmas is
27803 -- Prag -- duplicate
27805 -- No error is emitted when both pragmas come from aspects because this
27806 -- is already detected by the general aspect analysis mechanism.
27808 if Prag_From_Asp
and Prev_From_Asp
then
27810 elsif Prag_From_Asp
then
27811 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
27812 elsif Prev_From_Asp
then
27813 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
27815 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
27817 end Duplication_Error
;
27823 function Entity_Hash
(E
: Entity_Id
) return Num_Primitives
is
27825 return Num_Primitives
(E
mod 511);
27828 ------------------------------
27829 -- Find_Encapsulating_State --
27830 ------------------------------
27832 function Find_Encapsulating_State
27833 (States
: Elist_Id
;
27834 Constit_Id
: Entity_Id
) return Entity_Id
27836 State_Id
: Entity_Id
;
27839 -- Since a constituent may be part of a larger constituent set, climb
27840 -- the encapsulating state chain looking for a state that appears in
27843 State_Id
:= Encapsulating_State
(Constit_Id
);
27844 while Present
(State_Id
) loop
27845 if Contains
(States
, State_Id
) then
27849 State_Id
:= Encapsulating_State
(State_Id
);
27853 end Find_Encapsulating_State
;
27855 --------------------------
27856 -- Find_Related_Context --
27857 --------------------------
27859 function Find_Related_Context
27861 Do_Checks
: Boolean := False) return Node_Id
27866 Stmt
:= Prev
(Prag
);
27867 while Present
(Stmt
) loop
27869 -- Skip prior pragmas, but check for duplicates
27871 if Nkind
(Stmt
) = N_Pragma
then
27872 if Do_Checks
and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
) then
27878 -- Skip internally generated code
27880 elsif not Comes_From_Source
(Stmt
) then
27882 -- The anonymous object created for a single concurrent type is a
27883 -- suitable context.
27885 if Nkind
(Stmt
) = N_Object_Declaration
27886 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
27891 -- Return the current source construct
27901 end Find_Related_Context
;
27903 --------------------------------------
27904 -- Find_Related_Declaration_Or_Body --
27905 --------------------------------------
27907 function Find_Related_Declaration_Or_Body
27909 Do_Checks
: Boolean := False) return Node_Id
27911 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
27913 procedure Expression_Function_Error
;
27914 -- Emit an error concerning pragma Prag that illegaly applies to an
27915 -- expression function.
27917 -------------------------------
27918 -- Expression_Function_Error --
27919 -------------------------------
27921 procedure Expression_Function_Error
is
27923 Error_Msg_Name_1
:= Prag_Nam
;
27925 -- Emit a precise message to distinguish between source pragmas and
27926 -- pragmas generated from aspects.
27928 if From_Aspect_Specification
(Prag
) then
27930 ("aspect % cannot apply to a stand alone expression function",
27934 ("pragma % cannot apply to a stand alone expression function",
27937 end Expression_Function_Error
;
27941 Context
: constant Node_Id
:= Parent
(Prag
);
27944 Look_For_Body
: constant Boolean :=
27945 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
27946 Name_Refined_Global
,
27947 Name_Refined_Post
);
27948 -- Refinement pragmas must be associated with a subprogram body [stub]
27950 -- Start of processing for Find_Related_Declaration_Or_Body
27953 Stmt
:= Prev
(Prag
);
27954 while Present
(Stmt
) loop
27956 -- Skip prior pragmas, but check for duplicates. Pragmas produced
27957 -- by splitting a complex pre/postcondition are not considered to
27960 if Nkind
(Stmt
) = N_Pragma
then
27962 and then not Split_PPC
(Stmt
)
27963 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
27970 -- Emit an error when a refinement pragma appears on an expression
27971 -- function without a completion.
27974 and then Look_For_Body
27975 and then Nkind
(Stmt
) = N_Subprogram_Declaration
27976 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
27977 and then not Has_Completion
(Defining_Entity
(Stmt
))
27979 Expression_Function_Error
;
27982 -- The refinement pragma applies to a subprogram body stub
27984 elsif Look_For_Body
27985 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
27989 -- Skip internally generated code
27991 elsif not Comes_From_Source
(Stmt
) then
27993 -- The anonymous object created for a single concurrent type is a
27994 -- suitable context.
27996 if Nkind
(Stmt
) = N_Object_Declaration
27997 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28001 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
28003 -- The subprogram declaration is an internally generated spec
28004 -- for an expression function.
28006 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28009 -- The subprogram is actually an instance housed within an
28010 -- anonymous wrapper package.
28012 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28017 -- Return the current construct which is either a subprogram body,
28018 -- a subprogram declaration or is illegal.
28027 -- If we fall through, then the pragma was either the first declaration
28028 -- or it was preceded by other pragmas and no source constructs.
28030 -- The pragma is associated with a library-level subprogram
28032 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
28033 return Unit
(Parent
(Context
));
28035 -- The pragma appears inside the declarations of an entry body
28037 elsif Nkind
(Context
) = N_Entry_Body
then
28040 -- The pragma appears inside the statements of a subprogram body. This
28041 -- placement is the result of subprogram contract expansion.
28043 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
28044 return Parent
(Context
);
28046 -- The pragma appears inside the declarative part of a subprogram body
28048 elsif Nkind
(Context
) = N_Subprogram_Body
then
28051 -- The pragma appears inside the declarative part of a task body
28053 elsif Nkind
(Context
) = N_Task_Body
then
28056 -- The pragma is a byproduct of aspect expansion, return the related
28057 -- context of the original aspect. This case has a lower priority as
28058 -- the above circuitry pinpoints precisely the related context.
28060 elsif Present
(Corresponding_Aspect
(Prag
)) then
28061 return Parent
(Corresponding_Aspect
(Prag
));
28063 -- No candidate subprogram [body] found
28068 end Find_Related_Declaration_Or_Body
;
28070 ----------------------------------
28071 -- Find_Related_Package_Or_Body --
28072 ----------------------------------
28074 function Find_Related_Package_Or_Body
28076 Do_Checks
: Boolean := False) return Node_Id
28078 Context
: constant Node_Id
:= Parent
(Prag
);
28079 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28083 Stmt
:= Prev
(Prag
);
28084 while Present
(Stmt
) loop
28086 -- Skip prior pragmas, but check for duplicates
28088 if Nkind
(Stmt
) = N_Pragma
then
28089 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
28095 -- Skip internally generated code
28097 elsif not Comes_From_Source
(Stmt
) then
28098 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
28100 -- The subprogram declaration is an internally generated spec
28101 -- for an expression function.
28103 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28106 -- The subprogram is actually an instance housed within an
28107 -- anonymous wrapper package.
28109 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28114 -- Return the current source construct which is illegal
28123 -- If we fall through, then the pragma was either the first declaration
28124 -- or it was preceded by other pragmas and no source constructs.
28126 -- The pragma is associated with a package. The immediate context in
28127 -- this case is the specification of the package.
28129 if Nkind
(Context
) = N_Package_Specification
then
28130 return Parent
(Context
);
28132 -- The pragma appears in the declarations of a package body
28134 elsif Nkind
(Context
) = N_Package_Body
then
28137 -- The pragma appears in the statements of a package body
28139 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
28140 and then Nkind
(Parent
(Context
)) = N_Package_Body
28142 return Parent
(Context
);
28144 -- The pragma is a byproduct of aspect expansion, return the related
28145 -- context of the original aspect. This case has a lower priority as
28146 -- the above circuitry pinpoints precisely the related context.
28148 elsif Present
(Corresponding_Aspect
(Prag
)) then
28149 return Parent
(Corresponding_Aspect
(Prag
));
28151 -- No candidate packge [body] found
28156 end Find_Related_Package_Or_Body
;
28162 function Get_Argument
28164 Context_Id
: Entity_Id
:= Empty
) return Node_Id
28166 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
28169 -- Use the expression of the original aspect when compiling for ASIS or
28170 -- when analyzing the template of a generic unit. In both cases the
28171 -- aspect's tree must be decorated to allow for ASIS queries or to save
28172 -- the global references in the generic context.
28174 if From_Aspect_Specification
(Prag
)
28175 and then (ASIS_Mode
or else (Present
(Context_Id
)
28176 and then Is_Generic_Unit
(Context_Id
)))
28178 return Corresponding_Aspect
(Prag
);
28180 -- Otherwise use the expression of the pragma
28182 elsif Present
(Args
) then
28183 return First
(Args
);
28190 -------------------------
28191 -- Get_Base_Subprogram --
28192 -------------------------
28194 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
28195 Result
: Entity_Id
;
28198 -- Follow subprogram renaming chain
28202 if Is_Subprogram
(Result
)
28204 Nkind
(Parent
(Declaration_Node
(Result
))) =
28205 N_Subprogram_Renaming_Declaration
28206 and then Present
(Alias
(Result
))
28208 Result
:= Alias
(Result
);
28212 end Get_Base_Subprogram
;
28214 -----------------------
28215 -- Get_SPARK_Mode_Type --
28216 -----------------------
28218 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
28220 if N
= Name_On
then
28222 elsif N
= Name_Off
then
28225 -- Any other argument is illegal
28228 raise Program_Error
;
28230 end Get_SPARK_Mode_Type
;
28232 ------------------------------------
28233 -- Get_SPARK_Mode_From_Annotation --
28234 ------------------------------------
28236 function Get_SPARK_Mode_From_Annotation
28237 (N
: Node_Id
) return SPARK_Mode_Type
28242 if Nkind
(N
) = N_Aspect_Specification
then
28243 Mode
:= Expression
(N
);
28245 else pragma Assert
(Nkind
(N
) = N_Pragma
);
28246 Mode
:= First
(Pragma_Argument_Associations
(N
));
28248 if Present
(Mode
) then
28249 Mode
:= Get_Pragma_Arg
(Mode
);
28253 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28255 if Present
(Mode
) then
28256 if Nkind
(Mode
) = N_Identifier
then
28257 return Get_SPARK_Mode_Type
(Chars
(Mode
));
28259 -- In case of a malformed aspect or pragma, return the default None
28265 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28270 end Get_SPARK_Mode_From_Annotation
;
28272 ---------------------------
28273 -- Has_Extra_Parentheses --
28274 ---------------------------
28276 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
28280 -- The aggregate should not have an expression list because a clause
28281 -- is always interpreted as a component association. The only way an
28282 -- expression list can sneak in is by adding extra parentheses around
28283 -- the individual clauses:
28285 -- Depends (Output => Input) -- proper form
28286 -- Depends ((Output => Input)) -- extra parentheses
28288 -- Since the extra parentheses are not allowed by the syntax of the
28289 -- pragma, flag them now to avoid emitting misleading errors down the
28292 if Nkind
(Clause
) = N_Aggregate
28293 and then Present
(Expressions
(Clause
))
28295 Expr
:= First
(Expressions
(Clause
));
28296 while Present
(Expr
) loop
28298 -- A dependency clause surrounded by extra parentheses appears
28299 -- as an aggregate of component associations with an optional
28300 -- Paren_Count set.
28302 if Nkind
(Expr
) = N_Aggregate
28303 and then Present
(Component_Associations
(Expr
))
28306 ("dependency clause contains extra parentheses", Expr
);
28308 -- Otherwise the expression is a malformed construct
28311 SPARK_Msg_N
("malformed dependency clause", Expr
);
28321 end Has_Extra_Parentheses
;
28327 procedure Initialize
is
28338 Dummy
:= Dummy
+ 1;
28341 -----------------------------
28342 -- Is_Config_Static_String --
28343 -----------------------------
28345 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28347 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
28348 -- This is an internal recursive function that is just like the outer
28349 -- function except that it adds the string to the name buffer rather
28350 -- than placing the string in the name buffer.
28352 ------------------------------
28353 -- Add_Config_Static_String --
28354 ------------------------------
28356 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28363 if Nkind
(N
) = N_Op_Concat
then
28364 if Add_Config_Static_String
(Left_Opnd
(N
)) then
28365 N
:= Right_Opnd
(N
);
28371 if Nkind
(N
) /= N_String_Literal
then
28372 Error_Msg_N
("string literal expected for pragma argument", N
);
28376 for J
in 1 .. String_Length
(Strval
(N
)) loop
28377 C
:= Get_String_Char
(Strval
(N
), J
);
28379 if not In_Character_Range
(C
) then
28381 ("string literal contains invalid wide character",
28382 Sloc
(N
) + 1 + Source_Ptr
(J
));
28386 Add_Char_To_Name_Buffer
(Get_Character
(C
));
28391 end Add_Config_Static_String
;
28393 -- Start of processing for Is_Config_Static_String
28398 return Add_Config_Static_String
(Arg
);
28399 end Is_Config_Static_String
;
28401 ---------------------
28402 -- Is_CCT_Instance --
28403 ---------------------
28405 function Is_CCT_Instance
28406 (Ref_Id
: Entity_Id
;
28407 Context_Id
: Entity_Id
) return Boolean
28413 -- When the reference denotes a single protected type, the context is
28414 -- either a protected subprogram or its body.
28416 if Is_Single_Protected_Object
(Ref_Id
) then
28417 Typ
:= Scope
(Context_Id
);
28420 Ekind
(Typ
) = E_Protected_Type
28421 and then Present
(Anonymous_Object
(Typ
))
28422 and then Anonymous_Object
(Typ
) = Ref_Id
;
28424 -- When the reference denotes a single task type, the context is either
28425 -- the same type or if inside the body, the anonymous task type.
28427 elsif Is_Single_Task_Object
(Ref_Id
) then
28428 if Ekind
(Context_Id
) = E_Task_Type
then
28430 Present
(Anonymous_Object
(Context_Id
))
28431 and then Anonymous_Object
(Context_Id
) = Ref_Id
;
28433 return Ref_Id
= Context_Id
;
28436 -- Otherwise the reference denotes a protected or a task type. Climb the
28437 -- scope chain looking for an enclosing concurrent type that matches the
28438 -- referenced entity.
28441 pragma Assert
(Ekind_In
(Ref_Id
, E_Protected_Type
, E_Task_Type
));
28443 S
:= Current_Scope
;
28444 while Present
(S
) and then S
/= Standard_Standard
loop
28445 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
)
28446 and then S
= Ref_Id
28456 end Is_CCT_Instance
;
28458 -------------------------------
28459 -- Is_Elaboration_SPARK_Mode --
28460 -------------------------------
28462 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
28465 (Nkind
(N
) = N_Pragma
28466 and then Pragma_Name
(N
) = Name_SPARK_Mode
28467 and then Is_List_Member
(N
));
28469 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28470 -- appears in the statement part of the body.
28473 Present
(Parent
(N
))
28474 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
28475 and then List_Containing
(N
) = Statements
(Parent
(N
))
28476 and then Present
(Parent
(Parent
(N
)))
28477 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
28478 end Is_Elaboration_SPARK_Mode
;
28480 -----------------------
28481 -- Is_Enabled_Pragma --
28482 -----------------------
28484 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
28488 if Present
(Prag
) then
28489 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
28491 if Present
(Arg
) then
28492 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
28494 -- The lack of a Boolean argument automatically enables the pragma
28500 -- The pragma is missing, therefore it is not enabled
28505 end Is_Enabled_Pragma
;
28507 -----------------------------------------
28508 -- Is_Non_Significant_Pragma_Reference --
28509 -----------------------------------------
28511 -- This function makes use of the following static table which indicates
28512 -- whether appearance of some name in a given pragma is to be considered
28513 -- as a reference for the purposes of warnings about unreferenced objects.
28515 -- -1 indicates that appearence in any argument is significant
28516 -- 0 indicates that appearance in any argument is not significant
28517 -- +n indicates that appearance as argument n is significant, but all
28518 -- other arguments are not significant
28519 -- 9n arguments from n on are significant, before n insignificant
28521 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
28522 (Pragma_Abort_Defer
=> -1,
28523 Pragma_Abstract_State
=> -1,
28524 Pragma_Ada_83
=> -1,
28525 Pragma_Ada_95
=> -1,
28526 Pragma_Ada_05
=> -1,
28527 Pragma_Ada_2005
=> -1,
28528 Pragma_Ada_12
=> -1,
28529 Pragma_Ada_2012
=> -1,
28530 Pragma_All_Calls_Remote
=> -1,
28531 Pragma_Allow_Integer_Address
=> -1,
28532 Pragma_Annotate
=> 93,
28533 Pragma_Assert
=> -1,
28534 Pragma_Assert_And_Cut
=> -1,
28535 Pragma_Assertion_Policy
=> 0,
28536 Pragma_Assume
=> -1,
28537 Pragma_Assume_No_Invalid_Values
=> 0,
28538 Pragma_Async_Readers
=> 0,
28539 Pragma_Async_Writers
=> 0,
28540 Pragma_Asynchronous
=> 0,
28541 Pragma_Atomic
=> 0,
28542 Pragma_Atomic_Components
=> 0,
28543 Pragma_Attach_Handler
=> -1,
28544 Pragma_Attribute_Definition
=> 92,
28545 Pragma_Check
=> -1,
28546 Pragma_Check_Float_Overflow
=> 0,
28547 Pragma_Check_Name
=> 0,
28548 Pragma_Check_Policy
=> 0,
28549 Pragma_CPP_Class
=> 0,
28550 Pragma_CPP_Constructor
=> 0,
28551 Pragma_CPP_Virtual
=> 0,
28552 Pragma_CPP_Vtable
=> 0,
28554 Pragma_C_Pass_By_Copy
=> 0,
28555 Pragma_Comment
=> -1,
28556 Pragma_Common_Object
=> 0,
28557 Pragma_Compile_Time_Error
=> -1,
28558 Pragma_Compile_Time_Warning
=> -1,
28559 Pragma_Compiler_Unit
=> -1,
28560 Pragma_Compiler_Unit_Warning
=> -1,
28561 Pragma_Complete_Representation
=> 0,
28562 Pragma_Complex_Representation
=> 0,
28563 Pragma_Component_Alignment
=> 0,
28564 Pragma_Constant_After_Elaboration
=> 0,
28565 Pragma_Contract_Cases
=> -1,
28566 Pragma_Controlled
=> 0,
28567 Pragma_Convention
=> 0,
28568 Pragma_Convention_Identifier
=> 0,
28569 Pragma_Debug
=> -1,
28570 Pragma_Debug_Policy
=> 0,
28571 Pragma_Detect_Blocking
=> 0,
28572 Pragma_Default_Initial_Condition
=> -1,
28573 Pragma_Default_Scalar_Storage_Order
=> 0,
28574 Pragma_Default_Storage_Pool
=> 0,
28575 Pragma_Depends
=> -1,
28576 Pragma_Disable_Atomic_Synchronization
=> 0,
28577 Pragma_Discard_Names
=> 0,
28578 Pragma_Dispatching_Domain
=> -1,
28579 Pragma_Effective_Reads
=> 0,
28580 Pragma_Effective_Writes
=> 0,
28581 Pragma_Elaborate
=> 0,
28582 Pragma_Elaborate_All
=> 0,
28583 Pragma_Elaborate_Body
=> 0,
28584 Pragma_Elaboration_Checks
=> 0,
28585 Pragma_Eliminate
=> 0,
28586 Pragma_Enable_Atomic_Synchronization
=> 0,
28587 Pragma_Export
=> -1,
28588 Pragma_Export_Function
=> -1,
28589 Pragma_Export_Object
=> -1,
28590 Pragma_Export_Procedure
=> -1,
28591 Pragma_Export_Value
=> -1,
28592 Pragma_Export_Valued_Procedure
=> -1,
28593 Pragma_Extend_System
=> -1,
28594 Pragma_Extensions_Allowed
=> 0,
28595 Pragma_Extensions_Visible
=> 0,
28596 Pragma_External
=> -1,
28597 Pragma_Favor_Top_Level
=> 0,
28598 Pragma_External_Name_Casing
=> 0,
28599 Pragma_Fast_Math
=> 0,
28600 Pragma_Finalize_Storage_Only
=> 0,
28602 Pragma_Global
=> -1,
28603 Pragma_Ident
=> -1,
28604 Pragma_Ignore_Pragma
=> 0,
28605 Pragma_Implementation_Defined
=> -1,
28606 Pragma_Implemented
=> -1,
28607 Pragma_Implicit_Packing
=> 0,
28608 Pragma_Import
=> 93,
28609 Pragma_Import_Function
=> 0,
28610 Pragma_Import_Object
=> 0,
28611 Pragma_Import_Procedure
=> 0,
28612 Pragma_Import_Valued_Procedure
=> 0,
28613 Pragma_Independent
=> 0,
28614 Pragma_Independent_Components
=> 0,
28615 Pragma_Initial_Condition
=> -1,
28616 Pragma_Initialize_Scalars
=> 0,
28617 Pragma_Initializes
=> -1,
28618 Pragma_Inline
=> 0,
28619 Pragma_Inline_Always
=> 0,
28620 Pragma_Inline_Generic
=> 0,
28621 Pragma_Inspection_Point
=> -1,
28622 Pragma_Interface
=> 92,
28623 Pragma_Interface_Name
=> 0,
28624 Pragma_Interrupt_Handler
=> -1,
28625 Pragma_Interrupt_Priority
=> -1,
28626 Pragma_Interrupt_State
=> -1,
28627 Pragma_Invariant
=> -1,
28628 Pragma_Keep_Names
=> 0,
28629 Pragma_License
=> 0,
28630 Pragma_Link_With
=> -1,
28631 Pragma_Linker_Alias
=> -1,
28632 Pragma_Linker_Constructor
=> -1,
28633 Pragma_Linker_Destructor
=> -1,
28634 Pragma_Linker_Options
=> -1,
28635 Pragma_Linker_Section
=> 0,
28637 Pragma_Lock_Free
=> 0,
28638 Pragma_Locking_Policy
=> 0,
28639 Pragma_Loop_Invariant
=> -1,
28640 Pragma_Loop_Optimize
=> 0,
28641 Pragma_Loop_Variant
=> -1,
28642 Pragma_Machine_Attribute
=> -1,
28644 Pragma_Main_Storage
=> -1,
28645 Pragma_Memory_Size
=> 0,
28646 Pragma_No_Return
=> 0,
28647 Pragma_No_Body
=> 0,
28648 Pragma_No_Elaboration_Code_All
=> 0,
28649 Pragma_No_Inline
=> 0,
28650 Pragma_No_Run_Time
=> -1,
28651 Pragma_No_Strict_Aliasing
=> -1,
28652 Pragma_No_Tagged_Streams
=> 0,
28653 Pragma_Normalize_Scalars
=> 0,
28654 Pragma_Obsolescent
=> 0,
28655 Pragma_Optimize
=> 0,
28656 Pragma_Optimize_Alignment
=> 0,
28657 Pragma_Overflow_Mode
=> 0,
28658 Pragma_Overriding_Renamings
=> 0,
28659 Pragma_Ordered
=> 0,
28662 Pragma_Part_Of
=> 0,
28663 Pragma_Partition_Elaboration_Policy
=> 0,
28664 Pragma_Passive
=> 0,
28665 Pragma_Persistent_BSS
=> 0,
28666 Pragma_Polling
=> 0,
28667 Pragma_Prefix_Exception_Messages
=> 0,
28669 Pragma_Postcondition
=> -1,
28670 Pragma_Post_Class
=> -1,
28672 Pragma_Precondition
=> -1,
28673 Pragma_Predicate
=> -1,
28674 Pragma_Predicate_Failure
=> -1,
28675 Pragma_Preelaborable_Initialization
=> -1,
28676 Pragma_Preelaborate
=> 0,
28677 Pragma_Pre_Class
=> -1,
28678 Pragma_Priority
=> -1,
28679 Pragma_Priority_Specific_Dispatching
=> 0,
28680 Pragma_Profile
=> 0,
28681 Pragma_Profile_Warnings
=> 0,
28682 Pragma_Propagate_Exceptions
=> 0,
28683 Pragma_Provide_Shift_Operators
=> 0,
28684 Pragma_Psect_Object
=> 0,
28686 Pragma_Pure_Function
=> 0,
28687 Pragma_Queuing_Policy
=> 0,
28688 Pragma_Rational
=> 0,
28689 Pragma_Ravenscar
=> 0,
28690 Pragma_Refined_Depends
=> -1,
28691 Pragma_Refined_Global
=> -1,
28692 Pragma_Refined_Post
=> -1,
28693 Pragma_Refined_State
=> -1,
28694 Pragma_Relative_Deadline
=> 0,
28695 Pragma_Remote_Access_Type
=> -1,
28696 Pragma_Remote_Call_Interface
=> -1,
28697 Pragma_Remote_Types
=> -1,
28698 Pragma_Restricted_Run_Time
=> 0,
28699 Pragma_Restriction_Warnings
=> 0,
28700 Pragma_Restrictions
=> 0,
28701 Pragma_Reviewable
=> -1,
28702 Pragma_Short_Circuit_And_Or
=> 0,
28703 Pragma_Share_Generic
=> 0,
28704 Pragma_Shared
=> 0,
28705 Pragma_Shared_Passive
=> 0,
28706 Pragma_Short_Descriptors
=> 0,
28707 Pragma_Simple_Storage_Pool_Type
=> 0,
28708 Pragma_Source_File_Name
=> 0,
28709 Pragma_Source_File_Name_Project
=> 0,
28710 Pragma_Source_Reference
=> 0,
28711 Pragma_SPARK_Mode
=> 0,
28712 Pragma_Storage_Size
=> -1,
28713 Pragma_Storage_Unit
=> 0,
28714 Pragma_Static_Elaboration_Desired
=> 0,
28715 Pragma_Stream_Convert
=> 0,
28716 Pragma_Style_Checks
=> 0,
28717 Pragma_Subtitle
=> 0,
28718 Pragma_Suppress
=> 0,
28719 Pragma_Suppress_Exception_Locations
=> 0,
28720 Pragma_Suppress_All
=> 0,
28721 Pragma_Suppress_Debug_Info
=> 0,
28722 Pragma_Suppress_Initialization
=> 0,
28723 Pragma_System_Name
=> 0,
28724 Pragma_Task_Dispatching_Policy
=> 0,
28725 Pragma_Task_Info
=> -1,
28726 Pragma_Task_Name
=> -1,
28727 Pragma_Task_Storage
=> -1,
28728 Pragma_Test_Case
=> -1,
28729 Pragma_Thread_Local_Storage
=> -1,
28730 Pragma_Time_Slice
=> -1,
28732 Pragma_Type_Invariant
=> -1,
28733 Pragma_Type_Invariant_Class
=> -1,
28734 Pragma_Unchecked_Union
=> 0,
28735 Pragma_Unevaluated_Use_Of_Old
=> 0,
28736 Pragma_Unimplemented_Unit
=> 0,
28737 Pragma_Universal_Aliasing
=> 0,
28738 Pragma_Universal_Data
=> 0,
28739 Pragma_Unmodified
=> 0,
28740 Pragma_Unreferenced
=> 0,
28741 Pragma_Unreferenced_Objects
=> 0,
28742 Pragma_Unreserve_All_Interrupts
=> 0,
28743 Pragma_Unsuppress
=> 0,
28744 Pragma_Unused
=> 0,
28745 Pragma_Use_VADS_Size
=> 0,
28746 Pragma_Validity_Checks
=> 0,
28747 Pragma_Volatile
=> 0,
28748 Pragma_Volatile_Components
=> 0,
28749 Pragma_Volatile_Full_Access
=> 0,
28750 Pragma_Volatile_Function
=> 0,
28751 Pragma_Warning_As_Error
=> 0,
28752 Pragma_Warnings
=> 0,
28753 Pragma_Weak_External
=> 0,
28754 Pragma_Wide_Character_Encoding
=> 0,
28755 Unknown_Pragma
=> 0);
28757 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
28763 function Arg_No
return Nat
;
28764 -- Returns an integer showing what argument we are in. A value of
28765 -- zero means we are not in any of the arguments.
28771 function Arg_No
return Nat
is
28776 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
28790 -- Start of processing for Non_Significant_Pragma_Reference
28795 if Nkind
(P
) /= N_Pragma_Argument_Association
then
28799 Id
:= Get_Pragma_Id
(Parent
(P
));
28800 C
:= Sig_Flags
(Id
);
28815 return AN
< (C
- 90);
28821 end Is_Non_Significant_Pragma_Reference
;
28823 ------------------------------
28824 -- Is_Pragma_String_Literal --
28825 ------------------------------
28827 -- This function returns true if the corresponding pragma argument is a
28828 -- static string expression. These are the only cases in which string
28829 -- literals can appear as pragma arguments. We also allow a string literal
28830 -- as the first argument to pragma Assert (although it will of course
28831 -- always generate a type error).
28833 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
28834 Pragn
: constant Node_Id
:= Parent
(Par
);
28835 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
28836 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
28842 N
:= First
(Assoc
);
28849 if Pname
= Name_Assert
then
28852 elsif Pname
= Name_Export
then
28855 elsif Pname
= Name_Ident
then
28858 elsif Pname
= Name_Import
then
28861 elsif Pname
= Name_Interface_Name
then
28864 elsif Pname
= Name_Linker_Alias
then
28867 elsif Pname
= Name_Linker_Section
then
28870 elsif Pname
= Name_Machine_Attribute
then
28873 elsif Pname
= Name_Source_File_Name
then
28876 elsif Pname
= Name_Source_Reference
then
28879 elsif Pname
= Name_Title
then
28882 elsif Pname
= Name_Subtitle
then
28888 end Is_Pragma_String_Literal
;
28890 ---------------------------
28891 -- Is_Private_SPARK_Mode --
28892 ---------------------------
28894 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
28897 (Nkind
(N
) = N_Pragma
28898 and then Pragma_Name
(N
) = Name_SPARK_Mode
28899 and then Is_List_Member
(N
));
28901 -- For pragma SPARK_Mode to be private, it has to appear in the private
28902 -- declarations of a package.
28905 Present
(Parent
(N
))
28906 and then Nkind
(Parent
(N
)) = N_Package_Specification
28907 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
28908 end Is_Private_SPARK_Mode
;
28910 -------------------------------------
28911 -- Is_Unconstrained_Or_Tagged_Item --
28912 -------------------------------------
28914 function Is_Unconstrained_Or_Tagged_Item
28915 (Item
: Entity_Id
) return Boolean
28917 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
28918 -- Determine whether record type Typ has at least one unconstrained
28921 ---------------------------------
28922 -- Has_Unconstrained_Component --
28923 ---------------------------------
28925 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
28929 Comp
:= First_Component
(Typ
);
28930 while Present
(Comp
) loop
28931 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
28935 Next_Component
(Comp
);
28939 end Has_Unconstrained_Component
;
28943 Typ
: constant Entity_Id
:= Etype
(Item
);
28945 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
28948 if Is_Tagged_Type
(Typ
) then
28951 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
28954 elsif Is_Record_Type
(Typ
) then
28955 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
28958 return Has_Unconstrained_Component
(Typ
);
28961 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
28967 end Is_Unconstrained_Or_Tagged_Item
;
28969 -----------------------------
28970 -- Is_Valid_Assertion_Kind --
28971 -----------------------------
28973 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
28980 Name_Assertion_Policy |
28981 Name_Static_Predicate |
28982 Name_Dynamic_Predicate |
28987 Name_Type_Invariant |
28988 Name_uType_Invariant |
28992 Name_Assert_And_Cut |
28994 Name_Contract_Cases |
28996 Name_Default_Initial_Condition |
28998 Name_Initial_Condition |
29001 Name_Loop_Invariant |
29002 Name_Loop_Variant |
29003 Name_Postcondition |
29004 Name_Precondition |
29006 Name_Refined_Post |
29007 Name_Statement_Assertions
=> return True;
29009 when others => return False;
29011 end Is_Valid_Assertion_Kind
;
29013 --------------------------------------
29014 -- Process_Compilation_Unit_Pragmas --
29015 --------------------------------------
29017 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
29019 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29020 -- strange because it comes at the end of the unit. Rational has the
29021 -- same name for a pragma, but treats it as a program unit pragma, In
29022 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29023 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29024 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29025 -- the context clause to ensure the correct processing.
29027 if Has_Pragma_Suppress_All
(N
) then
29028 Prepend_To
(Context_Items
(N
),
29029 Make_Pragma
(Sloc
(N
),
29030 Chars
=> Name_Suppress
,
29031 Pragma_Argument_Associations
=> New_List
(
29032 Make_Pragma_Argument_Association
(Sloc
(N
),
29033 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
29036 -- Nothing else to do at the current time
29038 end Process_Compilation_Unit_Pragmas
;
29040 -------------------------------------------
29041 -- Process_Compile_Time_Warning_Or_Error --
29042 -------------------------------------------
29044 procedure Process_Compile_Time_Warning_Or_Error
29048 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
29049 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
29050 Arg2
: constant Node_Id
:= Next
(Arg1
);
29053 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
29055 if Compile_Time_Known_Value
(Arg1x
) then
29056 if Is_True
(Expr_Value
(Arg1x
)) then
29058 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29059 Pname
: constant Name_Id
:= Pragma_Name
(N
);
29060 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
29061 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
29062 Str_Len
: constant Nat
:= String_Length
(Str
);
29064 Force
: constant Boolean :=
29065 Prag_Id
= Pragma_Compile_Time_Warning
29066 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
29067 and then (Ekind
(Cent
) /= E_Package
29068 or else not In_Private_Part
(Cent
));
29069 -- Set True if this is the warning case, and we are in the
29070 -- visible part of a package spec, or in a subprogram spec,
29071 -- in which case we want to force the client to see the
29072 -- warning, even though it is not in the main unit.
29080 -- Loop through segments of message separated by line feeds.
29081 -- We output these segments as separate messages with
29082 -- continuation marks for all but the first.
29087 Error_Msg_Strlen
:= 0;
29089 -- Loop to copy characters from argument to error message
29093 exit when Ptr
> Str_Len
;
29094 CC
:= Get_String_Char
(Str
, Ptr
);
29097 -- Ignore wide chars ??? else store character
29099 if In_Character_Range
(CC
) then
29100 C
:= Get_Character
(CC
);
29101 exit when C
= ASCII
.LF
;
29102 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
29103 Error_Msg_String
(Error_Msg_Strlen
) := C
;
29107 -- Here with one line ready to go
29109 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
29111 -- If this is a warning in a spec, then we want clients
29112 -- to see the warning, so mark the message with the
29113 -- special sequence !! to force the warning. In the case
29114 -- of a package spec, we do not force this if we are in
29115 -- the private part of the spec.
29118 if Cont
= False then
29119 Error_Msg
("<<~!!", Eloc
);
29122 Error_Msg
("\<<~!!", Eloc
);
29125 -- Error, rather than warning, or in a body, so we do not
29126 -- need to force visibility for client (error will be
29127 -- output in any case, and this is the situation in which
29128 -- we do not want a client to get a warning, since the
29129 -- warning is in the body or the spec private part).
29132 if Cont
= False then
29133 Error_Msg
("<<~", Eloc
);
29136 Error_Msg
("\<<~", Eloc
);
29140 exit when Ptr
> Str_Len
;
29145 end Process_Compile_Time_Warning_Or_Error
;
29147 ------------------------------------
29148 -- Record_Possible_Body_Reference --
29149 ------------------------------------
29151 procedure Record_Possible_Body_Reference
29152 (State_Id
: Entity_Id
;
29156 Spec_Id
: Entity_Id
;
29159 -- Ensure that we are dealing with a reference to a state
29161 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
29163 -- Climb the tree starting from the reference looking for a package body
29164 -- whose spec declares the referenced state. This criteria automatically
29165 -- excludes references in package specs which are legal. Note that it is
29166 -- not wise to emit an error now as the package body may lack pragma
29167 -- Refined_State or the referenced state may not be mentioned in the
29168 -- refinement. This approach avoids the generation of misleading errors.
29171 while Present
(Context
) loop
29172 if Nkind
(Context
) = N_Package_Body
then
29173 Spec_Id
:= Corresponding_Spec
(Context
);
29175 if Present
(Abstract_States
(Spec_Id
))
29176 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
29178 if No
(Body_References
(State_Id
)) then
29179 Set_Body_References
(State_Id
, New_Elmt_List
);
29182 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
29187 Context
:= Parent
(Context
);
29189 end Record_Possible_Body_Reference
;
29191 ------------------------------------------
29192 -- Relocate_Pragmas_To_Anonymous_Object --
29193 ------------------------------------------
29195 procedure Relocate_Pragmas_To_Anonymous_Object
29196 (Typ_Decl
: Node_Id
;
29197 Obj_Decl
: Node_Id
)
29201 Next_Decl
: Node_Id
;
29204 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
29205 Def
:= Protected_Definition
(Typ_Decl
);
29207 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
29208 Def
:= Task_Definition
(Typ_Decl
);
29211 -- The concurrent definition has a visible declaration list. Inspect it
29212 -- and relocate all canidate pragmas.
29214 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
29215 Decl
:= First
(Visible_Declarations
(Def
));
29216 while Present
(Decl
) loop
29218 -- Preserve the following declaration for iteration purposes due
29219 -- to possible relocation of a pragma.
29221 Next_Decl
:= Next
(Decl
);
29223 if Nkind
(Decl
) = N_Pragma
29224 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
29227 Insert_After
(Obj_Decl
, Decl
);
29229 -- Skip internally generated code
29231 elsif not Comes_From_Source
(Decl
) then
29234 -- No candidate pragmas are available for relocation
29243 end Relocate_Pragmas_To_Anonymous_Object
;
29245 ------------------------------
29246 -- Relocate_Pragmas_To_Body --
29247 ------------------------------
29249 procedure Relocate_Pragmas_To_Body
29250 (Subp_Body
: Node_Id
;
29251 Target_Body
: Node_Id
:= Empty
)
29253 procedure Relocate_Pragma
(Prag
: Node_Id
);
29254 -- Remove a single pragma from its current list and add it to the
29255 -- declarations of the proper body (either Subp_Body or Target_Body).
29257 ---------------------
29258 -- Relocate_Pragma --
29259 ---------------------
29261 procedure Relocate_Pragma
(Prag
: Node_Id
) is
29266 -- When subprogram stubs or expression functions are involves, the
29267 -- destination declaration list belongs to the proper body.
29269 if Present
(Target_Body
) then
29270 Target
:= Target_Body
;
29272 Target
:= Subp_Body
;
29275 Decls
:= Declarations
(Target
);
29279 Set_Declarations
(Target
, Decls
);
29282 -- Unhook the pragma from its current list
29285 Prepend
(Prag
, Decls
);
29286 end Relocate_Pragma
;
29290 Body_Id
: constant Entity_Id
:=
29291 Defining_Unit_Name
(Specification
(Subp_Body
));
29292 Next_Stmt
: Node_Id
;
29295 -- Start of processing for Relocate_Pragmas_To_Body
29298 -- Do not process a body that comes from a separate unit as no construct
29299 -- can possibly follow it.
29301 if not Is_List_Member
(Subp_Body
) then
29304 -- Do not relocate pragmas that follow a stub if the stub does not have
29307 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
29308 and then No
(Target_Body
)
29312 -- Do not process internally generated routine _Postconditions
29314 elsif Ekind
(Body_Id
) = E_Procedure
29315 and then Chars
(Body_Id
) = Name_uPostconditions
29320 -- Look at what is following the body. We are interested in certain kind
29321 -- of pragmas (either from source or byproducts of expansion) that can
29322 -- apply to a body [stub].
29324 Stmt
:= Next
(Subp_Body
);
29325 while Present
(Stmt
) loop
29327 -- Preserve the following statement for iteration purposes due to a
29328 -- possible relocation of a pragma.
29330 Next_Stmt
:= Next
(Stmt
);
29332 -- Move a candidate pragma following the body to the declarations of
29335 if Nkind
(Stmt
) = N_Pragma
29336 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
29338 Relocate_Pragma
(Stmt
);
29340 -- Skip internally generated code
29342 elsif not Comes_From_Source
(Stmt
) then
29345 -- No candidate pragmas are available for relocation
29353 end Relocate_Pragmas_To_Body
;
29355 -------------------
29356 -- Resolve_State --
29357 -------------------
29359 procedure Resolve_State
(N
: Node_Id
) is
29364 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29365 Func
:= Entity
(N
);
29367 -- Handle overloading of state names by functions. Traverse the
29368 -- homonym chain looking for an abstract state.
29370 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
29371 State
:= Homonym
(Func
);
29372 while Present
(State
) loop
29374 -- Resolve the overloading by setting the proper entity of the
29375 -- reference to that of the state.
29377 if Ekind
(State
) = E_Abstract_State
then
29378 Set_Etype
(N
, Standard_Void_Type
);
29379 Set_Entity
(N
, State
);
29380 Set_Associated_Node
(N
, State
);
29384 State
:= Homonym
(State
);
29387 -- A function can never act as a state. If the homonym chain does
29388 -- not contain a corresponding state, then something went wrong in
29389 -- the overloading mechanism.
29391 raise Program_Error
;
29396 ----------------------------
29397 -- Rewrite_Assertion_Kind --
29398 ----------------------------
29400 procedure Rewrite_Assertion_Kind
(N
: Node_Id
) is
29404 if Nkind
(N
) = N_Attribute_Reference
29405 and then Attribute_Name
(N
) = Name_Class
29406 and then Nkind
(Prefix
(N
)) = N_Identifier
29408 case Chars
(Prefix
(N
)) is
29413 when Name_Type_Invariant
=>
29414 Nam
:= Name_uType_Invariant
;
29415 when Name_Invariant
=>
29416 Nam
:= Name_uInvariant
;
29421 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
29423 end Rewrite_Assertion_Kind
;
29431 Dummy
:= Dummy
+ 1;
29434 --------------------------------
29435 -- Set_Encoded_Interface_Name --
29436 --------------------------------
29438 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
29439 Str
: constant String_Id
:= Strval
(S
);
29440 Len
: constant Nat
:= String_Length
(Str
);
29445 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
29448 -- Stores encoded value of character code CC. The encoding we use an
29449 -- underscore followed by four lower case hex digits.
29455 procedure Encode
is
29457 Store_String_Char
(Get_Char_Code
('_'));
29459 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
29461 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
29463 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
29465 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
29468 -- Start of processing for Set_Encoded_Interface_Name
29471 -- If first character is asterisk, this is a link name, and we leave it
29472 -- completely unmodified. We also ignore null strings (the latter case
29473 -- happens only in error cases).
29476 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
29478 Set_Interface_Name
(E
, S
);
29483 CC
:= Get_String_Char
(Str
, J
);
29485 exit when not In_Character_Range
(CC
);
29487 C
:= Get_Character
(CC
);
29489 exit when C
/= '_' and then C
/= '$'
29490 and then C
not in '0' .. '9'
29491 and then C
not in 'a' .. 'z'
29492 and then C
not in 'A' .. 'Z';
29495 Set_Interface_Name
(E
, S
);
29503 -- Here we need to encode. The encoding we use as follows:
29504 -- three underscores + four hex digits (lower case)
29508 for J
in 1 .. String_Length
(Str
) loop
29509 CC
:= Get_String_Char
(Str
, J
);
29511 if not In_Character_Range
(CC
) then
29514 C
:= Get_Character
(CC
);
29516 if C
= '_' or else C
= '$'
29517 or else C
in '0' .. '9'
29518 or else C
in 'a' .. 'z'
29519 or else C
in 'A' .. 'Z'
29521 Store_String_Char
(CC
);
29528 Set_Interface_Name
(E
,
29529 Make_String_Literal
(Sloc
(S
),
29530 Strval
=> End_String
));
29532 end Set_Encoded_Interface_Name
;
29534 ------------------------
29535 -- Set_Elab_Unit_Name --
29536 ------------------------
29538 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
29543 if Nkind
(N
) = N_Identifier
29544 and then Nkind
(With_Item
) = N_Identifier
29546 Set_Entity
(N
, Entity
(With_Item
));
29548 elsif Nkind
(N
) = N_Selected_Component
then
29549 Change_Selected_Component_To_Expanded_Name
(N
);
29550 Set_Entity
(N
, Entity
(With_Item
));
29551 Set_Entity
(Selector_Name
(N
), Entity
(N
));
29553 Pref
:= Prefix
(N
);
29554 Scop
:= Scope
(Entity
(N
));
29555 while Nkind
(Pref
) = N_Selected_Component
loop
29556 Change_Selected_Component_To_Expanded_Name
(Pref
);
29557 Set_Entity
(Selector_Name
(Pref
), Scop
);
29558 Set_Entity
(Pref
, Scop
);
29559 Pref
:= Prefix
(Pref
);
29560 Scop
:= Scope
(Scop
);
29563 Set_Entity
(Pref
, Scop
);
29566 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
29567 end Set_Elab_Unit_Name
;
29569 -------------------
29570 -- Test_Case_Arg --
29571 -------------------
29573 function Test_Case_Arg
29576 From_Aspect
: Boolean := False) return Node_Id
29578 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
29583 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
29588 -- The caller requests the aspect argument
29590 if From_Aspect
then
29591 if Present
(Aspect
)
29592 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
29594 Args
:= Expression
(Aspect
);
29596 -- "Name" and "Mode" may appear without an identifier as a
29597 -- positional association.
29599 if Present
(Expressions
(Args
)) then
29600 Arg
:= First
(Expressions
(Args
));
29602 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29610 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29615 -- Some or all arguments may appear as component associatons
29617 if Present
(Component_Associations
(Args
)) then
29618 Arg
:= First
(Component_Associations
(Args
));
29619 while Present
(Arg
) loop
29620 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
29629 -- Otherwise retrieve the argument directly from the pragma
29632 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29634 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29638 -- Skip argument "Name"
29642 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29646 -- Skip argument "Mode"
29650 -- Arguments "Requires" and "Ensures" are optional and may not be
29653 while Present
(Arg
) loop
29654 if Chars
(Arg
) = Arg_Nam
then
29665 -------------------------------
29666 -- Update_Primitives_Mapping --
29667 -------------------------------
29669 procedure Update_Primitives_Mapping
29670 (Inher_Id
: Entity_Id
;
29671 Subp_Id
: Entity_Id
)
29673 function Overridden_Ancestor
(S
: Entity_Id
) return Entity_Id
;
29674 -- Locate the primitive operation with the name of S whose controlling
29675 -- type is the dispatching type of Inher_Id.
29677 -------------------------
29678 -- Overridden_Ancestor --
29679 -------------------------
29681 function Overridden_Ancestor
(S
: Entity_Id
) return Entity_Id
is
29682 Par
: constant Entity_Id
:= Find_Dispatching_Type
(Inher_Id
);
29688 -- Locate the ancestor subprogram with the proper controlling type
29690 while Present
(Overridden_Operation
(Anc
)) loop
29691 Anc
:= Overridden_Operation
(Anc
);
29692 exit when Find_Dispatching_Type
(Anc
) = Par
;
29696 end Overridden_Ancestor
;
29700 Old_Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Inher_Id
);
29701 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(Subp_Id
);
29703 Old_Elmt
: Elmt_Id
;
29704 Old_Prim
: Entity_Id
;
29707 -- Start of processing for Update_Primitives_Mapping
29710 -- If the types are already in the map, it has been previously built for
29711 -- some other overriding primitive.
29713 if Primitives_Mapping
.Get
(Old_Typ
) = Typ
then
29717 -- Initialize new mapping with the primitive operations
29719 Decl
:= First
(List_Containing
(Unit_Declaration_Node
(Subp_Id
)));
29721 -- Look for primitive operations of the current type that have
29722 -- overridden an operation of the type related to the original
29723 -- class-wide precondition. There may be several intermediate
29724 -- overridings between them.
29726 while Present
(Decl
) loop
29727 if Nkind_In
(Decl
, N_Abstract_Subprogram_Declaration
,
29728 N_Subprogram_Declaration
)
29730 Prim
:= Defining_Entity
(Decl
);
29732 if Is_Subprogram
(Prim
)
29733 and then Present
(Overridden_Operation
(Prim
))
29734 and then Find_Dispatching_Type
(Prim
) = Typ
29736 Old_Prim
:= Overridden_Ancestor
(Prim
);
29738 Primitives_Mapping
.Set
(Old_Prim
, Prim
);
29745 -- Now examine inherited operations. these do not override, but have
29746 -- an alias, which is the entity used in a call. That alias may be
29747 -- inherited or come from source, in which case it may override an
29748 -- earlier operation. We only need to examine inherited functions,
29749 -- that can appear within the inherited expression.
29751 Prim
:= First_Entity
(Scope
(Subp_Id
));
29752 while Present
(Prim
) loop
29753 if not Comes_From_Source
(Prim
)
29754 and then Ekind
(Prim
) = E_Function
29755 and then Present
(Alias
(Prim
))
29757 Old_Prim
:= Alias
(Prim
);
29759 if Comes_From_Source
(Old_Prim
) then
29760 Old_Prim
:= Overridden_Ancestor
(Old_Prim
);
29763 while Present
(Alias
(Old_Prim
))
29764 and then Scope
(Old_Prim
) /= Scope
(Inher_Id
)
29766 Old_Prim
:= Alias
(Old_Prim
);
29768 if Comes_From_Source
(Old_Prim
) then
29769 Old_Prim
:= Overridden_Ancestor
(Old_Prim
);
29775 Primitives_Mapping
.Set
(Old_Prim
, Prim
);
29778 Next_Entity
(Prim
);
29781 -- If the parent operation is an interface operation, the overriding
29782 -- indicator is not present. Instead, we get from the interface
29783 -- operation the primitive of the current type that implements it.
29785 if Is_Interface
(Old_Typ
) then
29786 Old_Elmt
:= First_Elmt
(Collect_Primitive_Operations
(Old_Typ
));
29787 while Present
(Old_Elmt
) loop
29788 Old_Prim
:= Node
(Old_Elmt
);
29789 Prim
:= Find_Primitive_Covering_Interface
(Typ
, Old_Prim
);
29791 if Present
(Prim
) then
29792 Primitives_Mapping
.Set
(Old_Prim
, Prim
);
29795 Next_Elmt
(Old_Elmt
);
29800 -- Map the types themselves, so that the process is not repeated for
29801 -- other overriding primitives.
29803 Primitives_Mapping
.Set
(Old_Typ
, Typ
);
29804 end Update_Primitives_Mapping
;