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 package body Sem_Prag
is
94 ----------------------------------------------
95 -- Common Handling of Import-Export Pragmas --
96 ----------------------------------------------
98 -- In the following section, a number of Import_xxx and Export_xxx pragmas
99 -- are defined by GNAT. These are compatible with the DEC pragmas of the
100 -- same name, and all have the following common form and processing:
103 -- [Internal =>] LOCAL_NAME
104 -- [, [External =>] EXTERNAL_SYMBOL]
105 -- [, other optional parameters ]);
108 -- [Internal =>] LOCAL_NAME
109 -- [, [External =>] EXTERNAL_SYMBOL]
110 -- [, other optional parameters ]);
112 -- EXTERNAL_SYMBOL ::=
114 -- | static_string_EXPRESSION
116 -- The internal LOCAL_NAME designates the entity that is imported or
117 -- exported, and must refer to an entity in the current declarative
118 -- part (as required by the rules for LOCAL_NAME).
120 -- The external linker name is designated by the External parameter if
121 -- given, or the Internal parameter if not (if there is no External
122 -- parameter, the External parameter is a copy of the Internal name).
124 -- If the External parameter is given as a string, then this string is
125 -- treated as an external name (exactly as though it had been given as an
126 -- External_Name parameter for a normal Import pragma).
128 -- If the External parameter is given as an identifier (or there is no
129 -- External parameter, so that the Internal identifier is used), then
130 -- the external name is the characters of the identifier, translated
131 -- to all lower case letters.
133 -- Note: the external name specified or implied by any of these special
134 -- Import_xxx or Export_xxx pragmas override an external or link name
135 -- specified in a previous Import or Export pragma.
137 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
138 -- named notation, following the standard rules for subprogram calls, i.e.
139 -- parameters can be given in any order if named notation is used, and
140 -- positional and named notation can be mixed, subject to the rule that all
141 -- positional parameters must appear first.
143 -- Note: All these pragmas are implemented exactly following the DEC design
144 -- and implementation and are intended to be fully compatible with the use
145 -- of these pragmas in the DEC Ada compiler.
147 --------------------------------------------
148 -- Checking for Duplicated External Names --
149 --------------------------------------------
151 -- It is suspicious if two separate Export pragmas use the same external
152 -- name. The following table is used to diagnose this situation so that
153 -- an appropriate warning can be issued.
155 -- The Node_Id stored is for the N_String_Literal node created to hold
156 -- the value of the external name. The Sloc of this node is used to
157 -- cross-reference the location of the duplication.
159 package Externals
is new Table
.Table
(
160 Table_Component_Type
=> Node_Id
,
161 Table_Index_Type
=> Int
,
162 Table_Low_Bound
=> 0,
163 Table_Initial
=> 100,
164 Table_Increment
=> 100,
165 Table_Name
=> "Name_Externals");
167 -------------------------------------
168 -- Local Subprograms and Variables --
169 -------------------------------------
171 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
172 -- This routine is used for possible casing adjustment of an explicit
173 -- external name supplied as a string literal (the node N), according to
174 -- the casing requirement of Opt.External_Name_Casing. If this is set to
175 -- As_Is, then the string literal is returned unchanged, but if it is set
176 -- to Uppercase or Lowercase, then a new string literal with appropriate
177 -- casing is constructed.
179 procedure Analyze_Part_Of
183 Encap_Id
: out Entity_Id
;
184 Legal
: out Boolean);
185 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
186 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
187 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
188 -- package instantiation. Encap denotes the encapsulating state or single
189 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
190 -- the indicator is legal.
192 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
193 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
194 -- Query whether a particular item appears in a mixed list of nodes and
195 -- entities. It is assumed that all nodes in the list have entities.
197 procedure Check_Postcondition_Use_In_Inlined_Subprogram
199 Spec_Id
: Entity_Id
);
200 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
201 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
202 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
204 procedure Check_State_And_Constituent_Use
208 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
209 -- Global and Initializes. Determine whether a state from list States and a
210 -- corresponding constituent from list Constits (if any) appear in the same
211 -- context denoted by Context. If this is the case, emit an error.
213 procedure Contract_Freeze_Error
214 (Contract_Id
: Entity_Id
;
215 Freeze_Id
: Entity_Id
);
216 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
217 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
218 -- of a body which caused contract "freezing" and Contract_Id denotes the
219 -- entity of the affected contstruct.
221 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
222 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
223 -- Prag that duplicates previous pragma Prev.
225 function Find_Encapsulating_State
227 Constit_Id
: Entity_Id
) return Entity_Id
;
228 -- Given the entity of a constituent Constit_Id, find the corresponding
229 -- encapsulating state which appears in States. The routine returns Empty
230 -- if no such state is found.
232 function Find_Related_Context
234 Do_Checks
: Boolean := False) return Node_Id
;
235 -- Subsidiaty to the analysis of pragmas Async_Readers, Async_Writers,
236 -- Constant_After_Elaboration, Effective_Reads, Effective_Writers and
237 -- Part_Of. Find the first source declaration or statement found while
238 -- traversing the previous node chain starting from pragma Prag. If flag
239 -- Do_Checks is set, the routine reports duplicate pragmas. The routine
240 -- returns Empty when reaching the start of the node chain.
242 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
243 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
244 -- original one, following the renaming chain) is returned. Otherwise the
245 -- entity is returned unchanged. Should be in Einfo???
247 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
248 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
249 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
250 -- value of type SPARK_Mode_Type.
252 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
253 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
254 -- Determine whether dependency clause Clause is surrounded by extra
255 -- parentheses. If this is the case, issue an error message.
257 function Is_CCT_Instance
259 Context_Id
: Entity_Id
) return Boolean;
260 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
261 -- Global. Determine whether entity Ref_Id denotes the current instance of
262 -- a concurrent type. Context_Id denotes the associated context where the
265 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
266 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
267 -- pragma Depends. Determine whether the type of dependency item Item is
268 -- tagged, unconstrained array, unconstrained record or a record with at
269 -- least one unconstrained component.
271 procedure Record_Possible_Body_Reference
272 (State_Id
: Entity_Id
;
274 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
275 -- Global. Given an abstract state denoted by State_Id and a reference Ref
276 -- to it, determine whether the reference appears in a package body that
277 -- will eventually refine the state. If this is the case, record the
278 -- reference for future checks (see Analyze_Refined_State_In_Decls).
280 procedure Resolve_State
(N
: Node_Id
);
281 -- Handle the overloading of state names by functions. When N denotes a
282 -- function, this routine finds the corresponding state and sets the entity
283 -- of N to that of the state.
285 procedure Rewrite_Assertion_Kind
287 From_Policy
: Boolean := False);
288 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
289 -- then it is rewritten as an identifier with the corresponding special
290 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
291 -- and Check_Policy. If the names are Precondition or Postcondition, this
292 -- combination is deprecated in favor of Assertion_Policy and Ada2012
293 -- Aspect names. The parameter From_Policy indicates that the pragma
294 -- is the old non-standard Check_Policy and not a rewritten pragma.
296 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
297 -- Place semantic information on the argument of an Elaborate/Elaborate_All
298 -- pragma. Entity name for unit and its parents is taken from item in
299 -- previous with_clause that mentions the unit.
301 Dummy
: Integer := 0;
302 pragma Volatile
(Dummy
);
303 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
306 pragma No_Inline
(ip
);
307 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
308 -- is just to help debugging the front end. If a pragma Inspection_Point
309 -- is added to a source program, then breaking on ip will get you to that
310 -- point in the program.
313 pragma No_Inline
(rv
);
314 -- This is a dummy function called by the processing for pragma Reviewable.
315 -- It is there for assisting front end debugging. By placing a Reviewable
316 -- pragma in the source program, a breakpoint on rv catches this place in
317 -- the source, allowing convenient stepping to the point of interest.
319 -------------------------------
320 -- Adjust_External_Name_Case --
321 -------------------------------
323 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
327 -- Adjust case of literal if required
329 if Opt
.External_Name_Exp_Casing
= As_Is
then
333 -- Copy existing string
339 for J
in 1 .. String_Length
(Strval
(N
)) loop
340 CC
:= Get_String_Char
(Strval
(N
), J
);
342 if Opt
.External_Name_Exp_Casing
= Uppercase
343 and then CC
>= Get_Char_Code
('a')
344 and then CC
<= Get_Char_Code
('z')
346 Store_String_Char
(CC
- 32);
348 elsif Opt
.External_Name_Exp_Casing
= Lowercase
349 and then CC
>= Get_Char_Code
('A')
350 and then CC
<= Get_Char_Code
('Z')
352 Store_String_Char
(CC
+ 32);
355 Store_String_Char
(CC
);
360 Make_String_Literal
(Sloc
(N
),
361 Strval
=> End_String
);
363 end Adjust_External_Name_Case
;
365 -----------------------------------------
366 -- Analyze_Contract_Cases_In_Decl_Part --
367 -----------------------------------------
369 -- WARNING: This routine manages Ghost regions. Return statements must be
370 -- replaced by gotos which jump to the end of the routine and restore the
373 procedure Analyze_Contract_Cases_In_Decl_Part
375 Freeze_Id
: Entity_Id
:= Empty
)
377 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
378 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
380 Others_Seen
: Boolean := False;
381 -- This flag is set when an "others" choice is encountered. It is used
382 -- to detect multiple illegal occurrences of "others".
384 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
385 -- Verify the legality of a single contract case
387 ---------------------------
388 -- Analyze_Contract_Case --
389 ---------------------------
391 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
392 Case_Guard
: Node_Id
;
395 Extra_Guard
: Node_Id
;
398 if Nkind
(CCase
) = N_Component_Association
then
399 Case_Guard
:= First
(Choices
(CCase
));
400 Conseq
:= Expression
(CCase
);
402 -- Each contract case must have exactly one case guard
404 Extra_Guard
:= Next
(Case_Guard
);
406 if Present
(Extra_Guard
) then
408 ("contract case must have exactly one case guard",
412 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
414 if Nkind
(Case_Guard
) = N_Others_Choice
then
417 ("only one others choice allowed in contract cases",
423 elsif Others_Seen
then
425 ("others must be the last choice in contract cases", N
);
428 -- Preanalyze the case guard and consequence
430 if Nkind
(Case_Guard
) /= N_Others_Choice
then
431 Errors
:= Serious_Errors_Detected
;
432 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
434 -- Emit a clarification message when the case guard contains
435 -- at least one undefined reference, possibly due to contract
438 if Errors
/= Serious_Errors_Detected
439 and then Present
(Freeze_Id
)
440 and then Has_Undefined_Reference
(Case_Guard
)
442 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
446 Errors
:= Serious_Errors_Detected
;
447 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
449 -- Emit a clarification message when the consequence contains
450 -- at least one undefined reference, possibly due to contract
453 if Errors
/= Serious_Errors_Detected
454 and then Present
(Freeze_Id
)
455 and then Has_Undefined_Reference
(Conseq
)
457 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
460 -- The contract case is malformed
463 Error_Msg_N
("wrong syntax in contract case", CCase
);
465 end Analyze_Contract_Case
;
469 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
472 Mode
: Ghost_Mode_Type
;
473 Restore_Scope
: Boolean := False;
475 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
478 -- Do not analyze the pragma multiple times
480 if Is_Analyzed_Pragma
(N
) then
484 -- Set the Ghost mode in effect from the pragma. Due to the delayed
485 -- analysis of the pragma, the Ghost mode at point of declaration and
486 -- point of analysis may not necessarily be the same. Use the mode in
487 -- effect at the point of declaration.
489 Set_Ghost_Mode
(N
, Mode
);
491 -- Single and multiple contract cases must appear in aggregate form. If
492 -- this is not the case, then either the parser of the analysis of the
493 -- pragma failed to produce an aggregate.
495 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
497 if Present
(Component_Associations
(CCases
)) then
499 -- Ensure that the formal parameters are visible when analyzing all
500 -- clauses. This falls out of the general rule of aspects pertaining
501 -- to subprogram declarations.
503 if not In_Open_Scopes
(Spec_Id
) then
504 Restore_Scope
:= True;
505 Push_Scope
(Spec_Id
);
507 if Is_Generic_Subprogram
(Spec_Id
) then
508 Install_Generic_Formals
(Spec_Id
);
510 Install_Formals
(Spec_Id
);
514 CCase
:= First
(Component_Associations
(CCases
));
515 while Present
(CCase
) loop
516 Analyze_Contract_Case
(CCase
);
520 if Restore_Scope
then
524 -- Currently it is not possible to inline pre/postconditions on a
525 -- subprogram subject to pragma Inline_Always.
527 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
529 -- Otherwise the pragma is illegal
532 Error_Msg_N
("wrong syntax for constract cases", N
);
535 Set_Is_Analyzed_Pragma
(N
);
536 Restore_Ghost_Mode
(Mode
);
537 end Analyze_Contract_Cases_In_Decl_Part
;
539 ----------------------------------
540 -- Analyze_Depends_In_Decl_Part --
541 ----------------------------------
543 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
544 Loc
: constant Source_Ptr
:= Sloc
(N
);
545 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
546 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
548 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
549 -- A list containing the entities of all the inputs processed so far.
550 -- The list is populated with unique entities because the same input
551 -- may appear in multiple input lists.
553 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
554 -- A list containing the entities of all the outputs processed so far.
555 -- The list is populated with unique entities because output items are
556 -- unique in a dependence relation.
558 Constits_Seen
: Elist_Id
:= No_Elist
;
559 -- A list containing the entities of all constituents processed so far.
560 -- It aids in detecting illegal usage of a state and a corresponding
561 -- constituent in pragma [Refinde_]Depends.
563 Global_Seen
: Boolean := False;
564 -- A flag set when pragma Global has been processed
566 Null_Output_Seen
: Boolean := False;
567 -- A flag used to track the legality of a null output
569 Result_Seen
: Boolean := False;
570 -- A flag set when Spec_Id'Result is processed
572 States_Seen
: Elist_Id
:= No_Elist
;
573 -- A list containing the entities of all states processed so far. It
574 -- helps in detecting illegal usage of a state and a corresponding
575 -- constituent in pragma [Refined_]Depends.
577 Subp_Inputs
: Elist_Id
:= No_Elist
;
578 Subp_Outputs
: Elist_Id
:= No_Elist
;
579 -- Two lists containing the full set of inputs and output of the related
580 -- subprograms. Note that these lists contain both nodes and entities.
582 Task_Input_Seen
: Boolean := False;
583 Task_Output_Seen
: Boolean := False;
584 -- Flags used to track the implicit dependence of a task unit on itself
586 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
587 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
588 -- to the name buffer. The individual kinds are as follows:
589 -- E_Abstract_State - "state"
590 -- E_Constant - "constant"
591 -- E_Discriminant - "discriminant"
592 -- E_Generic_In_Out_Parameter - "generic parameter"
593 -- E_Generic_In_Parameter - "generic parameter"
594 -- E_In_Parameter - "parameter"
595 -- E_In_Out_Parameter - "parameter"
596 -- E_Loop_Parameter - "loop parameter"
597 -- E_Out_Parameter - "parameter"
598 -- E_Protected_Type - "current instance of protected type"
599 -- E_Task_Type - "current instance of task type"
600 -- E_Variable - "global"
602 procedure Analyze_Dependency_Clause
605 -- Verify the legality of a single dependency clause. Flag Is_Last
606 -- denotes whether Clause is the last clause in the relation.
608 procedure Check_Function_Return
;
609 -- Verify that Funtion'Result appears as one of the outputs
610 -- (SPARK RM 6.1.5(10)).
617 -- Ensure that an item fulfills its designated input and/or output role
618 -- as specified by pragma Global (if any) or the enclosing context. If
619 -- this is not the case, emit an error. Item and Item_Id denote the
620 -- attributes of an item. Flag Is_Input should be set when item comes
621 -- from an input list. Flag Self_Ref should be set when the item is an
622 -- output and the dependency clause has operator "+".
624 procedure Check_Usage
625 (Subp_Items
: Elist_Id
;
626 Used_Items
: Elist_Id
;
628 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
629 -- error if this is not the case.
631 procedure Normalize_Clause
(Clause
: Node_Id
);
632 -- Remove a self-dependency "+" from the input list of a clause
634 -----------------------------
635 -- Add_Item_To_Name_Buffer --
636 -----------------------------
638 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
640 if Ekind
(Item_Id
) = E_Abstract_State
then
641 Add_Str_To_Name_Buffer
("state");
643 elsif Ekind
(Item_Id
) = E_Constant
then
644 Add_Str_To_Name_Buffer
("constant");
646 elsif Ekind
(Item_Id
) = E_Discriminant
then
647 Add_Str_To_Name_Buffer
("discriminant");
649 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
650 E_Generic_In_Parameter
)
652 Add_Str_To_Name_Buffer
("generic parameter");
654 elsif Is_Formal
(Item_Id
) then
655 Add_Str_To_Name_Buffer
("parameter");
657 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
658 Add_Str_To_Name_Buffer
("loop parameter");
660 elsif Ekind
(Item_Id
) = E_Protected_Type
661 or else Is_Single_Protected_Object
(Item_Id
)
663 Add_Str_To_Name_Buffer
("current instance of protected type");
665 elsif Ekind
(Item_Id
) = E_Task_Type
666 or else Is_Single_Task_Object
(Item_Id
)
668 Add_Str_To_Name_Buffer
("current instance of task type");
670 elsif Ekind
(Item_Id
) = E_Variable
then
671 Add_Str_To_Name_Buffer
("global");
673 -- The routine should not be called with non-SPARK items
678 end Add_Item_To_Name_Buffer
;
680 -------------------------------
681 -- Analyze_Dependency_Clause --
682 -------------------------------
684 procedure Analyze_Dependency_Clause
688 procedure Analyze_Input_List
(Inputs
: Node_Id
);
689 -- Verify the legality of a single input list
691 procedure Analyze_Input_Output
696 Seen
: in out Elist_Id
;
697 Null_Seen
: in out Boolean;
698 Non_Null_Seen
: in out Boolean);
699 -- Verify the legality of a single input or output item. Flag
700 -- Is_Input should be set whenever Item is an input, False when it
701 -- denotes an output. Flag Self_Ref should be set when the item is an
702 -- output and the dependency clause has a "+". Flag Top_Level should
703 -- be set whenever Item appears immediately within an input or output
704 -- list. Seen is a collection of all abstract states, objects and
705 -- formals processed so far. Flag Null_Seen denotes whether a null
706 -- input or output has been encountered. Flag Non_Null_Seen denotes
707 -- whether a non-null input or output has been encountered.
709 ------------------------
710 -- Analyze_Input_List --
711 ------------------------
713 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
714 Inputs_Seen
: Elist_Id
:= No_Elist
;
715 -- A list containing the entities of all inputs that appear in the
716 -- current input list.
718 Non_Null_Input_Seen
: Boolean := False;
719 Null_Input_Seen
: Boolean := False;
720 -- Flags used to check the legality of an input list
725 -- Multiple inputs appear as an aggregate
727 if Nkind
(Inputs
) = N_Aggregate
then
728 if Present
(Component_Associations
(Inputs
)) then
730 ("nested dependency relations not allowed", Inputs
);
732 elsif Present
(Expressions
(Inputs
)) then
733 Input
:= First
(Expressions
(Inputs
));
734 while Present
(Input
) loop
741 Null_Seen
=> Null_Input_Seen
,
742 Non_Null_Seen
=> Non_Null_Input_Seen
);
747 -- Syntax error, always report
750 Error_Msg_N
("malformed input dependency list", Inputs
);
753 -- Process a solitary input
762 Null_Seen
=> Null_Input_Seen
,
763 Non_Null_Seen
=> Non_Null_Input_Seen
);
766 -- Detect an illegal dependency clause of the form
770 if Null_Output_Seen
and then Null_Input_Seen
then
772 ("null dependency clause cannot have a null input list",
775 end Analyze_Input_List
;
777 --------------------------
778 -- Analyze_Input_Output --
779 --------------------------
781 procedure Analyze_Input_Output
786 Seen
: in out Elist_Id
;
787 Null_Seen
: in out Boolean;
788 Non_Null_Seen
: in out Boolean)
790 procedure Current_Task_Instance_Seen
;
791 -- Set the appropriate global flag when the current instance of a
792 -- task unit is encountered.
794 --------------------------------
795 -- Current_Task_Instance_Seen --
796 --------------------------------
798 procedure Current_Task_Instance_Seen
is
801 Task_Input_Seen
:= True;
803 Task_Output_Seen
:= True;
805 end Current_Task_Instance_Seen
;
809 Is_Output
: constant Boolean := not Is_Input
;
813 -- Start of processing for Analyze_Input_Output
816 -- Multiple input or output items appear as an aggregate
818 if Nkind
(Item
) = N_Aggregate
then
819 if not Top_Level
then
820 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
822 elsif Present
(Component_Associations
(Item
)) then
824 ("nested dependency relations not allowed", Item
);
826 -- Recursively analyze the grouped items
828 elsif Present
(Expressions
(Item
)) then
829 Grouped
:= First
(Expressions
(Item
));
830 while Present
(Grouped
) loop
833 Is_Input
=> Is_Input
,
834 Self_Ref
=> Self_Ref
,
837 Null_Seen
=> Null_Seen
,
838 Non_Null_Seen
=> Non_Null_Seen
);
843 -- Syntax error, always report
846 Error_Msg_N
("malformed dependency list", Item
);
849 -- Process attribute 'Result in the context of a dependency clause
851 elsif Is_Attribute_Result
(Item
) then
852 Non_Null_Seen
:= True;
856 -- Attribute 'Result is allowed to appear on the output side of
857 -- a dependency clause (SPARK RM 6.1.5(6)).
860 SPARK_Msg_N
("function result cannot act as input", Item
);
864 ("cannot mix null and non-null dependency items", Item
);
870 -- Detect multiple uses of null in a single dependency list or
871 -- throughout the whole relation. Verify the placement of a null
872 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
874 elsif Nkind
(Item
) = N_Null
then
877 ("multiple null dependency relations not allowed", Item
);
879 elsif Non_Null_Seen
then
881 ("cannot mix null and non-null dependency items", Item
);
889 ("null output list must be the last clause in a "
890 & "dependency relation", Item
);
892 -- Catch a useless dependence of the form:
897 ("useless dependence, null depends on itself", Item
);
905 Non_Null_Seen
:= True;
908 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
912 Resolve_State
(Item
);
914 -- Find the entity of the item. If this is a renaming, climb
915 -- the renaming chain to reach the root object. Renamings of
916 -- non-entire objects do not yield an entity (Empty).
918 Item_Id
:= Entity_Of
(Item
);
920 if Present
(Item_Id
) then
924 if Ekind_In
(Item_Id
, E_Constant
,
929 -- Current instances of concurrent types
931 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
936 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
937 E_Generic_In_Parameter
,
945 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
947 -- The item denotes a concurrent type. Note that single
948 -- protected/task types are not considered here because
949 -- they behave as objects in the context of pragma
950 -- [Refined_]Depends.
952 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
954 -- This use is legal as long as the concurrent type is
955 -- the current instance of an enclosing type.
957 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
959 -- The dependence of a task unit on itself is
960 -- implicit and may or may not be explicitly
961 -- specified (SPARK RM 6.1.4).
963 if Ekind
(Item_Id
) = E_Task_Type
then
964 Current_Task_Instance_Seen
;
967 -- Otherwise this is not the current instance
971 ("invalid use of subtype mark in dependency "
975 -- The dependency of a task unit on itself is implicit
976 -- and may or may not be explicitly specified
979 elsif Is_Single_Task_Object
(Item_Id
)
980 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
982 Current_Task_Instance_Seen
;
985 -- Ensure that the item fulfills its role as input and/or
986 -- output as specified by pragma Global or the enclosing
989 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
991 -- Detect multiple uses of the same state, variable or
992 -- formal parameter. If this is not the case, add the
993 -- item to the list of processed relations.
995 if Contains
(Seen
, Item_Id
) then
997 ("duplicate use of item &", Item
, Item_Id
);
999 Append_New_Elmt
(Item_Id
, Seen
);
1002 -- Detect illegal use of an input related to a null
1003 -- output. Such input items cannot appear in other
1004 -- input lists (SPARK RM 6.1.5(13)).
1007 and then Null_Output_Seen
1008 and then Contains
(All_Inputs_Seen
, Item_Id
)
1011 ("input of a null output list cannot appear in "
1012 & "multiple input lists", Item
);
1015 -- Add an input or a self-referential output to the list
1016 -- of all processed inputs.
1018 if Is_Input
or else Self_Ref
then
1019 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1022 -- State related checks (SPARK RM 6.1.5(3))
1024 if Ekind
(Item_Id
) = E_Abstract_State
then
1026 -- Package and subprogram bodies are instantiated
1027 -- individually in a separate compiler pass. Due to
1028 -- this mode of instantiation, the refinement of a
1029 -- state may no longer be visible when a subprogram
1030 -- body contract is instantiated. Since the generic
1031 -- template is legal, do not perform this check in
1032 -- the instance to circumvent this oddity.
1034 if Is_Generic_Instance
(Spec_Id
) then
1037 -- An abstract state with visible refinement cannot
1038 -- appear in pragma [Refined_]Depends as its place
1039 -- must be taken by some of its constituents
1040 -- (SPARK RM 6.1.4(7)).
1042 elsif Has_Visible_Refinement
(Item_Id
) then
1044 ("cannot mention state & in dependence relation",
1046 SPARK_Msg_N
("\use its constituents instead", Item
);
1049 -- If the reference to the abstract state appears in
1050 -- an enclosing package body that will eventually
1051 -- refine the state, record the reference for future
1055 Record_Possible_Body_Reference
1056 (State_Id
=> Item_Id
,
1061 -- When the item renames an entire object, replace the
1062 -- item with a reference to the object.
1064 if Entity
(Item
) /= Item_Id
then
1066 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1070 -- Add the entity of the current item to the list of
1073 if Ekind
(Item_Id
) = E_Abstract_State
then
1074 Append_New_Elmt
(Item_Id
, States_Seen
);
1076 -- The variable may eventually become a constituent of a
1077 -- single protected/task type. Record the reference now
1078 -- and verify its legality when analyzing the contract of
1079 -- the variable (SPARK RM 9.3).
1081 elsif Ekind
(Item_Id
) = E_Variable
then
1082 Record_Possible_Part_Of_Reference
1087 if Ekind_In
(Item_Id
, E_Abstract_State
,
1090 and then Present
(Encapsulating_State
(Item_Id
))
1092 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1095 -- All other input/output items are illegal
1096 -- (SPARK RM 6.1.5(1)).
1100 ("item must denote parameter, variable, state or "
1101 & "current instance of concurren type", Item
);
1104 -- All other input/output items are illegal
1105 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1109 ("item must denote parameter, variable, state or current "
1110 & "instance of concurrent type", Item
);
1113 end Analyze_Input_Output
;
1121 Non_Null_Output_Seen
: Boolean := False;
1122 -- Flag used to check the legality of an output list
1124 -- Start of processing for Analyze_Dependency_Clause
1127 Inputs
:= Expression
(Clause
);
1130 -- An input list with a self-dependency appears as operator "+" where
1131 -- the actuals inputs are the right operand.
1133 if Nkind
(Inputs
) = N_Op_Plus
then
1134 Inputs
:= Right_Opnd
(Inputs
);
1138 -- Process the output_list of a dependency_clause
1140 Output
:= First
(Choices
(Clause
));
1141 while Present
(Output
) loop
1142 Analyze_Input_Output
1145 Self_Ref
=> Self_Ref
,
1147 Seen
=> All_Outputs_Seen
,
1148 Null_Seen
=> Null_Output_Seen
,
1149 Non_Null_Seen
=> Non_Null_Output_Seen
);
1154 -- Process the input_list of a dependency_clause
1156 Analyze_Input_List
(Inputs
);
1157 end Analyze_Dependency_Clause
;
1159 ---------------------------
1160 -- Check_Function_Return --
1161 ---------------------------
1163 procedure Check_Function_Return
is
1165 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1166 and then not Result_Seen
1169 ("result of & must appear in exactly one output list",
1172 end Check_Function_Return
;
1178 procedure Check_Role
1180 Item_Id
: Entity_Id
;
1185 (Item_Is_Input
: out Boolean;
1186 Item_Is_Output
: out Boolean);
1187 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1188 -- Item_Is_Output are set depending on the role.
1190 procedure Role_Error
1191 (Item_Is_Input
: Boolean;
1192 Item_Is_Output
: Boolean);
1193 -- Emit an error message concerning the incorrect use of Item in
1194 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1195 -- denote whether the item is an input and/or an output.
1202 (Item_Is_Input
: out Boolean;
1203 Item_Is_Output
: out Boolean)
1206 Item_Is_Input
:= False;
1207 Item_Is_Output
:= False;
1211 if Ekind
(Item_Id
) = E_Abstract_State
then
1213 -- When pragma Global is present, the mode of the state may be
1214 -- further constrained by setting a more restrictive mode.
1217 if Appears_In
(Subp_Inputs
, Item_Id
) then
1218 Item_Is_Input
:= True;
1221 if Appears_In
(Subp_Outputs
, Item_Id
) then
1222 Item_Is_Output
:= True;
1225 -- Otherwise the state has a default IN OUT mode
1228 Item_Is_Input
:= True;
1229 Item_Is_Output
:= True;
1234 elsif Ekind_In
(Item_Id
, E_Constant
,
1238 Item_Is_Input
:= True;
1242 elsif Ekind_In
(Item_Id
, E_Generic_In_Parameter
,
1245 Item_Is_Input
:= True;
1247 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
1250 Item_Is_Input
:= True;
1251 Item_Is_Output
:= True;
1253 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1254 if Scope
(Item_Id
) = Spec_Id
then
1256 -- An OUT parameter of the related subprogram has mode IN
1257 -- if its type is unconstrained or tagged because array
1258 -- bounds, discriminants or tags can be read.
1260 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1261 Item_Is_Input
:= True;
1264 Item_Is_Output
:= True;
1266 -- An OUT parameter of an enclosing subprogram behaves as a
1267 -- read-write variable in which case the mode is IN OUT.
1270 Item_Is_Input
:= True;
1271 Item_Is_Output
:= True;
1276 elsif Ekind
(Item_Id
) = E_Protected_Type
then
1278 -- A protected type acts as a formal parameter of mode IN when
1279 -- it applies to a protected function.
1281 if Ekind
(Spec_Id
) = E_Function
then
1282 Item_Is_Input
:= True;
1284 -- Otherwise the protected type acts as a formal of mode IN OUT
1287 Item_Is_Input
:= True;
1288 Item_Is_Output
:= True;
1293 elsif Ekind
(Item_Id
) = E_Task_Type
then
1294 Item_Is_Input
:= True;
1295 Item_Is_Output
:= True;
1299 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1301 -- When pragma Global is present, the mode of the variable may
1302 -- be further constrained by setting a more restrictive mode.
1306 -- A variable has mode IN when its type is unconstrained or
1307 -- tagged because array bounds, discriminants or tags can be
1310 if Appears_In
(Subp_Inputs
, Item_Id
)
1311 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1313 Item_Is_Input
:= True;
1316 if Appears_In
(Subp_Outputs
, Item_Id
) then
1317 Item_Is_Output
:= True;
1320 -- Otherwise the variable has a default IN OUT mode
1323 Item_Is_Input
:= True;
1324 Item_Is_Output
:= True;
1333 procedure Role_Error
1334 (Item_Is_Input
: Boolean;
1335 Item_Is_Output
: Boolean)
1337 Error_Msg
: Name_Id
;
1342 -- When the item is not part of the input and the output set of
1343 -- the related subprogram, then it appears as extra in pragma
1344 -- [Refined_]Depends.
1346 if not Item_Is_Input
and then not Item_Is_Output
then
1347 Add_Item_To_Name_Buffer
(Item_Id
);
1348 Add_Str_To_Name_Buffer
1349 (" & cannot appear in dependence relation");
1351 Error_Msg
:= Name_Find
;
1352 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1354 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1356 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1357 & "set of subprogram %"), Item
, Item_Id
);
1359 -- The mode of the item and its role in pragma [Refined_]Depends
1360 -- are in conflict. Construct a detailed message explaining the
1361 -- illegality (SPARK RM 6.1.5(5-6)).
1364 if Item_Is_Input
then
1365 Add_Str_To_Name_Buffer
("read-only");
1367 Add_Str_To_Name_Buffer
("write-only");
1370 Add_Char_To_Name_Buffer
(' ');
1371 Add_Item_To_Name_Buffer
(Item_Id
);
1372 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1374 if Item_Is_Input
then
1375 Add_Str_To_Name_Buffer
("output");
1377 Add_Str_To_Name_Buffer
("input");
1380 Add_Str_To_Name_Buffer
(" in dependence relation");
1381 Error_Msg
:= Name_Find
;
1382 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1388 Item_Is_Input
: Boolean;
1389 Item_Is_Output
: Boolean;
1391 -- Start of processing for Check_Role
1394 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1399 if not Item_Is_Input
then
1400 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1403 -- Self-referential item
1406 if not Item_Is_Input
or else not Item_Is_Output
then
1407 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1412 elsif not Item_Is_Output
then
1413 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1421 procedure Check_Usage
1422 (Subp_Items
: Elist_Id
;
1423 Used_Items
: Elist_Id
;
1426 procedure Usage_Error
(Item_Id
: Entity_Id
);
1427 -- Emit an error concerning the illegal usage of an item
1433 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1434 Error_Msg
: Name_Id
;
1441 -- Unconstrained and tagged items are not part of the explicit
1442 -- input set of the related subprogram, they do not have to be
1443 -- present in a dependence relation and should not be flagged
1444 -- (SPARK RM 6.1.5(8)).
1446 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1449 Add_Item_To_Name_Buffer
(Item_Id
);
1450 Add_Str_To_Name_Buffer
1451 (" & is missing from input dependence list");
1453 Error_Msg
:= Name_Find
;
1454 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1457 -- Output case (SPARK RM 6.1.5(10))
1462 Add_Item_To_Name_Buffer
(Item_Id
);
1463 Add_Str_To_Name_Buffer
1464 (" & is missing from output dependence list");
1466 Error_Msg
:= Name_Find
;
1467 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1475 Item_Id
: Entity_Id
;
1477 -- Start of processing for Check_Usage
1480 if No
(Subp_Items
) then
1484 -- Each input or output of the subprogram must appear in a dependency
1487 Elmt
:= First_Elmt
(Subp_Items
);
1488 while Present
(Elmt
) loop
1489 Item
:= Node
(Elmt
);
1491 if Nkind
(Item
) = N_Defining_Identifier
then
1494 Item_Id
:= Entity_Of
(Item
);
1497 -- The item does not appear in a dependency
1499 if Present
(Item_Id
)
1500 and then not Contains
(Used_Items
, Item_Id
)
1502 if Is_Formal
(Item_Id
) then
1503 Usage_Error
(Item_Id
);
1505 -- The current instance of a protected type behaves as a formal
1506 -- parameter (SPARK RM 6.1.4).
1508 elsif Ekind
(Item_Id
) = E_Protected_Type
1509 or else Is_Single_Protected_Object
(Item_Id
)
1511 Usage_Error
(Item_Id
);
1513 -- The current instance of a task type behaves as a formal
1514 -- parameter (SPARK RM 6.1.4).
1516 elsif Ekind
(Item_Id
) = E_Task_Type
1517 or else Is_Single_Task_Object
(Item_Id
)
1519 -- The dependence of a task unit on itself is implicit and
1520 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1521 -- Emit an error if only one input/output is present.
1523 if Task_Input_Seen
/= Task_Output_Seen
then
1524 Usage_Error
(Item_Id
);
1527 -- States and global objects are not used properly only when
1528 -- the subprogram is subject to pragma Global.
1530 elsif Global_Seen
then
1531 Usage_Error
(Item_Id
);
1539 ----------------------
1540 -- Normalize_Clause --
1541 ----------------------
1543 procedure Normalize_Clause
(Clause
: Node_Id
) is
1544 procedure Create_Or_Modify_Clause
1550 Multiple
: Boolean);
1551 -- Create a brand new clause to represent the self-reference or
1552 -- modify the input and/or output lists of an existing clause. Output
1553 -- denotes a self-referencial output. Outputs is the output list of a
1554 -- clause. Inputs is the input list of a clause. After denotes the
1555 -- clause after which the new clause is to be inserted. Flag In_Place
1556 -- should be set when normalizing the last output of an output list.
1557 -- Flag Multiple should be set when Output comes from a list with
1560 -----------------------------
1561 -- Create_Or_Modify_Clause --
1562 -----------------------------
1564 procedure Create_Or_Modify_Clause
1572 procedure Propagate_Output
1575 -- Handle the various cases of output propagation to the input
1576 -- list. Output denotes a self-referencial output item. Inputs
1577 -- is the input list of a clause.
1579 ----------------------
1580 -- Propagate_Output --
1581 ----------------------
1583 procedure Propagate_Output
1587 function In_Input_List
1589 Inputs
: List_Id
) return Boolean;
1590 -- Determine whether a particulat item appears in the input
1591 -- list of a clause.
1597 function In_Input_List
1599 Inputs
: List_Id
) return Boolean
1604 Elmt
:= First
(Inputs
);
1605 while Present
(Elmt
) loop
1606 if Entity_Of
(Elmt
) = Item
then
1618 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1621 -- Start of processing for Propagate_Output
1624 -- The clause is of the form:
1626 -- (Output =>+ null)
1628 -- Remove null input and replace it with a copy of the output:
1630 -- (Output => Output)
1632 if Nkind
(Inputs
) = N_Null
then
1633 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1635 -- The clause is of the form:
1637 -- (Output =>+ (Input1, ..., InputN))
1639 -- Determine whether the output is not already mentioned in the
1640 -- input list and if not, add it to the list of inputs:
1642 -- (Output => (Output, Input1, ..., InputN))
1644 elsif Nkind
(Inputs
) = N_Aggregate
then
1645 Grouped
:= Expressions
(Inputs
);
1647 if not In_Input_List
1651 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1654 -- The clause is of the form:
1656 -- (Output =>+ Input)
1658 -- If the input does not mention the output, group the two
1661 -- (Output => (Output, Input))
1663 elsif Entity_Of
(Inputs
) /= Output_Id
then
1665 Make_Aggregate
(Loc
,
1666 Expressions
=> New_List
(
1667 New_Copy_Tree
(Output
),
1668 New_Copy_Tree
(Inputs
))));
1670 end Propagate_Output
;
1674 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1675 New_Clause
: Node_Id
;
1677 -- Start of processing for Create_Or_Modify_Clause
1680 -- A null output depending on itself does not require any
1683 if Nkind
(Output
) = N_Null
then
1686 -- A function result cannot depend on itself because it cannot
1687 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1689 elsif Is_Attribute_Result
(Output
) then
1690 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1694 -- When performing the transformation in place, simply add the
1695 -- output to the list of inputs (if not already there). This
1696 -- case arises when dealing with the last output of an output
1697 -- list. Perform the normalization in place to avoid generating
1698 -- a malformed tree.
1701 Propagate_Output
(Output
, Inputs
);
1703 -- A list with multiple outputs is slowly trimmed until only
1704 -- one element remains. When this happens, replace aggregate
1705 -- with the element itself.
1709 Rewrite
(Outputs
, Output
);
1715 -- Unchain the output from its output list as it will appear in
1716 -- a new clause. Note that we cannot simply rewrite the output
1717 -- as null because this will violate the semantics of pragma
1722 -- Generate a new clause of the form:
1723 -- (Output => Inputs)
1726 Make_Component_Association
(Loc
,
1727 Choices
=> New_List
(Output
),
1728 Expression
=> New_Copy_Tree
(Inputs
));
1730 -- The new clause contains replicated content that has already
1731 -- been analyzed. There is not need to reanalyze or renormalize
1734 Set_Analyzed
(New_Clause
);
1737 (Output
=> First
(Choices
(New_Clause
)),
1738 Inputs
=> Expression
(New_Clause
));
1740 Insert_After
(After
, New_Clause
);
1742 end Create_Or_Modify_Clause
;
1746 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1748 Last_Output
: Node_Id
;
1749 Next_Output
: Node_Id
;
1752 -- Start of processing for Normalize_Clause
1755 -- A self-dependency appears as operator "+". Remove the "+" from the
1756 -- tree by moving the real inputs to their proper place.
1758 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1759 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1760 Inputs
:= Expression
(Clause
);
1762 -- Multiple outputs appear as an aggregate
1764 if Nkind
(Outputs
) = N_Aggregate
then
1765 Last_Output
:= Last
(Expressions
(Outputs
));
1767 Output
:= First
(Expressions
(Outputs
));
1768 while Present
(Output
) loop
1770 -- Normalization may remove an output from its list,
1771 -- preserve the subsequent output now.
1773 Next_Output
:= Next
(Output
);
1775 Create_Or_Modify_Clause
1780 In_Place
=> Output
= Last_Output
,
1783 Output
:= Next_Output
;
1789 Create_Or_Modify_Clause
1798 end Normalize_Clause
;
1802 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1803 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1807 Last_Clause
: Node_Id
;
1808 Restore_Scope
: Boolean := False;
1810 -- Start of processing for Analyze_Depends_In_Decl_Part
1813 -- Do not analyze the pragma multiple times
1815 if Is_Analyzed_Pragma
(N
) then
1819 -- Empty dependency list
1821 if Nkind
(Deps
) = N_Null
then
1823 -- Gather all states, objects and formal parameters that the
1824 -- subprogram may depend on. These items are obtained from the
1825 -- parameter profile or pragma [Refined_]Global (if available).
1827 Collect_Subprogram_Inputs_Outputs
1828 (Subp_Id
=> Subp_Id
,
1829 Subp_Inputs
=> Subp_Inputs
,
1830 Subp_Outputs
=> Subp_Outputs
,
1831 Global_Seen
=> Global_Seen
);
1833 -- Verify that every input or output of the subprogram appear in a
1836 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1837 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1838 Check_Function_Return
;
1840 -- Dependency clauses appear as component associations of an aggregate
1842 elsif Nkind
(Deps
) = N_Aggregate
then
1844 -- Do not attempt to perform analysis of a syntactically illegal
1845 -- clause as this will lead to misleading errors.
1847 if Has_Extra_Parentheses
(Deps
) then
1851 if Present
(Component_Associations
(Deps
)) then
1852 Last_Clause
:= Last
(Component_Associations
(Deps
));
1854 -- Gather all states, objects and formal parameters that the
1855 -- subprogram may depend on. These items are obtained from the
1856 -- parameter profile or pragma [Refined_]Global (if available).
1858 Collect_Subprogram_Inputs_Outputs
1859 (Subp_Id
=> Subp_Id
,
1860 Subp_Inputs
=> Subp_Inputs
,
1861 Subp_Outputs
=> Subp_Outputs
,
1862 Global_Seen
=> Global_Seen
);
1864 -- When pragma [Refined_]Depends appears on a single concurrent
1865 -- type, it is relocated to the anonymous object.
1867 if Is_Single_Concurrent_Object
(Spec_Id
) then
1870 -- Ensure that the formal parameters are visible when analyzing
1871 -- all clauses. This falls out of the general rule of aspects
1872 -- pertaining to subprogram declarations.
1874 elsif not In_Open_Scopes
(Spec_Id
) then
1875 Restore_Scope
:= True;
1876 Push_Scope
(Spec_Id
);
1878 if Ekind
(Spec_Id
) = E_Task_Type
then
1879 if Has_Discriminants
(Spec_Id
) then
1880 Install_Discriminants
(Spec_Id
);
1883 elsif Is_Generic_Subprogram
(Spec_Id
) then
1884 Install_Generic_Formals
(Spec_Id
);
1887 Install_Formals
(Spec_Id
);
1891 Clause
:= First
(Component_Associations
(Deps
));
1892 while Present
(Clause
) loop
1893 Errors
:= Serious_Errors_Detected
;
1895 -- The normalization mechanism may create extra clauses that
1896 -- contain replicated input and output names. There is no need
1897 -- to reanalyze them.
1899 if not Analyzed
(Clause
) then
1900 Set_Analyzed
(Clause
);
1902 Analyze_Dependency_Clause
1904 Is_Last
=> Clause
= Last_Clause
);
1907 -- Do not normalize a clause if errors were detected (count
1908 -- of Serious_Errors has increased) because the inputs and/or
1909 -- outputs may denote illegal items. Normalization is disabled
1910 -- in ASIS mode as it alters the tree by introducing new nodes
1911 -- similar to expansion.
1913 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1914 Normalize_Clause
(Clause
);
1920 if Restore_Scope
then
1924 -- Verify that every input or output of the subprogram appear in a
1927 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1928 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1929 Check_Function_Return
;
1931 -- The dependency list is malformed. This is a syntax error, always
1935 Error_Msg_N
("malformed dependency relation", Deps
);
1939 -- The top level dependency relation is malformed. This is a syntax
1940 -- error, always report.
1943 Error_Msg_N
("malformed dependency relation", Deps
);
1947 -- Ensure that a state and a corresponding constituent do not appear
1948 -- together in pragma [Refined_]Depends.
1950 Check_State_And_Constituent_Use
1951 (States
=> States_Seen
,
1952 Constits
=> Constits_Seen
,
1956 Set_Is_Analyzed_Pragma
(N
);
1957 end Analyze_Depends_In_Decl_Part
;
1959 --------------------------------------------
1960 -- Analyze_External_Property_In_Decl_Part --
1961 --------------------------------------------
1963 procedure Analyze_External_Property_In_Decl_Part
1965 Expr_Val
: out Boolean)
1967 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1968 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
1969 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
1975 -- Do not analyze the pragma multiple times
1977 if Is_Analyzed_Pragma
(N
) then
1981 Error_Msg_Name_1
:= Pragma_Name
(N
);
1983 -- An external property pragma must apply to an effectively volatile
1984 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1985 -- The check is performed at the end of the declarative region due to a
1986 -- possible out-of-order arrangement of pragmas:
1989 -- pragma Async_Readers (Obj);
1990 -- pragma Volatile (Obj);
1992 if not Is_Effectively_Volatile
(Obj_Id
) then
1994 ("external property % must apply to a volatile object", N
);
1997 -- Ensure that the Boolean expression (if present) is static. A missing
1998 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2002 if Present
(Arg1
) then
2003 Expr
:= Get_Pragma_Arg
(Arg1
);
2005 if Is_OK_Static_Expression
(Expr
) then
2006 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2010 Set_Is_Analyzed_Pragma
(N
);
2011 end Analyze_External_Property_In_Decl_Part
;
2013 ---------------------------------
2014 -- Analyze_Global_In_Decl_Part --
2015 ---------------------------------
2017 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2018 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2019 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2020 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2022 Constits_Seen
: Elist_Id
:= No_Elist
;
2023 -- A list containing the entities of all constituents processed so far.
2024 -- It aids in detecting illegal usage of a state and a corresponding
2025 -- constituent in pragma [Refinde_]Global.
2027 Seen
: Elist_Id
:= No_Elist
;
2028 -- A list containing the entities of all the items processed so far. It
2029 -- plays a role in detecting distinct entities.
2031 States_Seen
: Elist_Id
:= No_Elist
;
2032 -- A list containing the entities of all states processed so far. It
2033 -- helps in detecting illegal usage of a state and a corresponding
2034 -- constituent in pragma [Refined_]Global.
2036 In_Out_Seen
: Boolean := False;
2037 Input_Seen
: Boolean := False;
2038 Output_Seen
: Boolean := False;
2039 Proof_Seen
: Boolean := False;
2040 -- Flags used to verify the consistency of modes
2042 procedure Analyze_Global_List
2044 Global_Mode
: Name_Id
:= Name_Input
);
2045 -- Verify the legality of a single global list declaration. Global_Mode
2046 -- denotes the current mode in effect.
2048 -------------------------
2049 -- Analyze_Global_List --
2050 -------------------------
2052 procedure Analyze_Global_List
2054 Global_Mode
: Name_Id
:= Name_Input
)
2056 procedure Analyze_Global_Item
2058 Global_Mode
: Name_Id
);
2059 -- Verify the legality of a single global item declaration denoted by
2060 -- Item. Global_Mode denotes the current mode in effect.
2062 procedure Check_Duplicate_Mode
2064 Status
: in out Boolean);
2065 -- Flag Status denotes whether a particular mode has been seen while
2066 -- processing a global list. This routine verifies that Mode is not a
2067 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2069 procedure Check_Mode_Restriction_In_Enclosing_Context
2071 Item_Id
: Entity_Id
);
2072 -- Verify that an item of mode In_Out or Output does not appear as an
2073 -- input in the Global aspect of an enclosing subprogram. If this is
2074 -- the case, emit an error. Item and Item_Id are respectively the
2075 -- item and its entity.
2077 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2078 -- Mode denotes either In_Out or Output. Depending on the kind of the
2079 -- related subprogram, emit an error if those two modes apply to a
2080 -- function (SPARK RM 6.1.4(10)).
2082 -------------------------
2083 -- Analyze_Global_Item --
2084 -------------------------
2086 procedure Analyze_Global_Item
2088 Global_Mode
: Name_Id
)
2090 Item_Id
: Entity_Id
;
2093 -- Detect one of the following cases
2095 -- with Global => (null, Name)
2096 -- with Global => (Name_1, null, Name_2)
2097 -- with Global => (Name, null)
2099 if Nkind
(Item
) = N_Null
then
2100 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2105 Resolve_State
(Item
);
2107 -- Find the entity of the item. If this is a renaming, climb the
2108 -- renaming chain to reach the root object. Renamings of non-
2109 -- entire objects do not yield an entity (Empty).
2111 Item_Id
:= Entity_Of
(Item
);
2113 if Present
(Item_Id
) then
2115 -- A global item may denote a formal parameter of an enclosing
2116 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2117 -- provide a better error diagnostic.
2119 if Is_Formal
(Item_Id
) then
2120 if Scope
(Item_Id
) = Spec_Id
then
2122 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2123 & "parameter of subprogram &"), Item
, Spec_Id
);
2127 -- A global item may denote a concurrent type as long as it is
2128 -- the current instance of an enclosing protected or task type
2129 -- (SPARK RM 6.1.4).
2131 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2132 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2134 -- Pragma [Refined_]Global associated with a protected
2135 -- subprogram cannot mention the current instance of a
2136 -- protected type because the instance behaves as a
2137 -- formal parameter.
2139 if Ekind
(Item_Id
) = E_Protected_Type
then
2140 Error_Msg_Name_1
:= Chars
(Item_Id
);
2142 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2143 & "cannot reference current instance of protected "
2144 & "type %"), Item
, Spec_Id
);
2147 -- Pragma [Refined_]Global associated with a task type
2148 -- cannot mention the current instance of a task type
2149 -- because the instance behaves as a formal parameter.
2151 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2152 Error_Msg_Name_1
:= Chars
(Item_Id
);
2154 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2155 & "cannot reference current instance of task type "
2156 & "%"), Item
, Spec_Id
);
2160 -- Otherwise the global item denotes a subtype mark that is
2161 -- not a current instance.
2165 ("invalid use of subtype mark in global list", Item
);
2169 -- A global item may denote the anonymous object created for a
2170 -- single protected/task type as long as the current instance
2171 -- is the same single type (SPARK RM 6.1.4).
2173 elsif Is_Single_Concurrent_Object
(Item_Id
)
2174 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
2176 -- Pragma [Refined_]Global associated with a protected
2177 -- subprogram cannot mention the current instance of a
2178 -- protected type because the instance behaves as a formal
2181 if Is_Single_Protected_Object
(Item_Id
) then
2182 Error_Msg_Name_1
:= Chars
(Item_Id
);
2184 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2185 & "reference current instance of protected type %"),
2189 -- Pragma [Refined_]Global associated with a task type
2190 -- cannot mention the current instance of a task type
2191 -- because the instance behaves as a formal parameter.
2193 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2194 Error_Msg_Name_1
:= Chars
(Item_Id
);
2196 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2197 & "reference current instance of task type %"),
2202 -- A formal object may act as a global item inside a generic
2204 elsif Is_Formal_Object
(Item_Id
) then
2207 -- The only legal references are those to abstract states,
2208 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2210 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2217 ("global item must denote object, state or current "
2218 & "instance of concurrent type", Item
);
2222 -- State related checks
2224 if Ekind
(Item_Id
) = E_Abstract_State
then
2226 -- Package and subprogram bodies are instantiated
2227 -- individually in a separate compiler pass. Due to this
2228 -- mode of instantiation, the refinement of a state may
2229 -- no longer be visible when a subprogram body contract
2230 -- is instantiated. Since the generic template is legal,
2231 -- do not perform this check in the instance to circumvent
2234 if Is_Generic_Instance
(Spec_Id
) then
2237 -- An abstract state with visible refinement cannot appear
2238 -- in pragma [Refined_]Global as its place must be taken by
2239 -- some of its constituents (SPARK RM 6.1.4(7)).
2241 elsif Has_Visible_Refinement
(Item_Id
) then
2243 ("cannot mention state & in global refinement",
2245 SPARK_Msg_N
("\use its constituents instead", Item
);
2248 -- An external state cannot appear as a global item of a
2249 -- nonvolatile function (SPARK RM 7.1.3(8)).
2251 elsif Is_External_State
(Item_Id
)
2252 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2253 and then not Is_Volatile_Function
(Spec_Id
)
2256 ("external state & cannot act as global item of "
2257 & "nonvolatile function", Item
, Item_Id
);
2260 -- If the reference to the abstract state appears in an
2261 -- enclosing package body that will eventually refine the
2262 -- state, record the reference for future checks.
2265 Record_Possible_Body_Reference
2266 (State_Id
=> Item_Id
,
2270 -- Constant related checks
2272 elsif Ekind
(Item_Id
) = E_Constant
then
2274 -- A constant is a read-only item, therefore it cannot act
2277 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2279 ("constant & cannot act as output", Item
, Item_Id
);
2283 -- Discriminant related checks
2285 elsif Ekind
(Item_Id
) = E_Discriminant
then
2287 -- A discriminant is a read-only item, therefore it cannot
2288 -- act as an output.
2290 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2292 ("discriminant & cannot act as output", Item
, Item_Id
);
2296 -- Loop parameter related checks
2298 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2300 -- A loop parameter is a read-only item, therefore it cannot
2301 -- act as an output.
2303 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2305 ("loop parameter & cannot act as output",
2310 -- Variable related checks. These are only relevant when
2311 -- SPARK_Mode is on as they are not standard Ada legality
2314 elsif SPARK_Mode
= On
2315 and then Ekind
(Item_Id
) = E_Variable
2316 and then Is_Effectively_Volatile
(Item_Id
)
2318 -- An effectively volatile object cannot appear as a global
2319 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2321 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2322 and then not Is_Volatile_Function
(Spec_Id
)
2325 ("volatile object & cannot act as global item of a "
2326 & "function", Item
, Item_Id
);
2329 -- An effectively volatile object with external property
2330 -- Effective_Reads set to True must have mode Output or
2331 -- In_Out (SPARK RM 7.1.3(10)).
2333 elsif Effective_Reads_Enabled
(Item_Id
)
2334 and then Global_Mode
= Name_Input
2337 ("volatile object & with property Effective_Reads must "
2338 & "have mode In_Out or Output", Item
, Item_Id
);
2343 -- When the item renames an entire object, replace the item
2344 -- with a reference to the object.
2346 if Entity
(Item
) /= Item_Id
then
2347 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2351 -- Some form of illegal construct masquerading as a name
2352 -- (SPARK RM 6.1.4(4)).
2356 ("global item must denote object, state or current instance "
2357 & "of concurrent type", Item
);
2361 -- Verify that an output does not appear as an input in an
2362 -- enclosing subprogram.
2364 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2365 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2368 -- The same entity might be referenced through various way.
2369 -- Check the entity of the item rather than the item itself
2370 -- (SPARK RM 6.1.4(10)).
2372 if Contains
(Seen
, Item_Id
) then
2373 SPARK_Msg_N
("duplicate global item", Item
);
2375 -- Add the entity of the current item to the list of processed
2379 Append_New_Elmt
(Item_Id
, Seen
);
2381 if Ekind
(Item_Id
) = E_Abstract_State
then
2382 Append_New_Elmt
(Item_Id
, States_Seen
);
2384 -- The variable may eventually become a constituent of a single
2385 -- protected/task type. Record the reference now and verify its
2386 -- legality when analyzing the contract of the variable
2389 elsif Ekind
(Item_Id
) = E_Variable
then
2390 Record_Possible_Part_Of_Reference
2395 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2396 and then Present
(Encapsulating_State
(Item_Id
))
2398 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2401 end Analyze_Global_Item
;
2403 --------------------------
2404 -- Check_Duplicate_Mode --
2405 --------------------------
2407 procedure Check_Duplicate_Mode
2409 Status
: in out Boolean)
2413 SPARK_Msg_N
("duplicate global mode", Mode
);
2417 end Check_Duplicate_Mode
;
2419 -------------------------------------------------
2420 -- Check_Mode_Restriction_In_Enclosing_Context --
2421 -------------------------------------------------
2423 procedure Check_Mode_Restriction_In_Enclosing_Context
2425 Item_Id
: Entity_Id
)
2427 Context
: Entity_Id
;
2429 Inputs
: Elist_Id
:= No_Elist
;
2430 Outputs
: Elist_Id
:= No_Elist
;
2433 -- Traverse the scope stack looking for enclosing subprograms
2434 -- subject to pragma [Refined_]Global.
2436 Context
:= Scope
(Subp_Id
);
2437 while Present
(Context
) and then Context
/= Standard_Standard
loop
2438 if Is_Subprogram
(Context
)
2440 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2442 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2444 Collect_Subprogram_Inputs_Outputs
2445 (Subp_Id
=> Context
,
2446 Subp_Inputs
=> Inputs
,
2447 Subp_Outputs
=> Outputs
,
2448 Global_Seen
=> Dummy
);
2450 -- The item is classified as In_Out or Output but appears as
2451 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2453 if Appears_In
(Inputs
, Item_Id
)
2454 and then not Appears_In
(Outputs
, Item_Id
)
2457 ("global item & cannot have mode In_Out or Output",
2461 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2462 & "subprogram &"), Item
, Context
);
2464 -- Stop the traversal once an error has been detected
2470 Context
:= Scope
(Context
);
2472 end Check_Mode_Restriction_In_Enclosing_Context
;
2474 ----------------------------------------
2475 -- Check_Mode_Restriction_In_Function --
2476 ----------------------------------------
2478 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2480 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2482 ("global mode & is not applicable to functions", Mode
);
2484 end Check_Mode_Restriction_In_Function
;
2492 -- Start of processing for Analyze_Global_List
2495 if Nkind
(List
) = N_Null
then
2496 Set_Analyzed
(List
);
2498 -- Single global item declaration
2500 elsif Nkind_In
(List
, N_Expanded_Name
,
2502 N_Selected_Component
)
2504 Analyze_Global_Item
(List
, Global_Mode
);
2506 -- Simple global list or moded global list declaration
2508 elsif Nkind
(List
) = N_Aggregate
then
2509 Set_Analyzed
(List
);
2511 -- The declaration of a simple global list appear as a collection
2514 if Present
(Expressions
(List
)) then
2515 if Present
(Component_Associations
(List
)) then
2517 ("cannot mix moded and non-moded global lists", List
);
2520 Item
:= First
(Expressions
(List
));
2521 while Present
(Item
) loop
2522 Analyze_Global_Item
(Item
, Global_Mode
);
2526 -- The declaration of a moded global list appears as a collection
2527 -- of component associations where individual choices denote
2530 elsif Present
(Component_Associations
(List
)) then
2531 if Present
(Expressions
(List
)) then
2533 ("cannot mix moded and non-moded global lists", List
);
2536 Assoc
:= First
(Component_Associations
(List
));
2537 while Present
(Assoc
) loop
2538 Mode
:= First
(Choices
(Assoc
));
2540 if Nkind
(Mode
) = N_Identifier
then
2541 if Chars
(Mode
) = Name_In_Out
then
2542 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2543 Check_Mode_Restriction_In_Function
(Mode
);
2545 elsif Chars
(Mode
) = Name_Input
then
2546 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2548 elsif Chars
(Mode
) = Name_Output
then
2549 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2550 Check_Mode_Restriction_In_Function
(Mode
);
2552 elsif Chars
(Mode
) = Name_Proof_In
then
2553 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2556 SPARK_Msg_N
("invalid mode selector", Mode
);
2560 SPARK_Msg_N
("invalid mode selector", Mode
);
2563 -- Items in a moded list appear as a collection of
2564 -- expressions. Reuse the existing machinery to analyze
2568 (List
=> Expression
(Assoc
),
2569 Global_Mode
=> Chars
(Mode
));
2577 raise Program_Error
;
2580 -- Any other attempt to declare a global item is illegal. This is a
2581 -- syntax error, always report.
2584 Error_Msg_N
("malformed global list", List
);
2586 end Analyze_Global_List
;
2590 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2592 Restore_Scope
: Boolean := False;
2594 -- Start of processing for Analyze_Global_In_Decl_Part
2597 -- Do not analyze the pragma multiple times
2599 if Is_Analyzed_Pragma
(N
) then
2603 -- There is nothing to be done for a null global list
2605 if Nkind
(Items
) = N_Null
then
2606 Set_Analyzed
(Items
);
2608 -- Analyze the various forms of global lists and items. Note that some
2609 -- of these may be malformed in which case the analysis emits error
2613 -- When pragma [Refined_]Global appears on a single concurrent type,
2614 -- it is relocated to the anonymous object.
2616 if Is_Single_Concurrent_Object
(Spec_Id
) then
2619 -- Ensure that the formal parameters are visible when processing an
2620 -- item. This falls out of the general rule of aspects pertaining to
2621 -- subprogram declarations.
2623 elsif not In_Open_Scopes
(Spec_Id
) then
2624 Restore_Scope
:= True;
2625 Push_Scope
(Spec_Id
);
2627 if Ekind
(Spec_Id
) = E_Task_Type
then
2628 if Has_Discriminants
(Spec_Id
) then
2629 Install_Discriminants
(Spec_Id
);
2632 elsif Is_Generic_Subprogram
(Spec_Id
) then
2633 Install_Generic_Formals
(Spec_Id
);
2636 Install_Formals
(Spec_Id
);
2640 Analyze_Global_List
(Items
);
2642 if Restore_Scope
then
2647 -- Ensure that a state and a corresponding constituent do not appear
2648 -- together in pragma [Refined_]Global.
2650 Check_State_And_Constituent_Use
2651 (States
=> States_Seen
,
2652 Constits
=> Constits_Seen
,
2655 Set_Is_Analyzed_Pragma
(N
);
2656 end Analyze_Global_In_Decl_Part
;
2658 --------------------------------------------
2659 -- Analyze_Initial_Condition_In_Decl_Part --
2660 --------------------------------------------
2662 -- WARNING: This routine manages Ghost regions. Return statements must be
2663 -- replaced by gotos which jump to the end of the routine and restore the
2666 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2667 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2668 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2669 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2671 Mode
: Ghost_Mode_Type
;
2674 -- Do not analyze the pragma multiple times
2676 if Is_Analyzed_Pragma
(N
) then
2680 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2681 -- analysis of the pragma, the Ghost mode at point of declaration and
2682 -- point of analysis may not necessarily be the same. Use the mode in
2683 -- effect at the point of declaration.
2685 Set_Ghost_Mode
(N
, Mode
);
2687 -- The expression is preanalyzed because it has not been moved to its
2688 -- final place yet. A direct analysis may generate side effects and this
2689 -- is not desired at this point.
2691 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2692 Set_Is_Analyzed_Pragma
(N
);
2694 Restore_Ghost_Mode
(Mode
);
2695 end Analyze_Initial_Condition_In_Decl_Part
;
2697 --------------------------------------
2698 -- Analyze_Initializes_In_Decl_Part --
2699 --------------------------------------
2701 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2702 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2703 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2705 Constits_Seen
: Elist_Id
:= No_Elist
;
2706 -- A list containing the entities of all constituents processed so far.
2707 -- It aids in detecting illegal usage of a state and a corresponding
2708 -- constituent in pragma Initializes.
2710 Items_Seen
: Elist_Id
:= No_Elist
;
2711 -- A list of all initialization items processed so far. This list is
2712 -- used to detect duplicate items.
2714 Non_Null_Seen
: Boolean := False;
2715 Null_Seen
: Boolean := False;
2716 -- Flags used to check the legality of a null initialization list
2718 States_And_Objs
: Elist_Id
:= No_Elist
;
2719 -- A list of all abstract states and objects declared in the visible
2720 -- declarations of the related package. This list is used to detect the
2721 -- legality of initialization items.
2723 States_Seen
: Elist_Id
:= No_Elist
;
2724 -- A list containing the entities of all states processed so far. It
2725 -- helps in detecting illegal usage of a state and a corresponding
2726 -- constituent in pragma Initializes.
2728 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2729 -- Verify the legality of a single initialization item
2731 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2732 -- Verify the legality of a single initialization item followed by a
2733 -- list of input items.
2735 procedure Collect_States_And_Objects
;
2736 -- Inspect the visible declarations of the related package and gather
2737 -- the entities of all abstract states and objects in States_And_Objs.
2739 ---------------------------------
2740 -- Analyze_Initialization_Item --
2741 ---------------------------------
2743 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2744 Item_Id
: Entity_Id
;
2747 -- Null initialization list
2749 if Nkind
(Item
) = N_Null
then
2751 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2753 elsif Non_Null_Seen
then
2755 ("cannot mix null and non-null initialization items", Item
);
2760 -- Initialization item
2763 Non_Null_Seen
:= True;
2767 ("cannot mix null and non-null initialization items", Item
);
2771 Resolve_State
(Item
);
2773 if Is_Entity_Name
(Item
) then
2774 Item_Id
:= Entity_Of
(Item
);
2776 if Ekind_In
(Item_Id
, E_Abstract_State
,
2780 -- The state or variable must be declared in the visible
2781 -- declarations of the package (SPARK RM 7.1.5(7)).
2783 if not Contains
(States_And_Objs
, Item_Id
) then
2784 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2786 ("initialization item & must appear in the visible "
2787 & "declarations of package %", Item
, Item_Id
);
2789 -- Detect a duplicate use of the same initialization item
2790 -- (SPARK RM 7.1.5(5)).
2792 elsif Contains
(Items_Seen
, Item_Id
) then
2793 SPARK_Msg_N
("duplicate initialization item", Item
);
2795 -- The item is legal, add it to the list of processed states
2799 Append_New_Elmt
(Item_Id
, Items_Seen
);
2801 if Ekind
(Item_Id
) = E_Abstract_State
then
2802 Append_New_Elmt
(Item_Id
, States_Seen
);
2805 if Present
(Encapsulating_State
(Item_Id
)) then
2806 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2810 -- The item references something that is not a state or object
2811 -- (SPARK RM 7.1.5(3)).
2815 ("initialization item must denote object or state", Item
);
2818 -- Some form of illegal construct masquerading as a name
2819 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2823 ("initialization item must denote object or state", Item
);
2826 end Analyze_Initialization_Item
;
2828 ---------------------------------------------
2829 -- Analyze_Initialization_Item_With_Inputs --
2830 ---------------------------------------------
2832 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2833 Inputs_Seen
: Elist_Id
:= No_Elist
;
2834 -- A list of all inputs processed so far. This list is used to detect
2835 -- duplicate uses of an input.
2837 Non_Null_Seen
: Boolean := False;
2838 Null_Seen
: Boolean := False;
2839 -- Flags used to check the legality of an input list
2841 procedure Analyze_Input_Item
(Input
: Node_Id
);
2842 -- Verify the legality of a single input item
2844 ------------------------
2845 -- Analyze_Input_Item --
2846 ------------------------
2848 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2849 Input_Id
: Entity_Id
;
2850 Input_OK
: Boolean := True;
2855 if Nkind
(Input
) = N_Null
then
2858 ("multiple null initializations not allowed", Item
);
2860 elsif Non_Null_Seen
then
2862 ("cannot mix null and non-null initialization item", Item
);
2870 Non_Null_Seen
:= True;
2874 ("cannot mix null and non-null initialization item", Item
);
2878 Resolve_State
(Input
);
2880 if Is_Entity_Name
(Input
) then
2881 Input_Id
:= Entity_Of
(Input
);
2883 if Ekind_In
(Input_Id
, E_Abstract_State
,
2885 E_Generic_In_Out_Parameter
,
2886 E_Generic_In_Parameter
,
2892 -- The input cannot denote states or objects declared
2893 -- within the related package (SPARK RM 7.1.5(4)).
2895 if Within_Scope
(Input_Id
, Current_Scope
) then
2897 -- Do not consider generic formal parameters or their
2898 -- respective mappings to generic formals. Even though
2899 -- the formals appear within the scope of the package,
2900 -- it is allowed for an initialization item to depend
2901 -- on an input item.
2903 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2904 E_Generic_In_Parameter
)
2908 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2909 and then Present
(Corresponding_Generic_Association
2910 (Declaration_Node
(Input_Id
)))
2916 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2918 ("input item & cannot denote a visible object or "
2919 & "state of package %", Input
, Input_Id
);
2923 -- Detect a duplicate use of the same input item
2924 -- (SPARK RM 7.1.5(5)).
2926 if Contains
(Inputs_Seen
, Input_Id
) then
2928 SPARK_Msg_N
("duplicate input item", Input
);
2931 -- Input is legal, add it to the list of processed inputs
2934 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2936 if Ekind
(Input_Id
) = E_Abstract_State
then
2937 Append_New_Elmt
(Input_Id
, States_Seen
);
2940 if Ekind_In
(Input_Id
, E_Abstract_State
,
2943 and then Present
(Encapsulating_State
(Input_Id
))
2945 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2949 -- The input references something that is not a state or an
2950 -- object (SPARK RM 7.1.5(3)).
2954 ("input item must denote object or state", Input
);
2957 -- Some form of illegal construct masquerading as a name
2958 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2962 ("input item must denote object or state", Input
);
2965 end Analyze_Input_Item
;
2969 Inputs
: constant Node_Id
:= Expression
(Item
);
2973 Name_Seen
: Boolean := False;
2974 -- A flag used to detect multiple item names
2976 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2979 -- Inspect the name of an item with inputs
2981 Elmt
:= First
(Choices
(Item
));
2982 while Present
(Elmt
) loop
2984 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2987 Analyze_Initialization_Item
(Elmt
);
2993 -- Multiple input items appear as an aggregate
2995 if Nkind
(Inputs
) = N_Aggregate
then
2996 if Present
(Expressions
(Inputs
)) then
2997 Input
:= First
(Expressions
(Inputs
));
2998 while Present
(Input
) loop
2999 Analyze_Input_Item
(Input
);
3004 if Present
(Component_Associations
(Inputs
)) then
3006 ("inputs must appear in named association form", Inputs
);
3009 -- Single input item
3012 Analyze_Input_Item
(Inputs
);
3014 end Analyze_Initialization_Item_With_Inputs
;
3016 --------------------------------
3017 -- Collect_States_And_Objects --
3018 --------------------------------
3020 procedure Collect_States_And_Objects
is
3021 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3025 -- Collect the abstract states defined in the package (if any)
3027 if Present
(Abstract_States
(Pack_Id
)) then
3028 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3031 -- Collect all objects the appear in the visible declarations of the
3034 if Present
(Visible_Declarations
(Pack_Spec
)) then
3035 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3036 while Present
(Decl
) loop
3037 if Comes_From_Source
(Decl
)
3038 and then Nkind
(Decl
) = N_Object_Declaration
3040 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3046 end Collect_States_And_Objects
;
3050 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3053 -- Start of processing for Analyze_Initializes_In_Decl_Part
3056 -- Do not analyze the pragma multiple times
3058 if Is_Analyzed_Pragma
(N
) then
3062 -- Nothing to do when the initialization list is empty
3064 if Nkind
(Inits
) = N_Null
then
3068 -- Single and multiple initialization clauses appear as an aggregate. If
3069 -- this is not the case, then either the parser or the analysis of the
3070 -- pragma failed to produce an aggregate.
3072 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3074 -- Initialize the various lists used during analysis
3076 Collect_States_And_Objects
;
3078 if Present
(Expressions
(Inits
)) then
3079 Init
:= First
(Expressions
(Inits
));
3080 while Present
(Init
) loop
3081 Analyze_Initialization_Item
(Init
);
3086 if Present
(Component_Associations
(Inits
)) then
3087 Init
:= First
(Component_Associations
(Inits
));
3088 while Present
(Init
) loop
3089 Analyze_Initialization_Item_With_Inputs
(Init
);
3094 -- Ensure that a state and a corresponding constituent do not appear
3095 -- together in pragma Initializes.
3097 Check_State_And_Constituent_Use
3098 (States
=> States_Seen
,
3099 Constits
=> Constits_Seen
,
3102 Set_Is_Analyzed_Pragma
(N
);
3103 end Analyze_Initializes_In_Decl_Part
;
3105 ---------------------
3106 -- Analyze_Part_Of --
3107 ---------------------
3109 procedure Analyze_Part_Of
3111 Item_Id
: Entity_Id
;
3113 Encap_Id
: out Entity_Id
;
3114 Legal
: out Boolean)
3116 Encap_Typ
: Entity_Id
;
3117 Item_Decl
: Node_Id
;
3118 Pack_Id
: Entity_Id
;
3119 Placement
: State_Space_Kind
;
3120 Parent_Unit
: Entity_Id
;
3123 -- Assume that the indicator is illegal
3128 if Nkind_In
(Encap
, N_Expanded_Name
,
3130 N_Selected_Component
)
3133 Resolve_State
(Encap
);
3135 Encap_Id
:= Entity
(Encap
);
3137 -- The encapsulator is an abstract state
3139 if Ekind
(Encap_Id
) = E_Abstract_State
then
3142 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3144 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3147 -- Otherwise the encapsulator is not a legal choice
3151 ("indicator Part_Of must denote abstract state, single "
3152 & "protected type or single task type", Encap
);
3156 -- This is a syntax error, always report
3160 ("indicator Part_Of must denote abstract state, single protected "
3161 & "type or single task type", Encap
);
3165 -- Catch a case where indicator Part_Of denotes the abstract view of a
3166 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3168 if From_Limited_With
(Encap_Id
)
3169 and then Present
(Non_Limited_View
(Encap_Id
))
3170 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3172 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3173 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3177 -- The encapsulator is an abstract state
3179 if Ekind
(Encap_Id
) = E_Abstract_State
then
3181 -- Determine where the object, package instantiation or state lives
3182 -- with respect to the enclosing packages or package bodies.
3184 Find_Placement_In_State_Space
3185 (Item_Id
=> Item_Id
,
3186 Placement
=> Placement
,
3187 Pack_Id
=> Pack_Id
);
3189 -- The item appears in a non-package construct with a declarative
3190 -- part (subprogram, block, etc). As such, the item is not allowed
3191 -- to be a part of an encapsulating state because the item is not
3194 if Placement
= Not_In_Package
then
3196 ("indicator Part_Of cannot appear in this context "
3197 & "(SPARK RM 7.2.6(5))", Indic
);
3198 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3200 ("\& is not part of the hidden state of package %",
3203 -- The item appears in the visible state space of some package. In
3204 -- general this scenario does not warrant Part_Of except when the
3205 -- package is a private child unit and the encapsulating state is
3206 -- declared in a parent unit or a public descendant of that parent
3209 elsif Placement
= Visible_State_Space
then
3210 if Is_Child_Unit
(Pack_Id
)
3211 and then Is_Private_Descendant
(Pack_Id
)
3213 -- A variable or state abstraction which is part of the visible
3214 -- state of a private child unit (or one of its public
3215 -- descendants) must have its Part_Of indicator specified. The
3216 -- Part_Of indicator must denote a state abstraction declared
3217 -- by either the parent unit of the private unit or by a public
3218 -- descendant of that parent unit.
3220 -- Find nearest private ancestor (which can be the current unit
3223 Parent_Unit
:= Pack_Id
;
3224 while Present
(Parent_Unit
) loop
3227 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3228 Parent_Unit
:= Scope
(Parent_Unit
);
3231 Parent_Unit
:= Scope
(Parent_Unit
);
3233 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3235 ("indicator Part_Of must denote abstract state or public "
3236 & "descendant of & (SPARK RM 7.2.6(3))",
3237 Indic
, Parent_Unit
);
3239 elsif Scope
(Encap_Id
) = Parent_Unit
3241 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3242 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3248 ("indicator Part_Of must denote abstract state or public "
3249 & "descendant of & (SPARK RM 7.2.6(3))",
3250 Indic
, Parent_Unit
);
3253 -- Indicator Part_Of is not needed when the related package is not
3254 -- a private child unit or a public descendant thereof.
3258 ("indicator Part_Of cannot appear in this context "
3259 & "(SPARK RM 7.2.6(5))", Indic
);
3260 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3262 ("\& is declared in the visible part of package %",
3266 -- When the item appears in the private state space of a package, the
3267 -- encapsulating state must be declared in the same package.
3269 elsif Placement
= Private_State_Space
then
3270 if Scope
(Encap_Id
) /= Pack_Id
then
3272 ("indicator Part_Of must designate an abstract state of "
3273 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3274 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3276 ("\& is declared in the private part of package %",
3280 -- Items declared in the body state space of a package do not need
3281 -- Part_Of indicators as the refinement has already been seen.
3285 ("indicator Part_Of cannot appear in this context "
3286 & "(SPARK RM 7.2.6(5))", Indic
);
3288 if Scope
(Encap_Id
) = Pack_Id
then
3289 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3291 ("\& is declared in the body of package %", Indic
, Item_Id
);
3295 -- The encapsulator is a single concurrent type
3298 Encap_Typ
:= Etype
(Encap_Id
);
3300 -- Only abstract states and variables can act as constituents of an
3301 -- encapsulating single concurrent type.
3303 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3306 -- The constituent is a constant
3308 elsif Ekind
(Item_Id
) = E_Constant
then
3309 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3311 (Fix_Msg
(Encap_Typ
, "constant & cannot act as constituent of "
3312 & "single protected type %"), Indic
, Item_Id
);
3314 -- The constituent is a package instantiation
3317 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3319 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3320 & "constituent of single protected type %"), Indic
, Item_Id
);
3323 -- When the item denotes an abstract state of a nested package, use
3324 -- the declaration of the package to detect proper placement.
3329 -- with Abstract_State => (State with Part_Of => T)
3331 if Ekind
(Item_Id
) = E_Abstract_State
then
3332 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3334 Item_Decl
:= Declaration_Node
(Item_Id
);
3337 -- Both the item and its encapsulating single concurrent type must
3338 -- appear in the same declarative region (SPARK RM 9.3). Note that
3339 -- privacy is ignored.
3341 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3342 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3344 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3345 & "immediately within the same region as single protected "
3346 & "type %"), Indic
, Item_Id
);
3351 end Analyze_Part_Of
;
3353 ----------------------------------
3354 -- Analyze_Part_Of_In_Decl_Part --
3355 ----------------------------------
3357 procedure Analyze_Part_Of_In_Decl_Part
3359 Freeze_Id
: Entity_Id
:= Empty
)
3361 Encap
: constant Node_Id
:=
3362 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3363 Errors
: constant Nat
:= Serious_Errors_Detected
;
3364 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3365 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3366 Constits
: Elist_Id
;
3367 Encap_Id
: Entity_Id
;
3371 -- Detect any discrepancies between the placement of the variable with
3372 -- respect to general state space and the encapsulating state or single
3379 Encap_Id
=> Encap_Id
,
3382 -- The Part_Of indicator turns the variable into a constituent of the
3383 -- encapsulating state or single concurrent type.
3386 pragma Assert
(Present
(Encap_Id
));
3387 Constits
:= Part_Of_Constituents
(Encap_Id
);
3389 if No
(Constits
) then
3390 Constits
:= New_Elmt_List
;
3391 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3394 Append_Elmt
(Var_Id
, Constits
);
3395 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3397 -- A Part_Of constituent partially refines an abstract state. This
3398 -- property does not apply to protected or task units.
3400 if Ekind
(Encap_Id
) = E_Abstract_State
then
3401 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3405 -- Emit a clarification message when the encapsulator is undefined,
3406 -- possibly due to contract "freezing".
3408 if Errors
/= Serious_Errors_Detected
3409 and then Present
(Freeze_Id
)
3410 and then Has_Undefined_Reference
(Encap
)
3412 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3414 end Analyze_Part_Of_In_Decl_Part
;
3416 --------------------
3417 -- Analyze_Pragma --
3418 --------------------
3420 procedure Analyze_Pragma
(N
: Node_Id
) is
3421 Loc
: constant Source_Ptr
:= Sloc
(N
);
3422 Prag_Id
: Pragma_Id
;
3424 Pname
: Name_Id
:= Pragma_Name
(N
);
3425 -- Name of the source pragma, or name of the corresponding aspect for
3426 -- pragmas which originate in a source aspect. In the latter case, the
3427 -- name may be different from the pragma name.
3429 Pragma_Exit
: exception;
3430 -- This exception is used to exit pragma processing completely. It
3431 -- is used when an error is detected, and no further processing is
3432 -- required. It is also used if an earlier error has left the tree in
3433 -- a state where the pragma should not be processed.
3436 -- Number of pragma argument associations
3442 -- First four pragma arguments (pragma argument association nodes, or
3443 -- Empty if the corresponding argument does not exist).
3445 type Name_List
is array (Natural range <>) of Name_Id
;
3446 type Args_List
is array (Natural range <>) of Node_Id
;
3447 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3449 -----------------------
3450 -- Local Subprograms --
3451 -----------------------
3453 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3454 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3455 -- get the given string argument, and place it in Name_Buffer, adding
3456 -- leading and trailing asterisks if they are not already present. The
3457 -- caller has already checked that Arg is a static string expression.
3459 procedure Ada_2005_Pragma
;
3460 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3461 -- Ada 95 mode, these are implementation defined pragmas, so should be
3462 -- caught by the No_Implementation_Pragmas restriction.
3464 procedure Ada_2012_Pragma
;
3465 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3466 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3467 -- should be caught by the No_Implementation_Pragmas restriction.
3469 procedure Analyze_Depends_Global
3470 (Spec_Id
: out Entity_Id
;
3471 Subp_Decl
: out Node_Id
;
3472 Legal
: out Boolean);
3473 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3474 -- legality of the placement and related context of the pragma. Spec_Id
3475 -- is the entity of the related subprogram. Subp_Decl is the declaration
3476 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3478 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3479 -- Inspect the remainder of the list containing pragma N and look for
3480 -- a pragma that matches Id. If found, analyze the pragma.
3482 procedure Analyze_Pre_Post_Condition
;
3483 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3485 procedure Analyze_Refined_Depends_Global_Post
3486 (Spec_Id
: out Entity_Id
;
3487 Body_Id
: out Entity_Id
;
3488 Legal
: out Boolean);
3489 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3490 -- Refined_Global and Refined_Post. Verify the legality of the placement
3491 -- and related context of the pragma. Spec_Id is the entity of the
3492 -- related subprogram. Body_Id is the entity of the subprogram body.
3493 -- Flag Legal is set when the pragma is legal.
3495 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3496 -- Perform full analysis of pragma Unmodified and the write aspect of
3497 -- pragma Unused. Flag Is_Unused should be set when verifying the
3498 -- semantics of pragma Unused.
3500 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3501 -- Perform full analysis of pragma Unreferenced and the read aspect of
3502 -- pragma Unused. Flag Is_Unused should be set when verifying the
3503 -- semantics of pragma Unused.
3505 procedure Check_Ada_83_Warning
;
3506 -- Issues a warning message for the current pragma if operating in Ada
3507 -- 83 mode (used for language pragmas that are not a standard part of
3508 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3511 procedure Check_Arg_Count
(Required
: Nat
);
3512 -- Check argument count for pragma is equal to given parameter. If not,
3513 -- then issue an error message and raise Pragma_Exit.
3515 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3516 -- Arg which can either be a pragma argument association, in which case
3517 -- the check is applied to the expression of the association or an
3518 -- expression directly.
3520 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3521 -- Check that an argument has the right form for an EXTERNAL_NAME
3522 -- parameter of an extended import/export pragma. The rule is that the
3523 -- name must be an identifier or string literal (in Ada 83 mode) or a
3524 -- static string expression (in Ada 95 mode).
3526 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3527 -- Check the specified argument Arg to make sure that it is an
3528 -- identifier. If not give error and raise Pragma_Exit.
3530 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3531 -- Check the specified argument Arg to make sure that it is an integer
3532 -- literal. If not give error and raise Pragma_Exit.
3534 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3535 -- Check the specified argument Arg to make sure that it has the proper
3536 -- syntactic form for a local name and meets the semantic requirements
3537 -- for a local name. The local name is analyzed as part of the
3538 -- processing for this call. In addition, the local name is required
3539 -- to represent an entity at the library level.
3541 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
);
3542 -- Check the specified argument Arg to make sure that it has the proper
3543 -- syntactic form for a local name and meets the semantic requirements
3544 -- for a local name. The local name is analyzed as part of the
3545 -- processing for this call.
3547 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3548 -- Check the specified argument Arg to make sure that it is a valid
3549 -- locking policy name. If not give error and raise Pragma_Exit.
3551 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3552 -- Check the specified argument Arg to make sure that it is a valid
3553 -- elaboration policy name. If not give error and raise Pragma_Exit.
3555 procedure Check_Arg_Is_One_Of
3558 procedure Check_Arg_Is_One_Of
3560 N1
, N2
, N3
: Name_Id
);
3561 procedure Check_Arg_Is_One_Of
3563 N1
, N2
, N3
, N4
: Name_Id
);
3564 procedure Check_Arg_Is_One_Of
3566 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3567 -- Check the specified argument Arg to make sure that it is an
3568 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3569 -- present). If not then give error and raise Pragma_Exit.
3571 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3572 -- Check the specified argument Arg to make sure that it is a valid
3573 -- queuing policy name. If not give error and raise Pragma_Exit.
3575 procedure Check_Arg_Is_OK_Static_Expression
3577 Typ
: Entity_Id
:= Empty
);
3578 -- Check the specified argument Arg to make sure that it is a static
3579 -- expression of the given type (i.e. it will be analyzed and resolved
3580 -- using this type, which can be any valid argument to Resolve, e.g.
3581 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3582 -- Typ is left Empty, then any static expression is allowed. Includes
3583 -- checking that the argument does not raise Constraint_Error.
3585 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3586 -- Check the specified argument Arg to make sure that it is a valid task
3587 -- dispatching policy name. If not give error and raise Pragma_Exit.
3589 procedure Check_Arg_Order
(Names
: Name_List
);
3590 -- Checks for an instance of two arguments with identifiers for the
3591 -- current pragma which are not in the sequence indicated by Names,
3592 -- and if so, generates a fatal message about bad order of arguments.
3594 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3595 -- Check there are at least N arguments present
3597 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3598 -- Check there are no more than N arguments present
3600 procedure Check_Component
3603 In_Variant_Part
: Boolean := False);
3604 -- Examine an Unchecked_Union component for correct use of per-object
3605 -- constrained subtypes, and for restrictions on finalizable components.
3606 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3607 -- should be set when Comp comes from a record variant.
3609 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3610 -- Check if a rep item of the same name as the current pragma is already
3611 -- chained as a rep pragma to the given entity. If so give a message
3612 -- about the duplicate, and then raise Pragma_Exit so does not return.
3613 -- Note that if E is a type, then this routine avoids flagging a pragma
3614 -- which applies to a parent type from which E is derived.
3616 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3617 -- Nam is an N_String_Literal node containing the external name set by
3618 -- an Import or Export pragma (or extended Import or Export pragma).
3619 -- This procedure checks for possible duplications if this is the export
3620 -- case, and if found, issues an appropriate error message.
3622 procedure Check_Expr_Is_OK_Static_Expression
3624 Typ
: Entity_Id
:= Empty
);
3625 -- Check the specified expression Expr to make sure that it is a static
3626 -- expression of the given type (i.e. it will be analyzed and resolved
3627 -- using this type, which can be any valid argument to Resolve, e.g.
3628 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3629 -- Typ is left Empty, then any static expression is allowed. Includes
3630 -- checking that the expression does not raise Constraint_Error.
3632 procedure Check_First_Subtype
(Arg
: Node_Id
);
3633 -- Checks that Arg, whose expression is an entity name, references a
3636 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3637 -- Checks that the given argument has an identifier, and if so, requires
3638 -- it to match the given identifier name. If there is no identifier, or
3639 -- a non-matching identifier, then an error message is given and
3640 -- Pragma_Exit is raised.
3642 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3643 -- Checks that the given argument has an identifier, and if so, requires
3644 -- it to match one of the given identifier names. If there is no
3645 -- identifier, or a non-matching identifier, then an error message is
3646 -- given and Pragma_Exit is raised.
3648 procedure Check_In_Main_Program
;
3649 -- Common checks for pragmas that appear within a main program
3650 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3652 procedure Check_Interrupt_Or_Attach_Handler
;
3653 -- Common processing for first argument of pragma Interrupt_Handler or
3654 -- pragma Attach_Handler.
3656 procedure Check_Loop_Pragma_Placement
;
3657 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3658 -- appear immediately within a construct restricted to loops, and that
3659 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3661 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3662 -- Check that pragma appears in a declarative part, or in a package
3663 -- specification, i.e. that it does not occur in a statement sequence
3666 procedure Check_No_Identifier
(Arg
: Node_Id
);
3667 -- Checks that the given argument does not have an identifier. If
3668 -- an identifier is present, then an error message is issued, and
3669 -- Pragma_Exit is raised.
3671 procedure Check_No_Identifiers
;
3672 -- Checks that none of the arguments to the pragma has an identifier.
3673 -- If any argument has an identifier, then an error message is issued,
3674 -- and Pragma_Exit is raised.
3676 procedure Check_No_Link_Name
;
3677 -- Checks that no link name is specified
3679 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3680 -- Checks if the given argument has an identifier, and if so, requires
3681 -- it to match the given identifier name. If there is a non-matching
3682 -- identifier, then an error message is given and Pragma_Exit is raised.
3684 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3685 -- Checks if the given argument has an identifier, and if so, requires
3686 -- it to match the given identifier name. If there is a non-matching
3687 -- identifier, then an error message is given and Pragma_Exit is raised.
3688 -- In this version of the procedure, the identifier name is given as
3689 -- a string with lower case letters.
3691 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3692 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3693 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3694 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3695 -- is an OK static boolean expression. Emit an error if this is not the
3698 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3699 -- Constr is a constraint from an N_Subtype_Indication node from a
3700 -- component constraint in an Unchecked_Union type. This routine checks
3701 -- that the constraint is static as required by the restrictions for
3704 procedure Check_Valid_Configuration_Pragma
;
3705 -- Legality checks for placement of a configuration pragma
3707 procedure Check_Valid_Library_Unit_Pragma
;
3708 -- Legality checks for library unit pragmas. A special case arises for
3709 -- pragmas in generic instances that come from copies of the original
3710 -- library unit pragmas in the generic templates. In the case of other
3711 -- than library level instantiations these can appear in contexts which
3712 -- would normally be invalid (they only apply to the original template
3713 -- and to library level instantiations), and they are simply ignored,
3714 -- which is implemented by rewriting them as null statements.
3716 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3717 -- Check an Unchecked_Union variant for lack of nested variants and
3718 -- presence of at least one component. UU_Typ is the related Unchecked_
3721 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3722 -- Subsidiary routine to the processing of pragmas Abstract_State,
3723 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3724 -- Refined_Global and Refined_State. Transform argument Arg into
3725 -- an aggregate if not one already. N_Null is never transformed.
3726 -- Arg may denote an aspect specification or a pragma argument
3729 procedure Error_Pragma
(Msg
: String);
3730 pragma No_Return
(Error_Pragma
);
3731 -- Outputs error message for current pragma. The message contains a %
3732 -- that will be replaced with the pragma name, and the flag is placed
3733 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3734 -- calls Fix_Error (see spec of that procedure for details).
3736 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3737 pragma No_Return
(Error_Pragma_Arg
);
3738 -- Outputs error message for current pragma. The message may contain
3739 -- a % that will be replaced with the pragma name. The parameter Arg
3740 -- may either be a pragma argument association, in which case the flag
3741 -- is placed on the expression of this association, or an expression,
3742 -- in which case the flag is placed directly on the expression. The
3743 -- message is placed using Error_Msg_N, so the message may also contain
3744 -- an & insertion character which will reference the given Arg value.
3745 -- After placing the message, Pragma_Exit is raised. Note: this routine
3746 -- calls Fix_Error (see spec of that procedure for details).
3748 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3749 pragma No_Return
(Error_Pragma_Arg
);
3750 -- Similar to above form of Error_Pragma_Arg except that two messages
3751 -- are provided, the second is a continuation comment starting with \.
3753 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3754 pragma No_Return
(Error_Pragma_Arg_Ident
);
3755 -- Outputs error message for current pragma. The message may contain a %
3756 -- that will be replaced with the pragma name. The parameter Arg must be
3757 -- a pragma argument association with a non-empty identifier (i.e. its
3758 -- Chars field must be set), and the error message is placed on the
3759 -- identifier. The message is placed using Error_Msg_N so the message
3760 -- may also contain an & insertion character which will reference
3761 -- the identifier. After placing the message, Pragma_Exit is raised.
3762 -- Note: this routine calls Fix_Error (see spec of that procedure for
3765 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3766 pragma No_Return
(Error_Pragma_Ref
);
3767 -- Outputs error message for current pragma. The message may contain
3768 -- a % that will be replaced with the pragma name. The parameter Ref
3769 -- must be an entity whose name can be referenced by & and sloc by #.
3770 -- After placing the message, Pragma_Exit is raised. Note: this routine
3771 -- calls Fix_Error (see spec of that procedure for details).
3773 function Find_Lib_Unit_Name
return Entity_Id
;
3774 -- Used for a library unit pragma to find the entity to which the
3775 -- library unit pragma applies, returns the entity found.
3777 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3778 -- If the pragma is a compilation unit pragma, the id must denote the
3779 -- compilation unit in the same compilation, and the pragma must appear
3780 -- in the list of preceding or trailing pragmas. If it is a program
3781 -- unit pragma that is not a compilation unit pragma, then the
3782 -- identifier must be visible.
3784 function Find_Unique_Parameterless_Procedure
3786 Arg
: Node_Id
) return Entity_Id
;
3787 -- Used for a procedure pragma to find the unique parameterless
3788 -- procedure identified by Name, returns it if it exists, otherwise
3789 -- errors out and uses Arg as the pragma argument for the message.
3791 function Fix_Error
(Msg
: String) return String;
3792 -- This is called prior to issuing an error message. Msg is the normal
3793 -- error message issued in the pragma case. This routine checks for the
3794 -- case of a pragma coming from an aspect in the source, and returns a
3795 -- message suitable for the aspect case as follows:
3797 -- Each substring "pragma" is replaced by "aspect"
3799 -- If "argument of" is at the start of the error message text, it is
3800 -- replaced by "entity for".
3802 -- If "argument" is at the start of the error message text, it is
3803 -- replaced by "entity".
3805 -- So for example, "argument of pragma X must be discrete type"
3806 -- returns "entity for aspect X must be a discrete type".
3808 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3809 -- be different from the pragma name). If the current pragma results
3810 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3811 -- original pragma name.
3813 procedure Gather_Associations
3815 Args
: out Args_List
);
3816 -- This procedure is used to gather the arguments for a pragma that
3817 -- permits arbitrary ordering of parameters using the normal rules
3818 -- for named and positional parameters. The Names argument is a list
3819 -- of Name_Id values that corresponds to the allowed pragma argument
3820 -- association identifiers in order. The result returned in Args is
3821 -- a list of corresponding expressions that are the pragma arguments.
3822 -- Note that this is a list of expressions, not of pragma argument
3823 -- associations (Gather_Associations has completely checked all the
3824 -- optional identifiers when it returns). An entry in Args is Empty
3825 -- on return if the corresponding argument is not present.
3827 procedure GNAT_Pragma
;
3828 -- Called for all GNAT defined pragmas to check the relevant restriction
3829 -- (No_Implementation_Pragmas).
3831 function Is_Before_First_Decl
3832 (Pragma_Node
: Node_Id
;
3833 Decls
: List_Id
) return Boolean;
3834 -- Return True if Pragma_Node is before the first declarative item in
3835 -- Decls where Decls is the list of declarative items.
3837 function Is_Configuration_Pragma
return Boolean;
3838 -- Determines if the placement of the current pragma is appropriate
3839 -- for a configuration pragma.
3841 function Is_In_Context_Clause
return Boolean;
3842 -- Returns True if pragma appears within the context clause of a unit,
3843 -- and False for any other placement (does not generate any messages).
3845 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3846 -- Analyzes the argument, and determines if it is a static string
3847 -- expression, returns True if so, False if non-static or not String.
3848 -- A special case is that a string literal returns True in Ada 83 mode
3849 -- (which has no such thing as static string expressions). Note that
3850 -- the call analyzes its argument, so this cannot be used for the case
3851 -- where an identifier might not be declared.
3853 procedure Pragma_Misplaced
;
3854 pragma No_Return
(Pragma_Misplaced
);
3855 -- Issue fatal error message for misplaced pragma
3857 procedure Process_Atomic_Independent_Shared_Volatile
;
3858 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3859 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3860 -- and treated as being identical in effect to pragma Atomic.
3862 procedure Process_Compile_Time_Warning_Or_Error
;
3863 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3865 procedure Process_Convention
3866 (C
: out Convention_Id
;
3867 Ent
: out Entity_Id
);
3868 -- Common processing for Convention, Interface, Import and Export.
3869 -- Checks first two arguments of pragma, and sets the appropriate
3870 -- convention value in the specified entity or entities. On return
3871 -- C is the convention, Ent is the referenced entity.
3873 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3874 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3875 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3877 procedure Process_Extended_Import_Export_Object_Pragma
3878 (Arg_Internal
: Node_Id
;
3879 Arg_External
: Node_Id
;
3880 Arg_Size
: Node_Id
);
3881 -- Common processing for the pragmas Import/Export_Object. The three
3882 -- arguments correspond to the three named parameters of the pragmas. An
3883 -- argument is empty if the corresponding parameter is not present in
3886 procedure Process_Extended_Import_Export_Internal_Arg
3887 (Arg_Internal
: Node_Id
:= Empty
);
3888 -- Common processing for all extended Import and Export pragmas. The
3889 -- argument is the pragma parameter for the Internal argument. If
3890 -- Arg_Internal is empty or inappropriate, an error message is posted.
3891 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3892 -- set to identify the referenced entity.
3894 procedure Process_Extended_Import_Export_Subprogram_Pragma
3895 (Arg_Internal
: Node_Id
;
3896 Arg_External
: Node_Id
;
3897 Arg_Parameter_Types
: Node_Id
;
3898 Arg_Result_Type
: Node_Id
:= Empty
;
3899 Arg_Mechanism
: Node_Id
;
3900 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3901 -- Common processing for all extended Import and Export pragmas applying
3902 -- to subprograms. The caller omits any arguments that do not apply to
3903 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3904 -- only in the Import_Function and Export_Function cases). The argument
3905 -- names correspond to the allowed pragma association identifiers.
3907 procedure Process_Generic_List
;
3908 -- Common processing for Share_Generic and Inline_Generic
3910 procedure Process_Import_Or_Interface
;
3911 -- Common processing for Import or Interface
3913 procedure Process_Import_Predefined_Type
;
3914 -- Processing for completing a type with pragma Import. This is used
3915 -- to declare types that match predefined C types, especially for cases
3916 -- without corresponding Ada predefined type.
3918 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3919 -- Inline status of a subprogram, indicated as follows:
3920 -- Suppressed: inlining is suppressed for the subprogram
3921 -- Disabled: no inlining is requested for the subprogram
3922 -- Enabled: inlining is requested/required for the subprogram
3924 procedure Process_Inline
(Status
: Inline_Status
);
3925 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3926 -- indicates the inline status specified by the pragma.
3928 procedure Process_Interface_Name
3929 (Subprogram_Def
: Entity_Id
;
3931 Link_Arg
: Node_Id
);
3932 -- Given the last two arguments of pragma Import, pragma Export, or
3933 -- pragma Interface_Name, performs validity checks and sets the
3934 -- Interface_Name field of the given subprogram entity to the
3935 -- appropriate external or link name, depending on the arguments given.
3936 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3937 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3938 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3939 -- nor Link_Arg is present, the interface name is set to the default
3940 -- from the subprogram name.
3942 procedure Process_Interrupt_Or_Attach_Handler
;
3943 -- Common processing for Interrupt and Attach_Handler pragmas
3945 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3946 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3947 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3948 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3949 -- is not set in the Restrictions case.
3951 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3952 -- Common processing for Suppress and Unsuppress. The boolean parameter
3953 -- Suppress_Case is True for the Suppress case, and False for the
3956 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3957 -- Subsidiary to the analysis of pragmas Independent[_Components].
3958 -- Record such a pragma N applied to entity E for future checks.
3960 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3961 -- This procedure sets the Is_Exported flag for the given entity,
3962 -- checking that the entity was not previously imported. Arg is
3963 -- the argument that specified the entity. A check is also made
3964 -- for exporting inappropriate entities.
3966 procedure Set_Extended_Import_Export_External_Name
3967 (Internal_Ent
: Entity_Id
;
3968 Arg_External
: Node_Id
);
3969 -- Common processing for all extended import export pragmas. The first
3970 -- argument, Internal_Ent, is the internal entity, which has already
3971 -- been checked for validity by the caller. Arg_External is from the
3972 -- Import or Export pragma, and may be null if no External parameter
3973 -- was present. If Arg_External is present and is a non-null string
3974 -- (a null string is treated as the default), then the Interface_Name
3975 -- field of Internal_Ent is set appropriately.
3977 procedure Set_Imported
(E
: Entity_Id
);
3978 -- This procedure sets the Is_Imported flag for the given entity,
3979 -- checking that it is not previously exported or imported.
3981 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3982 -- Mech is a parameter passing mechanism (see Import_Function syntax
3983 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3984 -- has the right form, and if not issues an error message. If the
3985 -- argument has the right form then the Mechanism field of Ent is
3986 -- set appropriately.
3988 procedure Set_Rational_Profile
;
3989 -- Activate the set of configuration pragmas and permissions that make
3990 -- up the Rational profile.
3992 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
3993 -- Activate the set of configuration pragmas and restrictions that make
3994 -- up the Profile. Profile must be either GNAT_Extended_Ravencar or
3995 -- Ravenscar. N is the corresponding pragma node, which is used for
3996 -- error messages on any constructs violating the profile.
3998 ----------------------------------
3999 -- Acquire_Warning_Match_String --
4000 ----------------------------------
4002 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4004 String_To_Name_Buffer
4005 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4007 -- Add asterisk at start if not already there
4009 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4010 Name_Buffer
(2 .. Name_Len
+ 1) :=
4011 Name_Buffer
(1 .. Name_Len
);
4012 Name_Buffer
(1) := '*';
4013 Name_Len
:= Name_Len
+ 1;
4016 -- Add asterisk at end if not already there
4018 if Name_Buffer
(Name_Len
) /= '*' then
4019 Name_Len
:= Name_Len
+ 1;
4020 Name_Buffer
(Name_Len
) := '*';
4022 end Acquire_Warning_Match_String
;
4024 ---------------------
4025 -- Ada_2005_Pragma --
4026 ---------------------
4028 procedure Ada_2005_Pragma
is
4030 if Ada_Version
<= Ada_95
then
4031 Check_Restriction
(No_Implementation_Pragmas
, N
);
4033 end Ada_2005_Pragma
;
4035 ---------------------
4036 -- Ada_2012_Pragma --
4037 ---------------------
4039 procedure Ada_2012_Pragma
is
4041 if Ada_Version
<= Ada_2005
then
4042 Check_Restriction
(No_Implementation_Pragmas
, N
);
4044 end Ada_2012_Pragma
;
4046 ----------------------------
4047 -- Analyze_Depends_Global --
4048 ----------------------------
4050 procedure Analyze_Depends_Global
4051 (Spec_Id
: out Entity_Id
;
4052 Subp_Decl
: out Node_Id
;
4053 Legal
: out Boolean)
4056 -- Assume that the pragma is illegal
4063 Check_Arg_Count
(1);
4065 -- Ensure the proper placement of the pragma. Depends/Global must be
4066 -- associated with a subprogram declaration or a body that acts as a
4069 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4073 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4076 -- Generic subprogram
4078 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4081 -- Object declaration of a single concurrent type
4083 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
then
4088 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4091 -- Subprogram body acts as spec
4093 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4094 and then No
(Corresponding_Spec
(Subp_Decl
))
4098 -- Subprogram body stub acts as spec
4100 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4101 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4105 -- Subprogram declaration
4107 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4112 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4120 -- If we get here, then the pragma is legal
4123 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4125 -- When the related context is an entry, the entry must belong to a
4126 -- protected unit (SPARK RM 6.1.4(6)).
4128 if Is_Entry_Declaration
(Spec_Id
)
4129 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4134 -- When the related context is an anonymous object created for a
4135 -- simple concurrent type, the type must be a task
4136 -- (SPARK RM 6.1.4(6)).
4138 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4139 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4145 -- A pragma that applies to a Ghost entity becomes Ghost for the
4146 -- purposes of legality checks and removal of ignored Ghost code.
4148 Mark_Ghost_Pragma
(N
, Spec_Id
);
4149 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4150 end Analyze_Depends_Global
;
4152 ------------------------
4153 -- Analyze_If_Present --
4154 ------------------------
4156 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4160 pragma Assert
(Is_List_Member
(N
));
4162 -- Inspect the declarations or statements following pragma N looking
4163 -- for another pragma whose Id matches the caller's request. If it is
4164 -- available, analyze it.
4167 while Present
(Stmt
) loop
4168 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4169 Analyze_Pragma
(Stmt
);
4172 -- The first source declaration or statement immediately following
4173 -- N ends the region where a pragma may appear.
4175 elsif Comes_From_Source
(Stmt
) then
4181 end Analyze_If_Present
;
4183 --------------------------------
4184 -- Analyze_Pre_Post_Condition --
4185 --------------------------------
4187 procedure Analyze_Pre_Post_Condition
is
4188 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4189 Subp_Decl
: Node_Id
;
4190 Subp_Id
: Entity_Id
;
4192 Duplicates_OK
: Boolean := False;
4193 -- Flag set when a pre/postcondition allows multiple pragmas of the
4196 In_Body_OK
: Boolean := False;
4197 -- Flag set when a pre/postcondition is allowed to appear on a body
4198 -- even though the subprogram may have a spec.
4200 Is_Pre_Post
: Boolean := False;
4201 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4205 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4206 -- offer uniformity among the various kinds of pre/postconditions by
4207 -- rewriting the pragma identifier. This allows the retrieval of the
4208 -- original pragma name by routine Original_Aspect_Pragma_Name.
4210 if Comes_From_Source
(N
) then
4211 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4212 Is_Pre_Post
:= True;
4213 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4214 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4216 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4217 Is_Pre_Post
:= True;
4218 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4219 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4223 -- Determine the semantics with respect to duplicates and placement
4224 -- in a body. Pragmas Precondition and Postcondition were introduced
4225 -- before aspects and are not subject to the same aspect-like rules.
4227 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4228 Duplicates_OK
:= True;
4234 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4235 -- argument without an identifier.
4238 Check_Arg_Count
(1);
4239 Check_No_Identifiers
;
4241 -- Pragmas Precondition and Postcondition have complex argument
4245 Check_At_Least_N_Arguments
(1);
4246 Check_At_Most_N_Arguments
(2);
4247 Check_Optional_Identifier
(Arg1
, Name_Check
);
4249 if Present
(Arg2
) then
4250 Check_Optional_Identifier
(Arg2
, Name_Message
);
4251 Preanalyze_Spec_Expression
4252 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4256 -- For a pragma PPC in the extended main source unit, record enabled
4258 -- ??? nothing checks that the pragma is in the main source unit
4260 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4261 Set_SCO_Pragma_Enabled
(Loc
);
4264 -- Ensure the proper placement of the pragma
4267 Find_Related_Declaration_Or_Body
4268 (N
, Do_Checks
=> not Duplicates_OK
);
4270 -- When a pre/postcondition pragma applies to an abstract subprogram,
4271 -- its original form must be an aspect with 'Class.
4273 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4274 if not From_Aspect_Specification
(N
) then
4276 ("pragma % cannot be applied to abstract subprogram");
4278 elsif not Class_Present
(N
) then
4280 ("aspect % requires ''Class for abstract subprogram");
4283 -- Entry declaration
4285 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4288 -- Generic subprogram declaration
4290 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4295 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4296 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4300 -- Subprogram body stub
4302 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4303 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4307 -- Subprogram declaration
4309 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4311 -- AI05-0230: When a pre/postcondition pragma applies to a null
4312 -- procedure, its original form must be an aspect with 'Class.
4314 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4315 and then Null_Present
(Specification
(Subp_Decl
))
4316 and then From_Aspect_Specification
(N
)
4317 and then not Class_Present
(N
)
4319 Error_Pragma
("aspect % requires ''Class for null procedure");
4322 -- Otherwise the placement is illegal
4329 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4331 -- A pragma that applies to a Ghost entity becomes Ghost for the
4332 -- purposes of legality checks and removal of ignored Ghost code.
4334 Mark_Ghost_Pragma
(N
, Subp_Id
);
4336 -- Chain the pragma on the contract for further processing by
4337 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4339 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4341 -- Fully analyze the pragma when it appears inside an entry or
4342 -- subprogram body because it cannot benefit from forward references.
4344 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4346 N_Subprogram_Body_Stub
)
4348 -- The legality checks of pragmas Precondition and Postcondition
4349 -- are affected by the SPARK mode in effect and the volatility of
4350 -- the context. Analyze all pragmas in a specific order.
4352 Analyze_If_Present
(Pragma_SPARK_Mode
);
4353 Analyze_If_Present
(Pragma_Volatile_Function
);
4354 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4356 end Analyze_Pre_Post_Condition
;
4358 -----------------------------------------
4359 -- Analyze_Refined_Depends_Global_Post --
4360 -----------------------------------------
4362 procedure Analyze_Refined_Depends_Global_Post
4363 (Spec_Id
: out Entity_Id
;
4364 Body_Id
: out Entity_Id
;
4365 Legal
: out Boolean)
4367 Body_Decl
: Node_Id
;
4368 Spec_Decl
: Node_Id
;
4371 -- Assume that the pragma is illegal
4378 Check_Arg_Count
(1);
4379 Check_No_Identifiers
;
4381 -- Verify the placement of the pragma and check for duplicates. The
4382 -- pragma must apply to a subprogram body [stub].
4384 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4388 if Nkind
(Body_Decl
) = N_Entry_Body
then
4393 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4396 -- Subprogram body stub
4398 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4403 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4411 Body_Id
:= Defining_Entity
(Body_Decl
);
4412 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4414 -- The pragma must apply to the second declaration of a subprogram.
4415 -- In other words, the body [stub] cannot acts as a spec.
4417 if No
(Spec_Id
) then
4418 Error_Pragma
("pragma % cannot apply to a stand alone body");
4421 -- Catch the case where the subprogram body is a subunit and acts as
4422 -- the third declaration of the subprogram.
4424 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4425 Error_Pragma
("pragma % cannot apply to a subunit");
4429 -- A refined pragma can only apply to the body [stub] of a subprogram
4430 -- declared in the visible part of a package. Retrieve the context of
4431 -- the subprogram declaration.
4433 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4435 -- When dealing with protected entries or protected subprograms, use
4436 -- the enclosing protected type as the proper context.
4438 if Ekind_In
(Spec_Id
, E_Entry
,
4442 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4444 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4447 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4449 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4450 & "subprogram declared in a package specification"));
4454 -- If we get here, then the pragma is legal
4458 -- A pragma that applies to a Ghost entity becomes Ghost for the
4459 -- purposes of legality checks and removal of ignored Ghost code.
4461 Mark_Ghost_Pragma
(N
, Spec_Id
);
4463 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4464 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4466 end Analyze_Refined_Depends_Global_Post
;
4468 ----------------------------------
4469 -- Analyze_Unmodified_Or_Unused --
4470 ----------------------------------
4472 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4477 Ghost_Error_Posted
: Boolean := False;
4478 -- Flag set when an error concerning the illegal mix of Ghost and
4479 -- non-Ghost variables is emitted.
4481 Ghost_Id
: Entity_Id
:= Empty
;
4482 -- The entity of the first Ghost variable encountered while
4483 -- processing the arguments of the pragma.
4487 Check_At_Least_N_Arguments
(1);
4489 -- Loop through arguments
4492 while Present
(Arg
) loop
4493 Check_No_Identifier
(Arg
);
4495 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4496 -- in fact generate reference, so that the entity will have a
4497 -- reference, which will inhibit any warnings about it not
4498 -- being referenced, and also properly show up in the ali file
4499 -- as a reference. But this reference is recorded before the
4500 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4501 -- generated for this reference.
4503 Check_Arg_Is_Local_Name
(Arg
);
4504 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4506 if Is_Entity_Name
(Arg_Expr
) then
4507 Arg_Id
:= Entity
(Arg_Expr
);
4509 -- Skip processing the argument if already flagged
4511 if Is_Assignable
(Arg_Id
)
4512 and then not Has_Pragma_Unmodified
(Arg_Id
)
4513 and then not Has_Pragma_Unused
(Arg_Id
)
4515 Set_Has_Pragma_Unmodified
(Arg_Id
);
4518 Set_Has_Pragma_Unused
(Arg_Id
);
4521 -- A pragma that applies to a Ghost entity becomes Ghost for
4522 -- the purposes of legality checks and removal of ignored
4525 Mark_Ghost_Pragma
(N
, Arg_Id
);
4527 -- Capture the entity of the first Ghost variable being
4528 -- processed for error detection purposes.
4530 if Is_Ghost_Entity
(Arg_Id
) then
4531 if No
(Ghost_Id
) then
4535 -- Otherwise the variable is non-Ghost. It is illegal to mix
4536 -- references to Ghost and non-Ghost entities
4539 elsif Present
(Ghost_Id
)
4540 and then not Ghost_Error_Posted
4542 Ghost_Error_Posted
:= True;
4544 Error_Msg_Name_1
:= Pname
;
4546 ("pragma % cannot mention ghost and non-ghost "
4549 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4550 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4552 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4553 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4556 -- Warn if already flagged as Unused or Unmodified
4558 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4559 if Has_Pragma_Unused
(Arg_Id
) then
4561 ("??pragma Unused already given for &!", Arg_Expr
,
4565 ("??pragma Unmodified already given for &!", Arg_Expr
,
4569 -- Otherwise the pragma referenced an illegal entity
4573 ("pragma% can only be applied to a variable", Arg_Expr
);
4579 end Analyze_Unmodified_Or_Unused
;
4581 -----------------------------------
4582 -- Analyze_Unreference_Or_Unused --
4583 -----------------------------------
4585 procedure Analyze_Unreferenced_Or_Unused
4586 (Is_Unused
: Boolean := False)
4593 Ghost_Error_Posted
: Boolean := False;
4594 -- Flag set when an error concerning the illegal mix of Ghost and
4595 -- non-Ghost names is emitted.
4597 Ghost_Id
: Entity_Id
:= Empty
;
4598 -- The entity of the first Ghost name encountered while processing
4599 -- the arguments of the pragma.
4603 Check_At_Least_N_Arguments
(1);
4605 -- Check case of appearing within context clause
4607 if not Is_Unused
and then Is_In_Context_Clause
then
4609 -- The arguments must all be units mentioned in a with clause in
4610 -- the same context clause. Note that Par.Prag already checked
4611 -- that the arguments are either identifiers or selected
4615 while Present
(Arg
) loop
4616 Citem
:= First
(List_Containing
(N
));
4617 while Citem
/= N
loop
4618 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4620 if Nkind
(Citem
) = N_With_Clause
4621 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4623 Set_Has_Pragma_Unreferenced
4626 (Library_Unit
(Citem
))));
4627 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4636 ("argument of pragma% is not withed unit", Arg
);
4642 -- Case of not in list of context items
4646 while Present
(Arg
) loop
4647 Check_No_Identifier
(Arg
);
4649 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4650 -- in fact generate reference, so that the entity will have a
4651 -- reference, which will inhibit any warnings about it not
4652 -- being referenced, and also properly show up in the ali file
4653 -- as a reference. But this reference is recorded before the
4654 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4655 -- generated for this reference.
4657 Check_Arg_Is_Local_Name
(Arg
);
4658 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4660 if Is_Entity_Name
(Arg_Expr
) then
4661 Arg_Id
:= Entity
(Arg_Expr
);
4663 -- Warn if already flagged as Unused or Unreferenced and
4664 -- skip processing the argument.
4666 if Has_Pragma_Unreferenced
(Arg_Id
) then
4667 if Has_Pragma_Unused
(Arg_Id
) then
4669 ("??pragma Unused already given for &!", Arg_Expr
,
4673 ("??pragma Unreferenced already given for &!",
4677 -- Apply Unreferenced to the entity
4680 -- If the entity is overloaded, the pragma applies to the
4681 -- most recent overloading, as documented. In this case,
4682 -- name resolution does not generate a reference, so it
4683 -- must be done here explicitly.
4685 if Is_Overloaded
(Arg_Expr
) then
4686 Generate_Reference
(Arg_Id
, N
);
4689 Set_Has_Pragma_Unreferenced
(Arg_Id
);
4692 Set_Has_Pragma_Unused
(Arg_Id
);
4695 -- A pragma that applies to a Ghost entity becomes Ghost
4696 -- for the purposes of legality checks and removal of
4697 -- ignored Ghost code.
4699 Mark_Ghost_Pragma
(N
, Arg_Id
);
4701 -- Capture the entity of the first Ghost name being
4702 -- processed for error detection purposes.
4704 if Is_Ghost_Entity
(Arg_Id
) then
4705 if No
(Ghost_Id
) then
4709 -- Otherwise the name is non-Ghost. It is illegal to mix
4710 -- references to Ghost and non-Ghost entities
4713 elsif Present
(Ghost_Id
)
4714 and then not Ghost_Error_Posted
4716 Ghost_Error_Posted
:= True;
4718 Error_Msg_Name_1
:= Pname
;
4720 ("pragma % cannot mention ghost and non-ghost "
4723 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4725 ("\& # declared as ghost", N
, Ghost_Id
);
4727 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4729 ("\& # declared as non-ghost", N
, Arg_Id
);
4737 end Analyze_Unreferenced_Or_Unused
;
4739 --------------------------
4740 -- Check_Ada_83_Warning --
4741 --------------------------
4743 procedure Check_Ada_83_Warning
is
4745 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4746 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4748 end Check_Ada_83_Warning
;
4750 ---------------------
4751 -- Check_Arg_Count --
4752 ---------------------
4754 procedure Check_Arg_Count
(Required
: Nat
) is
4756 if Arg_Count
/= Required
then
4757 Error_Pragma
("wrong number of arguments for pragma%");
4759 end Check_Arg_Count
;
4761 --------------------------------
4762 -- Check_Arg_Is_External_Name --
4763 --------------------------------
4765 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4766 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4769 if Nkind
(Argx
) = N_Identifier
then
4773 Analyze_And_Resolve
(Argx
, Standard_String
);
4775 if Is_OK_Static_Expression
(Argx
) then
4778 elsif Etype
(Argx
) = Any_Type
then
4781 -- An interesting special case, if we have a string literal and
4782 -- we are in Ada 83 mode, then we allow it even though it will
4783 -- not be flagged as static. This allows expected Ada 83 mode
4784 -- use of external names which are string literals, even though
4785 -- technically these are not static in Ada 83.
4787 elsif Ada_Version
= Ada_83
4788 and then Nkind
(Argx
) = N_String_Literal
4792 -- Static expression that raises Constraint_Error. This has
4793 -- already been flagged, so just exit from pragma processing.
4795 elsif Is_OK_Static_Expression
(Argx
) then
4798 -- Here we have a real error (non-static expression)
4801 Error_Msg_Name_1
:= Pname
;
4804 Msg
: constant String :=
4805 "argument for pragma% must be a identifier or "
4806 & "static string expression!";
4808 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
4813 end Check_Arg_Is_External_Name
;
4815 -----------------------------
4816 -- Check_Arg_Is_Identifier --
4817 -----------------------------
4819 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
4820 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4822 if Nkind
(Argx
) /= N_Identifier
then
4824 ("argument for pragma% must be identifier", Argx
);
4826 end Check_Arg_Is_Identifier
;
4828 ----------------------------------
4829 -- Check_Arg_Is_Integer_Literal --
4830 ----------------------------------
4832 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
4833 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4835 if Nkind
(Argx
) /= N_Integer_Literal
then
4837 ("argument for pragma% must be integer literal", Argx
);
4839 end Check_Arg_Is_Integer_Literal
;
4841 -------------------------------------------
4842 -- Check_Arg_Is_Library_Level_Local_Name --
4843 -------------------------------------------
4847 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4848 -- | library_unit_NAME
4850 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
4852 Check_Arg_Is_Local_Name
(Arg
);
4854 -- If it came from an aspect, we want to give the error just as if it
4855 -- came from source.
4857 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
4858 and then (Comes_From_Source
(N
)
4859 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
4862 ("argument for pragma% must be library level entity", Arg
);
4864 end Check_Arg_Is_Library_Level_Local_Name
;
4866 -----------------------------
4867 -- Check_Arg_Is_Local_Name --
4868 -----------------------------
4872 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4873 -- | library_unit_NAME
4875 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
4876 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4879 -- If this pragma came from an aspect specification, we don't want to
4880 -- check for this error, because that would cause spurious errors, in
4881 -- case a type is frozen in a scope more nested than the type. The
4882 -- aspect itself of course can't be anywhere but on the declaration
4885 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
4886 if From_Aspect_Specification
(Parent
(Arg
)) then
4890 -- Arg is the Expression of an N_Pragma_Argument_Association
4893 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
4900 if Nkind
(Argx
) not in N_Direct_Name
4901 and then (Nkind
(Argx
) /= N_Attribute_Reference
4902 or else Present
(Expressions
(Argx
))
4903 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
4904 and then (not Is_Entity_Name
(Argx
)
4905 or else not Is_Compilation_Unit
(Entity
(Argx
)))
4907 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
4910 -- No further check required if not an entity name
4912 if not Is_Entity_Name
(Argx
) then
4918 Ent
: constant Entity_Id
:= Entity
(Argx
);
4919 Scop
: constant Entity_Id
:= Scope
(Ent
);
4922 -- Case of a pragma applied to a compilation unit: pragma must
4923 -- occur immediately after the program unit in the compilation.
4925 if Is_Compilation_Unit
(Ent
) then
4927 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
4930 -- Case of pragma placed immediately after spec
4932 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
4935 -- Case of pragma placed immediately after body
4937 elsif Nkind
(Decl
) = N_Subprogram_Declaration
4938 and then Present
(Corresponding_Body
(Decl
))
4942 (Parent
(Unit_Declaration_Node
4943 (Corresponding_Body
(Decl
))));
4945 -- All other cases are illegal
4952 -- Special restricted placement rule from 10.2.1(11.8/2)
4954 elsif Is_Generic_Formal
(Ent
)
4955 and then Prag_Id
= Pragma_Preelaborable_Initialization
4957 OK
:= List_Containing
(N
) =
4958 Generic_Formal_Declarations
4959 (Unit_Declaration_Node
(Scop
));
4961 -- If this is an aspect applied to a subprogram body, the
4962 -- pragma is inserted in its declarative part.
4964 elsif From_Aspect_Specification
(N
)
4965 and then Ent
= Current_Scope
4967 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
4971 -- If the aspect is a predicate (possibly others ???) and the
4972 -- context is a record type, this is a discriminant expression
4973 -- within a type declaration, that freezes the predicated
4976 elsif From_Aspect_Specification
(N
)
4977 and then Prag_Id
= Pragma_Predicate
4978 and then Ekind
(Current_Scope
) = E_Record_Type
4979 and then Scop
= Scope
(Current_Scope
)
4983 -- Default case, just check that the pragma occurs in the scope
4984 -- of the entity denoted by the name.
4987 OK
:= Current_Scope
= Scop
;
4992 ("pragma% argument must be in same declarative part", Arg
);
4996 end Check_Arg_Is_Local_Name
;
4998 ---------------------------------
4999 -- Check_Arg_Is_Locking_Policy --
5000 ---------------------------------
5002 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5003 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5006 Check_Arg_Is_Identifier
(Argx
);
5008 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5009 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5011 end Check_Arg_Is_Locking_Policy
;
5013 -----------------------------------------------
5014 -- Check_Arg_Is_Partition_Elaboration_Policy --
5015 -----------------------------------------------
5017 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5018 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5021 Check_Arg_Is_Identifier
(Argx
);
5023 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5025 ("& is not a valid partition elaboration policy name", Argx
);
5027 end Check_Arg_Is_Partition_Elaboration_Policy
;
5029 -------------------------
5030 -- Check_Arg_Is_One_Of --
5031 -------------------------
5033 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5034 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5037 Check_Arg_Is_Identifier
(Argx
);
5039 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5040 Error_Msg_Name_2
:= N1
;
5041 Error_Msg_Name_3
:= N2
;
5042 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5044 end Check_Arg_Is_One_Of
;
5046 procedure Check_Arg_Is_One_Of
5048 N1
, N2
, N3
: Name_Id
)
5050 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5053 Check_Arg_Is_Identifier
(Argx
);
5055 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5056 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5058 end Check_Arg_Is_One_Of
;
5060 procedure Check_Arg_Is_One_Of
5062 N1
, N2
, N3
, N4
: Name_Id
)
5064 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5067 Check_Arg_Is_Identifier
(Argx
);
5069 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5070 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5072 end Check_Arg_Is_One_Of
;
5074 procedure Check_Arg_Is_One_Of
5076 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5078 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5081 Check_Arg_Is_Identifier
(Argx
);
5083 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5084 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5086 end Check_Arg_Is_One_Of
;
5088 ---------------------------------
5089 -- Check_Arg_Is_Queuing_Policy --
5090 ---------------------------------
5092 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5093 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5096 Check_Arg_Is_Identifier
(Argx
);
5098 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5099 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5101 end Check_Arg_Is_Queuing_Policy
;
5103 ---------------------------------------
5104 -- Check_Arg_Is_OK_Static_Expression --
5105 ---------------------------------------
5107 procedure Check_Arg_Is_OK_Static_Expression
5109 Typ
: Entity_Id
:= Empty
)
5112 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5113 end Check_Arg_Is_OK_Static_Expression
;
5115 ------------------------------------------
5116 -- Check_Arg_Is_Task_Dispatching_Policy --
5117 ------------------------------------------
5119 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5120 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5123 Check_Arg_Is_Identifier
(Argx
);
5125 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5127 ("& is not an allowed task dispatching policy name", Argx
);
5129 end Check_Arg_Is_Task_Dispatching_Policy
;
5131 ---------------------
5132 -- Check_Arg_Order --
5133 ---------------------
5135 procedure Check_Arg_Order
(Names
: Name_List
) is
5138 Highest_So_Far
: Natural := 0;
5139 -- Highest index in Names seen do far
5143 for J
in 1 .. Arg_Count
loop
5144 if Chars
(Arg
) /= No_Name
then
5145 for K
in Names
'Range loop
5146 if Chars
(Arg
) = Names
(K
) then
5147 if K
< Highest_So_Far
then
5148 Error_Msg_Name_1
:= Pname
;
5150 ("parameters out of order for pragma%", Arg
);
5151 Error_Msg_Name_1
:= Names
(K
);
5152 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5153 Error_Msg_N
("\% must appear before %", Arg
);
5157 Highest_So_Far
:= K
;
5165 end Check_Arg_Order
;
5167 --------------------------------
5168 -- Check_At_Least_N_Arguments --
5169 --------------------------------
5171 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5173 if Arg_Count
< N
then
5174 Error_Pragma
("too few arguments for pragma%");
5176 end Check_At_Least_N_Arguments
;
5178 -------------------------------
5179 -- Check_At_Most_N_Arguments --
5180 -------------------------------
5182 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5185 if Arg_Count
> N
then
5187 for J
in 1 .. N
loop
5189 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5192 end Check_At_Most_N_Arguments
;
5194 ---------------------
5195 -- Check_Component --
5196 ---------------------
5198 procedure Check_Component
5201 In_Variant_Part
: Boolean := False)
5203 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5204 Sindic
: constant Node_Id
:=
5205 Subtype_Indication
(Component_Definition
(Comp
));
5206 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5209 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5210 -- object constraint, then the component type shall be an Unchecked_
5213 if Nkind
(Sindic
) = N_Subtype_Indication
5214 and then Has_Per_Object_Constraint
(Comp_Id
)
5215 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5218 ("component subtype subject to per-object constraint "
5219 & "must be an Unchecked_Union", Comp
);
5221 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5222 -- the body of a generic unit, or within the body of any of its
5223 -- descendant library units, no part of the type of a component
5224 -- declared in a variant_part of the unchecked union type shall be of
5225 -- a formal private type or formal private extension declared within
5226 -- the formal part of the generic unit.
5228 elsif Ada_Version
>= Ada_2012
5229 and then In_Generic_Body
(UU_Typ
)
5230 and then In_Variant_Part
5231 and then Is_Private_Type
(Typ
)
5232 and then Is_Generic_Type
(Typ
)
5235 ("component of unchecked union cannot be of generic type", Comp
);
5237 elsif Needs_Finalization
(Typ
) then
5239 ("component of unchecked union cannot be controlled", Comp
);
5241 elsif Has_Task
(Typ
) then
5243 ("component of unchecked union cannot have tasks", Comp
);
5245 end Check_Component
;
5247 ----------------------------
5248 -- Check_Duplicate_Pragma --
5249 ----------------------------
5251 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5252 Id
: Entity_Id
:= E
;
5256 -- Nothing to do if this pragma comes from an aspect specification,
5257 -- since we could not be duplicating a pragma, and we dealt with the
5258 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5260 if From_Aspect_Specification
(N
) then
5264 -- Otherwise current pragma may duplicate previous pragma or a
5265 -- previously given aspect specification or attribute definition
5266 -- clause for the same pragma.
5268 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5272 -- If the entity is a type, then we have to make sure that the
5273 -- ostensible duplicate is not for a parent type from which this
5277 if Nkind
(P
) = N_Pragma
then
5279 Args
: constant List_Id
:=
5280 Pragma_Argument_Associations
(P
);
5283 and then Is_Entity_Name
(Expression
(First
(Args
)))
5284 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5285 and then Entity
(Expression
(First
(Args
))) /= E
5291 elsif Nkind
(P
) = N_Aspect_Specification
5292 and then Is_Type
(Entity
(P
))
5293 and then Entity
(P
) /= E
5299 -- Here we have a definite duplicate
5301 Error_Msg_Name_1
:= Pragma_Name
(N
);
5302 Error_Msg_Sloc
:= Sloc
(P
);
5304 -- For a single protected or a single task object, the error is
5305 -- issued on the original entity.
5307 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5308 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5311 if Nkind
(P
) = N_Aspect_Specification
5312 or else From_Aspect_Specification
(P
)
5314 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5316 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5321 end Check_Duplicate_Pragma
;
5323 ----------------------------------
5324 -- Check_Duplicated_Export_Name --
5325 ----------------------------------
5327 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5328 String_Val
: constant String_Id
:= Strval
(Nam
);
5331 -- We are only interested in the export case, and in the case of
5332 -- generics, it is the instance, not the template, that is the
5333 -- problem (the template will generate a warning in any case).
5335 if not Inside_A_Generic
5336 and then (Prag_Id
= Pragma_Export
5338 Prag_Id
= Pragma_Export_Procedure
5340 Prag_Id
= Pragma_Export_Valued_Procedure
5342 Prag_Id
= Pragma_Export_Function
)
5344 for J
in Externals
.First
.. Externals
.Last
loop
5345 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5346 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5347 Error_Msg_N
("external name duplicates name given#", Nam
);
5352 Externals
.Append
(Nam
);
5354 end Check_Duplicated_Export_Name
;
5356 ----------------------------------------
5357 -- Check_Expr_Is_OK_Static_Expression --
5358 ----------------------------------------
5360 procedure Check_Expr_Is_OK_Static_Expression
5362 Typ
: Entity_Id
:= Empty
)
5365 if Present
(Typ
) then
5366 Analyze_And_Resolve
(Expr
, Typ
);
5368 Analyze_And_Resolve
(Expr
);
5371 -- An expression cannot be considered static if its resolution failed
5372 -- or if it's erroneous. Stop the analysis of the related pragma.
5374 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5377 elsif Is_OK_Static_Expression
(Expr
) then
5380 -- An interesting special case, if we have a string literal and we
5381 -- are in Ada 83 mode, then we allow it even though it will not be
5382 -- flagged as static. This allows the use of Ada 95 pragmas like
5383 -- Import in Ada 83 mode. They will of course be flagged with
5384 -- warnings as usual, but will not cause errors.
5386 elsif Ada_Version
= Ada_83
5387 and then Nkind
(Expr
) = N_String_Literal
5391 -- Finally, we have a real error
5394 Error_Msg_Name_1
:= Pname
;
5395 Flag_Non_Static_Expr
5396 (Fix_Error
("argument for pragma% must be a static expression!"),
5400 end Check_Expr_Is_OK_Static_Expression
;
5402 -------------------------
5403 -- Check_First_Subtype --
5404 -------------------------
5406 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5407 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5408 Ent
: constant Entity_Id
:= Entity
(Argx
);
5411 if Is_First_Subtype
(Ent
) then
5414 elsif Is_Type
(Ent
) then
5416 ("pragma% cannot apply to subtype", Argx
);
5418 elsif Is_Object
(Ent
) then
5420 ("pragma% cannot apply to object, requires a type", Argx
);
5424 ("pragma% cannot apply to&, requires a type", Argx
);
5426 end Check_First_Subtype
;
5428 ----------------------
5429 -- Check_Identifier --
5430 ----------------------
5432 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5435 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5437 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5438 Error_Msg_Name_1
:= Pname
;
5439 Error_Msg_Name_2
:= Id
;
5440 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5444 end Check_Identifier
;
5446 --------------------------------
5447 -- Check_Identifier_Is_One_Of --
5448 --------------------------------
5450 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5453 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5455 if Chars
(Arg
) = No_Name
then
5456 Error_Msg_Name_1
:= Pname
;
5457 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5460 elsif Chars
(Arg
) /= N1
5461 and then Chars
(Arg
) /= N2
5463 Error_Msg_Name_1
:= Pname
;
5464 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5468 end Check_Identifier_Is_One_Of
;
5470 ---------------------------
5471 -- Check_In_Main_Program --
5472 ---------------------------
5474 procedure Check_In_Main_Program
is
5475 P
: constant Node_Id
:= Parent
(N
);
5478 -- Must be in subprogram body
5480 if Nkind
(P
) /= N_Subprogram_Body
then
5481 Error_Pragma
("% pragma allowed only in subprogram");
5483 -- Otherwise warn if obviously not main program
5485 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5486 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5488 Error_Msg_Name_1
:= Pname
;
5490 ("??pragma% is only effective in main program", N
);
5492 end Check_In_Main_Program
;
5494 ---------------------------------------
5495 -- Check_Interrupt_Or_Attach_Handler --
5496 ---------------------------------------
5498 procedure Check_Interrupt_Or_Attach_Handler
is
5499 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5500 Handler_Proc
, Proc_Scope
: Entity_Id
;
5505 if Prag_Id
= Pragma_Interrupt_Handler
then
5506 Check_Restriction
(No_Dynamic_Attachment
, N
);
5509 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5510 Proc_Scope
:= Scope
(Handler_Proc
);
5512 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5514 ("argument of pragma% must be protected procedure", Arg1
);
5517 -- For pragma case (as opposed to access case), check placement.
5518 -- We don't need to do that for aspects, because we have the
5519 -- check that they aspect applies an appropriate procedure.
5521 if not From_Aspect_Specification
(N
)
5522 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5524 Error_Pragma
("pragma% must be in protected definition");
5527 if not Is_Library_Level_Entity
(Proc_Scope
) then
5529 ("argument for pragma% must be library level entity", Arg1
);
5532 -- AI05-0033: A pragma cannot appear within a generic body, because
5533 -- instance can be in a nested scope. The check that protected type
5534 -- is itself a library-level declaration is done elsewhere.
5536 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5537 -- handle code prior to AI-0033. Analysis tools typically are not
5538 -- interested in this pragma in any case, so no need to worry too
5539 -- much about its placement.
5541 if Inside_A_Generic
then
5542 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5543 and then In_Package_Body
(Scope
(Current_Scope
))
5544 and then not Relaxed_RM_Semantics
5546 Error_Pragma
("pragma% cannot be used inside a generic");
5549 end Check_Interrupt_Or_Attach_Handler
;
5551 ---------------------------------
5552 -- Check_Loop_Pragma_Placement --
5553 ---------------------------------
5555 procedure Check_Loop_Pragma_Placement
is
5556 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5557 -- Verify whether the current pragma is properly grouped with other
5558 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5559 -- related loop where the pragma appears.
5561 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5562 -- Determine whether an arbitrary statement Stmt denotes pragma
5563 -- Loop_Invariant or Loop_Variant.
5565 procedure Placement_Error
(Constr
: Node_Id
);
5566 pragma No_Return
(Placement_Error
);
5567 -- Node Constr denotes the last loop restricted construct before we
5568 -- encountered an illegal relation between enclosing constructs. Emit
5569 -- an error depending on what Constr was.
5571 --------------------------------
5572 -- Check_Loop_Pragma_Grouping --
5573 --------------------------------
5575 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5576 Stop_Search
: exception;
5577 -- This exception is used to terminate the recursive descent of
5578 -- routine Check_Grouping.
5580 procedure Check_Grouping
(L
: List_Id
);
5581 -- Find the first group of pragmas in list L and if successful,
5582 -- ensure that the current pragma is part of that group. The
5583 -- routine raises Stop_Search once such a check is performed to
5584 -- halt the recursive descent.
5586 procedure Grouping_Error
(Prag
: Node_Id
);
5587 pragma No_Return
(Grouping_Error
);
5588 -- Emit an error concerning the current pragma indicating that it
5589 -- should be placed after pragma Prag.
5591 --------------------
5592 -- Check_Grouping --
5593 --------------------
5595 procedure Check_Grouping
(L
: List_Id
) is
5601 -- Inspect the list of declarations or statements looking for
5602 -- the first grouping of pragmas:
5605 -- pragma Loop_Invariant ...;
5606 -- pragma Loop_Variant ...;
5608 -- pragma Loop_Variant ...; -- current pragma
5610 -- If the current pragma is not in the grouping, then it must
5611 -- either appear in a different declarative or statement list
5612 -- or the construct at (1) is separating the pragma from the
5616 while Present
(Stmt
) loop
5618 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5619 -- inside a loop or a block housed inside a loop. Inspect
5620 -- the declarations and statements of the block as they may
5621 -- contain the first grouping.
5623 if Nkind
(Stmt
) = N_Block_Statement
then
5624 HSS
:= Handled_Statement_Sequence
(Stmt
);
5626 Check_Grouping
(Declarations
(Stmt
));
5628 if Present
(HSS
) then
5629 Check_Grouping
(Statements
(HSS
));
5632 -- First pragma of the first topmost grouping has been found
5634 elsif Is_Loop_Pragma
(Stmt
) then
5636 -- The group and the current pragma are not in the same
5637 -- declarative or statement list.
5639 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5640 Grouping_Error
(Stmt
);
5642 -- Try to reach the current pragma from the first pragma
5643 -- of the grouping while skipping other members:
5645 -- pragma Loop_Invariant ...; -- first pragma
5646 -- pragma Loop_Variant ...; -- member
5648 -- pragma Loop_Variant ...; -- current pragma
5651 while Present
(Stmt
) loop
5653 -- The current pragma is either the first pragma
5654 -- of the group or is a member of the group. Stop
5655 -- the search as the placement is legal.
5660 -- Skip group members, but keep track of the last
5661 -- pragma in the group.
5663 elsif Is_Loop_Pragma
(Stmt
) then
5666 -- Skip declarations and statements generated by
5667 -- the compiler during expansion.
5669 elsif not Comes_From_Source
(Stmt
) then
5672 -- A non-pragma is separating the group from the
5673 -- current pragma, the placement is illegal.
5676 Grouping_Error
(Prag
);
5682 -- If the traversal did not reach the current pragma,
5683 -- then the list must be malformed.
5685 raise Program_Error
;
5693 --------------------
5694 -- Grouping_Error --
5695 --------------------
5697 procedure Grouping_Error
(Prag
: Node_Id
) is
5699 Error_Msg_Sloc
:= Sloc
(Prag
);
5700 Error_Pragma
("pragma% must appear next to pragma#");
5703 -- Start of processing for Check_Loop_Pragma_Grouping
5706 -- Inspect the statements of the loop or nested blocks housed
5707 -- within to determine whether the current pragma is part of the
5708 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5710 Check_Grouping
(Statements
(Loop_Stmt
));
5713 when Stop_Search
=> null;
5714 end Check_Loop_Pragma_Grouping
;
5716 --------------------
5717 -- Is_Loop_Pragma --
5718 --------------------
5720 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5722 -- Inspect the original node as Loop_Invariant and Loop_Variant
5723 -- pragmas are rewritten to null when assertions are disabled.
5725 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5727 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
5728 Name_Loop_Invariant
,
5735 ---------------------
5736 -- Placement_Error --
5737 ---------------------
5739 procedure Placement_Error
(Constr
: Node_Id
) is
5740 LA
: constant String := " with Loop_Entry";
5743 if Prag_Id
= Pragma_Assert
then
5744 Error_Msg_String
(1 .. LA
'Length) := LA
;
5745 Error_Msg_Strlen
:= LA
'Length;
5747 Error_Msg_Strlen
:= 0;
5750 if Nkind
(Constr
) = N_Pragma
then
5752 ("pragma %~ must appear immediately within the statements "
5756 ("block containing pragma %~ must appear immediately within "
5757 & "the statements of a loop", Constr
);
5759 end Placement_Error
;
5761 -- Local declarations
5766 -- Start of processing for Check_Loop_Pragma_Placement
5769 -- Check that pragma appears immediately within a loop statement,
5770 -- ignoring intervening block statements.
5774 while Present
(Stmt
) loop
5776 -- The pragma or previous block must appear immediately within the
5777 -- current block's declarative or statement part.
5779 if Nkind
(Stmt
) = N_Block_Statement
then
5780 if (No
(Declarations
(Stmt
))
5781 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
5783 List_Containing
(Prev
) /=
5784 Statements
(Handled_Statement_Sequence
(Stmt
))
5786 Placement_Error
(Prev
);
5789 -- Keep inspecting the parents because we are now within a
5790 -- chain of nested blocks.
5794 Stmt
:= Parent
(Stmt
);
5797 -- The pragma or previous block must appear immediately within the
5798 -- statements of the loop.
5800 elsif Nkind
(Stmt
) = N_Loop_Statement
then
5801 if List_Containing
(Prev
) /= Statements
(Stmt
) then
5802 Placement_Error
(Prev
);
5805 -- Stop the traversal because we reached the innermost loop
5806 -- regardless of whether we encountered an error or not.
5810 -- Ignore a handled statement sequence. Note that this node may
5811 -- be related to a subprogram body in which case we will emit an
5812 -- error on the next iteration of the search.
5814 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
5815 Stmt
:= Parent
(Stmt
);
5817 -- Any other statement breaks the chain from the pragma to the
5821 Placement_Error
(Prev
);
5826 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5827 -- grouped together with other such pragmas.
5829 if Is_Loop_Pragma
(N
) then
5831 -- The previous check should have located the related loop
5833 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
5834 Check_Loop_Pragma_Grouping
(Stmt
);
5836 end Check_Loop_Pragma_Placement
;
5838 -------------------------------------------
5839 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5840 -------------------------------------------
5842 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
5851 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
5854 elsif Nkind_In
(P
, N_Package_Specification
,
5859 -- Note: the following tests seem a little peculiar, because
5860 -- they test for bodies, but if we were in the statement part
5861 -- of the body, we would already have hit the handled statement
5862 -- sequence, so the only way we get here is by being in the
5863 -- declarative part of the body.
5865 elsif Nkind_In
(P
, N_Subprogram_Body
,
5876 Error_Pragma
("pragma% is not in declarative part or package spec");
5877 end Check_Is_In_Decl_Part_Or_Package_Spec
;
5879 -------------------------
5880 -- Check_No_Identifier --
5881 -------------------------
5883 procedure Check_No_Identifier
(Arg
: Node_Id
) is
5885 if Nkind
(Arg
) = N_Pragma_Argument_Association
5886 and then Chars
(Arg
) /= No_Name
5888 Error_Pragma_Arg_Ident
5889 ("pragma% does not permit identifier& here", Arg
);
5891 end Check_No_Identifier
;
5893 --------------------------
5894 -- Check_No_Identifiers --
5895 --------------------------
5897 procedure Check_No_Identifiers
is
5901 for J
in 1 .. Arg_Count
loop
5902 Check_No_Identifier
(Arg_Node
);
5905 end Check_No_Identifiers
;
5907 ------------------------
5908 -- Check_No_Link_Name --
5909 ------------------------
5911 procedure Check_No_Link_Name
is
5913 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
5917 if Present
(Arg4
) then
5919 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
5921 end Check_No_Link_Name
;
5923 -------------------------------
5924 -- Check_Optional_Identifier --
5925 -------------------------------
5927 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5930 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5931 and then Chars
(Arg
) /= No_Name
5933 if Chars
(Arg
) /= Id
then
5934 Error_Msg_Name_1
:= Pname
;
5935 Error_Msg_Name_2
:= Id
;
5936 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5940 end Check_Optional_Identifier
;
5942 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
5944 Name_Buffer
(1 .. Id
'Length) := Id
;
5945 Name_Len
:= Id
'Length;
5946 Check_Optional_Identifier
(Arg
, Name_Find
);
5947 end Check_Optional_Identifier
;
5949 -------------------------------------
5950 -- Check_Static_Boolean_Expression --
5951 -------------------------------------
5953 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
5955 if Present
(Expr
) then
5956 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
5958 if not Is_OK_Static_Expression
(Expr
) then
5960 ("expression of pragma % must be static", Expr
);
5963 end Check_Static_Boolean_Expression
;
5965 -----------------------------
5966 -- Check_Static_Constraint --
5967 -----------------------------
5969 -- Note: for convenience in writing this procedure, in addition to
5970 -- the officially (i.e. by spec) allowed argument which is always a
5971 -- constraint, it also allows ranges and discriminant associations.
5972 -- Above is not clear ???
5974 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
5976 procedure Require_Static
(E
: Node_Id
);
5977 -- Require given expression to be static expression
5979 --------------------
5980 -- Require_Static --
5981 --------------------
5983 procedure Require_Static
(E
: Node_Id
) is
5985 if not Is_OK_Static_Expression
(E
) then
5986 Flag_Non_Static_Expr
5987 ("non-static constraint not allowed in Unchecked_Union!", E
);
5992 -- Start of processing for Check_Static_Constraint
5995 case Nkind
(Constr
) is
5996 when N_Discriminant_Association
=>
5997 Require_Static
(Expression
(Constr
));
6000 Require_Static
(Low_Bound
(Constr
));
6001 Require_Static
(High_Bound
(Constr
));
6003 when N_Attribute_Reference
=>
6004 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6005 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6007 when N_Range_Constraint
=>
6008 Check_Static_Constraint
(Range_Expression
(Constr
));
6010 when N_Index_Or_Discriminant_Constraint
=>
6014 IDC
:= First
(Constraints
(Constr
));
6015 while Present
(IDC
) loop
6016 Check_Static_Constraint
(IDC
);
6024 end Check_Static_Constraint
;
6026 --------------------------------------
6027 -- Check_Valid_Configuration_Pragma --
6028 --------------------------------------
6030 -- A configuration pragma must appear in the context clause of a
6031 -- compilation unit, and only other pragmas may precede it. Note that
6032 -- the test also allows use in a configuration pragma file.
6034 procedure Check_Valid_Configuration_Pragma
is
6036 if not Is_Configuration_Pragma
then
6037 Error_Pragma
("incorrect placement for configuration pragma%");
6039 end Check_Valid_Configuration_Pragma
;
6041 -------------------------------------
6042 -- Check_Valid_Library_Unit_Pragma --
6043 -------------------------------------
6045 procedure Check_Valid_Library_Unit_Pragma
is
6047 Parent_Node
: Node_Id
;
6048 Unit_Name
: Entity_Id
;
6049 Unit_Kind
: Node_Kind
;
6050 Unit_Node
: Node_Id
;
6051 Sindex
: Source_File_Index
;
6054 if not Is_List_Member
(N
) then
6058 Plist
:= List_Containing
(N
);
6059 Parent_Node
:= Parent
(Plist
);
6061 if Parent_Node
= Empty
then
6064 -- Case of pragma appearing after a compilation unit. In this case
6065 -- it must have an argument with the corresponding name and must
6066 -- be part of the following pragmas of its parent.
6068 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6069 if Plist
/= Pragmas_After
(Parent_Node
) then
6072 elsif Arg_Count
= 0 then
6074 ("argument required if outside compilation unit");
6077 Check_No_Identifiers
;
6078 Check_Arg_Count
(1);
6079 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6080 Unit_Kind
:= Nkind
(Unit_Node
);
6082 Analyze
(Get_Pragma_Arg
(Arg1
));
6084 if Unit_Kind
= N_Generic_Subprogram_Declaration
6085 or else Unit_Kind
= N_Subprogram_Declaration
6087 Unit_Name
:= Defining_Entity
(Unit_Node
);
6089 elsif Unit_Kind
in N_Generic_Instantiation
then
6090 Unit_Name
:= Defining_Entity
(Unit_Node
);
6093 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6096 if Chars
(Unit_Name
) /=
6097 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6100 ("pragma% argument is not current unit name", Arg1
);
6103 if Ekind
(Unit_Name
) = E_Package
6104 and then Present
(Renamed_Entity
(Unit_Name
))
6106 Error_Pragma
("pragma% not allowed for renamed package");
6110 -- Pragma appears other than after a compilation unit
6113 -- Here we check for the generic instantiation case and also
6114 -- for the case of processing a generic formal package. We
6115 -- detect these cases by noting that the Sloc on the node
6116 -- does not belong to the current compilation unit.
6118 Sindex
:= Source_Index
(Current_Sem_Unit
);
6120 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6121 Rewrite
(N
, Make_Null_Statement
(Loc
));
6124 -- If before first declaration, the pragma applies to the
6125 -- enclosing unit, and the name if present must be this name.
6127 elsif Is_Before_First_Decl
(N
, Plist
) then
6128 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6129 Unit_Kind
:= Nkind
(Unit_Node
);
6131 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6134 elsif Unit_Kind
= N_Subprogram_Body
6135 and then not Acts_As_Spec
(Unit_Node
)
6139 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6142 elsif Nkind
(Parent_Node
) = N_Package_Specification
6143 and then Plist
= Private_Declarations
(Parent_Node
)
6147 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6148 or else Nkind
(Parent_Node
) =
6149 N_Generic_Subprogram_Declaration
)
6150 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6154 elsif Arg_Count
> 0 then
6155 Analyze
(Get_Pragma_Arg
(Arg1
));
6157 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6159 ("name in pragma% must be enclosing unit", Arg1
);
6162 -- It is legal to have no argument in this context
6168 -- Error if not before first declaration. This is because a
6169 -- library unit pragma argument must be the name of a library
6170 -- unit (RM 10.1.5(7)), but the only names permitted in this
6171 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6172 -- generic subprogram declarations or generic instantiations.
6176 ("pragma% misplaced, must be before first declaration");
6180 end Check_Valid_Library_Unit_Pragma
;
6186 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6187 Clist
: constant Node_Id
:= Component_List
(Variant
);
6191 Comp
:= First
(Component_Items
(Clist
));
6192 while Present
(Comp
) loop
6193 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6198 ---------------------------
6199 -- Ensure_Aggregate_Form --
6200 ---------------------------
6202 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6203 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6204 Expr
: constant Node_Id
:= Expression
(Arg
);
6205 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6206 Comps
: List_Id
:= No_List
;
6207 Exprs
: List_Id
:= No_List
;
6208 Nam
: Name_Id
:= No_Name
;
6209 Nam_Loc
: Source_Ptr
;
6212 -- The pragma argument is in positional form:
6214 -- pragma Depends (Nam => ...)
6218 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6219 -- argument association.
6221 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6223 Nam_Loc
:= Sloc
(Arg
);
6225 -- Remove the pragma argument name as this will be captured in the
6228 Set_Chars
(Arg
, No_Name
);
6231 -- The argument is already in aggregate form, but the presence of a
6232 -- name causes this to be interpreted as named association which in
6233 -- turn must be converted into an aggregate.
6235 -- pragma Global (In_Out => (A, B, C))
6239 -- pragma Global ((In_Out => (A, B, C)))
6241 -- aggregate aggregate
6243 if Nkind
(Expr
) = N_Aggregate
then
6244 if Nam
= No_Name
then
6248 -- Do not transform a null argument into an aggregate as N_Null has
6249 -- special meaning in formal verification pragmas.
6251 elsif Nkind
(Expr
) = N_Null
then
6255 -- Everything comes from source if the original comes from source
6257 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6259 -- Positional argument is transformed into an aggregate with an
6260 -- Expressions list.
6262 if Nam
= No_Name
then
6263 Exprs
:= New_List
(Relocate_Node
(Expr
));
6265 -- An associative argument is transformed into an aggregate with
6266 -- Component_Associations.
6270 Make_Component_Association
(Loc
,
6271 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6272 Expression
=> Relocate_Node
(Expr
)));
6275 Set_Expression
(Arg
,
6276 Make_Aggregate
(Loc
,
6277 Component_Associations
=> Comps
,
6278 Expressions
=> Exprs
));
6280 -- Restore Comes_From_Source default
6282 Set_Comes_From_Source_Default
(CFSD
);
6283 end Ensure_Aggregate_Form
;
6289 procedure Error_Pragma
(Msg
: String) is
6291 Error_Msg_Name_1
:= Pname
;
6292 Error_Msg_N
(Fix_Error
(Msg
), N
);
6296 ----------------------
6297 -- Error_Pragma_Arg --
6298 ----------------------
6300 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6302 Error_Msg_Name_1
:= Pname
;
6303 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6305 end Error_Pragma_Arg
;
6307 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6309 Error_Msg_Name_1
:= Pname
;
6310 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6311 Error_Pragma_Arg
(Msg2
, Arg
);
6312 end Error_Pragma_Arg
;
6314 ----------------------------
6315 -- Error_Pragma_Arg_Ident --
6316 ----------------------------
6318 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6320 Error_Msg_Name_1
:= Pname
;
6321 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6323 end Error_Pragma_Arg_Ident
;
6325 ----------------------
6326 -- Error_Pragma_Ref --
6327 ----------------------
6329 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6331 Error_Msg_Name_1
:= Pname
;
6332 Error_Msg_Sloc
:= Sloc
(Ref
);
6333 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6335 end Error_Pragma_Ref
;
6337 ------------------------
6338 -- Find_Lib_Unit_Name --
6339 ------------------------
6341 function Find_Lib_Unit_Name
return Entity_Id
is
6343 -- Return inner compilation unit entity, for case of nested
6344 -- categorization pragmas. This happens in generic unit.
6346 if Nkind
(Parent
(N
)) = N_Package_Specification
6347 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6349 return Defining_Entity
(Parent
(N
));
6351 return Current_Scope
;
6353 end Find_Lib_Unit_Name
;
6355 ----------------------------
6356 -- Find_Program_Unit_Name --
6357 ----------------------------
6359 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6360 Unit_Name
: Entity_Id
;
6361 Unit_Kind
: Node_Kind
;
6362 P
: constant Node_Id
:= Parent
(N
);
6365 if Nkind
(P
) = N_Compilation_Unit
then
6366 Unit_Kind
:= Nkind
(Unit
(P
));
6368 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6369 N_Package_Declaration
)
6370 or else Unit_Kind
in N_Generic_Declaration
6372 Unit_Name
:= Defining_Entity
(Unit
(P
));
6374 if Chars
(Id
) = Chars
(Unit_Name
) then
6375 Set_Entity
(Id
, Unit_Name
);
6376 Set_Etype
(Id
, Etype
(Unit_Name
));
6378 Set_Etype
(Id
, Any_Type
);
6380 ("cannot find program unit referenced by pragma%");
6384 Set_Etype
(Id
, Any_Type
);
6385 Error_Pragma
("pragma% inapplicable to this unit");
6391 end Find_Program_Unit_Name
;
6393 -----------------------------------------
6394 -- Find_Unique_Parameterless_Procedure --
6395 -----------------------------------------
6397 function Find_Unique_Parameterless_Procedure
6399 Arg
: Node_Id
) return Entity_Id
6401 Proc
: Entity_Id
:= Empty
;
6404 -- The body of this procedure needs some comments ???
6406 if not Is_Entity_Name
(Name
) then
6408 ("argument of pragma% must be entity name", Arg
);
6410 elsif not Is_Overloaded
(Name
) then
6411 Proc
:= Entity
(Name
);
6413 if Ekind
(Proc
) /= E_Procedure
6414 or else Present
(First_Formal
(Proc
))
6417 ("argument of pragma% must be parameterless procedure", Arg
);
6422 Found
: Boolean := False;
6424 Index
: Interp_Index
;
6427 Get_First_Interp
(Name
, Index
, It
);
6428 while Present
(It
.Nam
) loop
6431 if Ekind
(Proc
) = E_Procedure
6432 and then No
(First_Formal
(Proc
))
6436 Set_Entity
(Name
, Proc
);
6437 Set_Is_Overloaded
(Name
, False);
6440 ("ambiguous handler name for pragma% ", Arg
);
6444 Get_Next_Interp
(Index
, It
);
6449 ("argument of pragma% must be parameterless procedure",
6452 Proc
:= Entity
(Name
);
6458 end Find_Unique_Parameterless_Procedure
;
6464 function Fix_Error
(Msg
: String) return String is
6465 Res
: String (Msg
'Range) := Msg
;
6466 Res_Last
: Natural := Msg
'Last;
6470 -- If we have a rewriting of another pragma, go to that pragma
6472 if Is_Rewrite_Substitution
(N
)
6473 and then Nkind
(Original_Node
(N
)) = N_Pragma
6475 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6478 -- Case where pragma comes from an aspect specification
6480 if From_Aspect_Specification
(N
) then
6482 -- Change appearence of "pragma" in message to "aspect"
6485 while J
<= Res_Last
- 5 loop
6486 if Res
(J
.. J
+ 5) = "pragma" then
6487 Res
(J
.. J
+ 5) := "aspect";
6495 -- Change "argument of" at start of message to "entity for"
6498 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6500 Res
(Res
'First .. Res
'First + 9) := "entity for";
6501 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6502 Res
(Res
'First + 11 .. Res_Last
);
6503 Res_Last
:= Res_Last
- 1;
6506 -- Change "argument" at start of message to "entity"
6509 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6511 Res
(Res
'First .. Res
'First + 5) := "entity";
6512 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6513 Res
(Res
'First + 8 .. Res_Last
);
6514 Res_Last
:= Res_Last
- 2;
6517 -- Get name from corresponding aspect
6519 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6522 -- Return possibly modified message
6524 return Res
(Res
'First .. Res_Last
);
6527 -------------------------
6528 -- Gather_Associations --
6529 -------------------------
6531 procedure Gather_Associations
6533 Args
: out Args_List
)
6538 -- Initialize all parameters to Empty
6540 for J
in Args
'Range loop
6544 -- That's all we have to do if there are no argument associations
6546 if No
(Pragma_Argument_Associations
(N
)) then
6550 -- Otherwise first deal with any positional parameters present
6552 Arg
:= First
(Pragma_Argument_Associations
(N
));
6553 for Index
in Args
'Range loop
6554 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6555 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6559 -- Positional parameters all processed, if any left, then we
6560 -- have too many positional parameters.
6562 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6564 ("too many positional associations for pragma%", Arg
);
6567 -- Process named parameters if any are present
6569 while Present
(Arg
) loop
6570 if Chars
(Arg
) = No_Name
then
6572 ("positional association cannot follow named association",
6576 for Index
in Names
'Range loop
6577 if Names
(Index
) = Chars
(Arg
) then
6578 if Present
(Args
(Index
)) then
6580 ("duplicate argument association for pragma%", Arg
);
6582 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6587 if Index
= Names
'Last then
6588 Error_Msg_Name_1
:= Pname
;
6589 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6591 -- Check for possible misspelling
6593 for Index1
in Names
'Range loop
6594 if Is_Bad_Spelling_Of
6595 (Chars
(Arg
), Names
(Index1
))
6597 Error_Msg_Name_1
:= Names
(Index1
);
6598 Error_Msg_N
-- CODEFIX
6599 ("\possible misspelling of%", Arg
);
6611 end Gather_Associations
;
6617 procedure GNAT_Pragma
is
6619 -- We need to check the No_Implementation_Pragmas restriction for
6620 -- the case of a pragma from source. Note that the case of aspects
6621 -- generating corresponding pragmas marks these pragmas as not being
6622 -- from source, so this test also catches that case.
6624 if Comes_From_Source
(N
) then
6625 Check_Restriction
(No_Implementation_Pragmas
, N
);
6629 --------------------------
6630 -- Is_Before_First_Decl --
6631 --------------------------
6633 function Is_Before_First_Decl
6634 (Pragma_Node
: Node_Id
;
6635 Decls
: List_Id
) return Boolean
6637 Item
: Node_Id
:= First
(Decls
);
6640 -- Only other pragmas can come before this pragma
6643 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6646 elsif Item
= Pragma_Node
then
6652 end Is_Before_First_Decl
;
6654 -----------------------------
6655 -- Is_Configuration_Pragma --
6656 -----------------------------
6658 -- A configuration pragma must appear in the context clause of a
6659 -- compilation unit, and only other pragmas may precede it. Note that
6660 -- the test below also permits use in a configuration pragma file.
6662 function Is_Configuration_Pragma
return Boolean is
6663 Lis
: constant List_Id
:= List_Containing
(N
);
6664 Par
: constant Node_Id
:= Parent
(N
);
6668 -- If no parent, then we are in the configuration pragma file,
6669 -- so the placement is definitely appropriate.
6674 -- Otherwise we must be in the context clause of a compilation unit
6675 -- and the only thing allowed before us in the context list is more
6676 -- configuration pragmas.
6678 elsif Nkind
(Par
) = N_Compilation_Unit
6679 and then Context_Items
(Par
) = Lis
6686 elsif Nkind
(Prg
) /= N_Pragma
then
6696 end Is_Configuration_Pragma
;
6698 --------------------------
6699 -- Is_In_Context_Clause --
6700 --------------------------
6702 function Is_In_Context_Clause
return Boolean is
6704 Parent_Node
: Node_Id
;
6707 if not Is_List_Member
(N
) then
6711 Plist
:= List_Containing
(N
);
6712 Parent_Node
:= Parent
(Plist
);
6714 if Parent_Node
= Empty
6715 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6716 or else Context_Items
(Parent_Node
) /= Plist
6723 end Is_In_Context_Clause
;
6725 ---------------------------------
6726 -- Is_Static_String_Expression --
6727 ---------------------------------
6729 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6730 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6731 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6734 Analyze_And_Resolve
(Argx
);
6736 -- Special case Ada 83, where the expression will never be static,
6737 -- but we will return true if we had a string literal to start with.
6739 if Ada_Version
= Ada_83
then
6742 -- Normal case, true only if we end up with a string literal that
6743 -- is marked as being the result of evaluating a static expression.
6746 return Is_OK_Static_Expression
(Argx
)
6747 and then Nkind
(Argx
) = N_String_Literal
;
6750 end Is_Static_String_Expression
;
6752 ----------------------
6753 -- Pragma_Misplaced --
6754 ----------------------
6756 procedure Pragma_Misplaced
is
6758 Error_Pragma
("incorrect placement of pragma%");
6759 end Pragma_Misplaced
;
6761 ------------------------------------------------
6762 -- Process_Atomic_Independent_Shared_Volatile --
6763 ------------------------------------------------
6765 procedure Process_Atomic_Independent_Shared_Volatile
is
6766 procedure Set_Atomic_VFA
(E
: Entity_Id
);
6767 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6768 -- no explicit alignment was given, set alignment to unknown, since
6769 -- back end knows what the alignment requirements are for atomic and
6770 -- full access arrays. Note: this is necessary for derived types.
6772 --------------------
6773 -- Set_Atomic_VFA --
6774 --------------------
6776 procedure Set_Atomic_VFA
(E
: Entity_Id
) is
6778 if Prag_Id
= Pragma_Volatile_Full_Access
then
6779 Set_Is_Volatile_Full_Access
(E
);
6784 if not Has_Alignment_Clause
(E
) then
6785 Set_Alignment
(E
, Uint_0
);
6795 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6798 Check_Ada_83_Warning
;
6799 Check_No_Identifiers
;
6800 Check_Arg_Count
(1);
6801 Check_Arg_Is_Local_Name
(Arg1
);
6802 E_Arg
:= Get_Pragma_Arg
(Arg1
);
6804 if Etype
(E_Arg
) = Any_Type
then
6808 E
:= Entity
(E_Arg
);
6810 -- A pragma that applies to a Ghost entity becomes Ghost for the
6811 -- purposes of legality checks and removal of ignored Ghost code.
6813 Mark_Ghost_Pragma
(N
, E
);
6815 -- Check duplicate before we chain ourselves
6817 Check_Duplicate_Pragma
(E
);
6819 -- Check Atomic and VFA used together
6821 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
6822 or else (Is_Volatile_Full_Access
(E
)
6823 and then (Prag_Id
= Pragma_Atomic
6825 Prag_Id
= Pragma_Shared
))
6828 ("cannot have Volatile_Full_Access and Atomic for same entity");
6831 -- Check for applying VFA to an entity which has aliased component
6833 if Prag_Id
= Pragma_Volatile_Full_Access
then
6836 Aliased_Comp
: Boolean := False;
6837 -- Set True if aliased component present
6840 if Is_Array_Type
(Etype
(E
)) then
6841 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
6843 -- Record case, too bad Has_Aliased_Components is not also
6844 -- set for records, should it be ???
6846 elsif Is_Record_Type
(Etype
(E
)) then
6847 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
6848 while Present
(Comp
) loop
6849 if Is_Aliased
(Comp
)
6850 or else Is_Aliased
(Etype
(Comp
))
6852 Aliased_Comp
:= True;
6856 Next_Component_Or_Discriminant
(Comp
);
6860 if Aliased_Comp
then
6862 ("cannot apply Volatile_Full_Access (aliased component "
6868 -- Now check appropriateness of the entity
6870 Decl
:= Declaration_Node
(E
);
6873 if Rep_Item_Too_Early
(E
, N
)
6875 Rep_Item_Too_Late
(E
, N
)
6879 Check_First_Subtype
(Arg1
);
6882 -- Attribute belongs on the base type. If the view of the type is
6883 -- currently private, it also belongs on the underlying type.
6885 if Prag_Id
= Pragma_Atomic
6887 Prag_Id
= Pragma_Shared
6889 Prag_Id
= Pragma_Volatile_Full_Access
6892 Set_Atomic_VFA
(Base_Type
(E
));
6893 Set_Atomic_VFA
(Underlying_Type
(E
));
6896 -- Atomic/Shared/Volatile_Full_Access imply Independent
6898 if Prag_Id
/= Pragma_Volatile
then
6899 Set_Is_Independent
(E
);
6900 Set_Is_Independent
(Base_Type
(E
));
6901 Set_Is_Independent
(Underlying_Type
(E
));
6903 if Prag_Id
= Pragma_Independent
then
6904 Record_Independence_Check
(N
, Base_Type
(E
));
6908 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6910 if Prag_Id
/= Pragma_Independent
then
6911 Set_Is_Volatile
(E
);
6912 Set_Is_Volatile
(Base_Type
(E
));
6913 Set_Is_Volatile
(Underlying_Type
(E
));
6915 Set_Treat_As_Volatile
(E
);
6916 Set_Treat_As_Volatile
(Underlying_Type
(E
));
6919 elsif Nkind
(Decl
) = N_Object_Declaration
6920 or else (Nkind
(Decl
) = N_Component_Declaration
6921 and then Original_Record_Component
(E
) = E
)
6923 if Rep_Item_Too_Late
(E
, N
) then
6927 if Prag_Id
= Pragma_Atomic
6929 Prag_Id
= Pragma_Shared
6931 Prag_Id
= Pragma_Volatile_Full_Access
6933 if Prag_Id
= Pragma_Volatile_Full_Access
then
6934 Set_Is_Volatile_Full_Access
(E
);
6939 -- If the object declaration has an explicit initialization, a
6940 -- temporary may have to be created to hold the expression, to
6941 -- ensure that access to the object remain atomic.
6943 if Nkind
(Parent
(E
)) = N_Object_Declaration
6944 and then Present
(Expression
(Parent
(E
)))
6946 Set_Has_Delayed_Freeze
(E
);
6950 -- Atomic/Shared/Volatile_Full_Access imply Independent
6952 if Prag_Id
/= Pragma_Volatile
then
6953 Set_Is_Independent
(E
);
6955 if Prag_Id
= Pragma_Independent
then
6956 Record_Independence_Check
(N
, E
);
6960 -- Atomic/Shared/Volatile_Full_Access imply Volatile
6962 if Prag_Id
/= Pragma_Independent
then
6963 Set_Is_Volatile
(E
);
6964 Set_Treat_As_Volatile
(E
);
6968 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
6971 -- The following check is only relevant when SPARK_Mode is on as
6972 -- this is not a standard Ada legality rule. Pragma Volatile can
6973 -- only apply to a full type declaration or an object declaration
6974 -- (SPARK RM C.6(1)). Original_Node is necessary to account for
6975 -- untagged derived types that are rewritten as subtypes of their
6976 -- respective root types.
6979 and then Prag_Id
= Pragma_Volatile
6981 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
6982 N_Object_Declaration
)
6985 ("argument of pragma % must denote a full type or object "
6986 & "declaration", Arg1
);
6988 end Process_Atomic_Independent_Shared_Volatile
;
6990 -------------------------------------------
6991 -- Process_Compile_Time_Warning_Or_Error --
6992 -------------------------------------------
6994 procedure Process_Compile_Time_Warning_Or_Error
is
6995 Validation_Needed
: Boolean := False;
6997 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
6998 -- Tree visitor that checks if N is an attribute reference that can
6999 -- be statically computed by the back end. Validation_Needed is set
7000 -- to True if found.
7006 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7008 if Nkind
(N
) = N_Attribute_Reference
7009 and then Is_Entity_Name
(Prefix
(N
))
7012 Attr_Id
: constant Attribute_Id
:=
7013 Get_Attribute_Id
(Attribute_Name
(N
));
7015 if Attr_Id
= Attribute_Alignment
7016 or else Attr_Id
= Attribute_Size
7018 Validation_Needed
:= True;
7026 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7030 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7032 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7035 Check_Arg_Count
(2);
7036 Check_No_Identifiers
;
7037 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7038 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7040 if Compile_Time_Known_Value
(Arg1x
) then
7041 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7043 -- Register the expression for its validation after the back end has
7044 -- been called if it has occurrences of attributes Size or Alignment
7045 -- (because they may be statically computed by the back end and hence
7046 -- the whole expression needs to be reevaluated).
7049 Check_Expression
(Arg1x
);
7051 if Validation_Needed
then
7052 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7055 end Process_Compile_Time_Warning_Or_Error
;
7057 ------------------------
7058 -- Process_Convention --
7059 ------------------------
7061 procedure Process_Convention
7062 (C
: out Convention_Id
;
7063 Ent
: out Entity_Id
)
7067 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7068 -- Called if we have more than one Export/Import/Convention pragma.
7069 -- This is generally illegal, but we have a special case of allowing
7070 -- Import and Interface to coexist if they specify the convention in
7071 -- a consistent manner. We are allowed to do this, since Interface is
7072 -- an implementation defined pragma, and we choose to do it since we
7073 -- know Rational allows this combination. S is the entity id of the
7074 -- subprogram in question. This procedure also sets the special flag
7075 -- Import_Interface_Present in both pragmas in the case where we do
7076 -- have matching Import and Interface pragmas.
7078 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7079 -- Set convention in entity E, and also flag that the entity has a
7080 -- convention pragma. If entity is for a private or incomplete type,
7081 -- also set convention and flag on underlying type. This procedure
7082 -- also deals with the special case of C_Pass_By_Copy convention,
7083 -- and error checks for inappropriate convention specification.
7085 -------------------------------
7086 -- Diagnose_Multiple_Pragmas --
7087 -------------------------------
7089 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7090 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7094 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7095 -- Decl is a pragma node. This function returns True if this
7096 -- pragma has a first argument that is an identifier with a
7097 -- Chars field corresponding to the Convention_Id C.
7099 function Same_Name
(Decl
: Node_Id
) return Boolean;
7100 -- Decl is a pragma node. This function returns True if this
7101 -- pragma has a second argument that is an identifier with a
7102 -- Chars field that matches the Chars of the current subprogram.
7104 ---------------------
7105 -- Same_Convention --
7106 ---------------------
7108 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7109 Arg1
: constant Node_Id
:=
7110 First
(Pragma_Argument_Associations
(Decl
));
7113 if Present
(Arg1
) then
7115 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7117 if Nkind
(Arg
) = N_Identifier
7118 and then Is_Convention_Name
(Chars
(Arg
))
7119 and then Get_Convention_Id
(Chars
(Arg
)) = C
7127 end Same_Convention
;
7133 function Same_Name
(Decl
: Node_Id
) return Boolean is
7134 Arg1
: constant Node_Id
:=
7135 First
(Pragma_Argument_Associations
(Decl
));
7143 Arg2
:= Next
(Arg1
);
7150 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7152 if Nkind
(Arg
) = N_Identifier
7153 and then Chars
(Arg
) = Chars
(S
)
7162 -- Start of processing for Diagnose_Multiple_Pragmas
7167 -- Definitely give message if we have Convention/Export here
7169 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7172 -- If we have an Import or Export, scan back from pragma to
7173 -- find any previous pragma applying to the same procedure.
7174 -- The scan will be terminated by the start of the list, or
7175 -- hitting the subprogram declaration. This won't allow one
7176 -- pragma to appear in the public part and one in the private
7177 -- part, but that seems very unlikely in practice.
7181 while Present
(Decl
) and then Decl
/= Pdec
loop
7183 -- Look for pragma with same name as us
7185 if Nkind
(Decl
) = N_Pragma
7186 and then Same_Name
(Decl
)
7188 -- Give error if same as our pragma or Export/Convention
7190 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7193 Pragma_Name_Unmapped
(N
))
7197 -- Case of Import/Interface or the other way round
7199 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7200 Name_Interface
, Name_Import
)
7202 -- Here we know that we have Import and Interface. It
7203 -- doesn't matter which way round they are. See if
7204 -- they specify the same convention. If so, all OK,
7205 -- and set special flags to stop other messages
7207 if Same_Convention
(Decl
) then
7208 Set_Import_Interface_Present
(N
);
7209 Set_Import_Interface_Present
(Decl
);
7212 -- If different conventions, special message
7215 Error_Msg_Sloc
:= Sloc
(Decl
);
7217 ("convention differs from that given#", Arg1
);
7227 -- Give message if needed if we fall through those tests
7228 -- except on Relaxed_RM_Semantics where we let go: either this
7229 -- is a case accepted/ignored by other Ada compilers (e.g.
7230 -- a mix of Convention and Import), or another error will be
7231 -- generated later (e.g. using both Import and Export).
7233 if Err
and not Relaxed_RM_Semantics
then
7235 ("at most one Convention/Export/Import pragma is allowed",
7238 end Diagnose_Multiple_Pragmas
;
7240 --------------------------------
7241 -- Set_Convention_From_Pragma --
7242 --------------------------------
7244 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7246 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7247 -- for an overridden dispatching operation. Technically this is
7248 -- an amendment and should only be done in Ada 2005 mode. However,
7249 -- this is clearly a mistake, since the problem that is addressed
7250 -- by this AI is that there is a clear gap in the RM.
7252 if Is_Dispatching_Operation
(E
)
7253 and then Present
(Overridden_Operation
(E
))
7254 and then C
/= Convention
(Overridden_Operation
(E
))
7257 ("cannot change convention for overridden dispatching "
7258 & "operation", Arg1
);
7261 -- Special checks for Convention_Stdcall
7263 if C
= Convention_Stdcall
then
7265 -- A dispatching call is not allowed. A dispatching subprogram
7266 -- cannot be used to interface to the Win32 API, so in fact
7267 -- this check does not impose any effective restriction.
7269 if Is_Dispatching_Operation
(E
) then
7270 Error_Msg_Sloc
:= Sloc
(E
);
7272 -- Note: make this unconditional so that if there is more
7273 -- than one call to which the pragma applies, we get a
7274 -- message for each call. Also don't use Error_Pragma,
7275 -- so that we get multiple messages.
7278 ("dispatching subprogram# cannot use Stdcall convention!",
7281 -- Subprograms are not allowed
7283 elsif not Is_Subprogram_Or_Generic_Subprogram
(E
)
7287 and then Ekind
(E
) /= E_Variable
7289 -- An access to subprogram is also allowed
7293 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7295 -- Allow internal call to set convention of subprogram type
7297 and then not (Ekind
(E
) = E_Subprogram_Type
)
7300 ("second argument of pragma% must be subprogram (type)",
7305 -- Set the convention
7307 Set_Convention
(E
, C
);
7308 Set_Has_Convention_Pragma
(E
);
7310 -- For the case of a record base type, also set the convention of
7311 -- any anonymous access types declared in the record which do not
7312 -- currently have a specified convention.
7314 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7319 Comp
:= First_Component
(E
);
7320 while Present
(Comp
) loop
7321 if Present
(Etype
(Comp
))
7322 and then Ekind_In
(Etype
(Comp
),
7323 E_Anonymous_Access_Type
,
7324 E_Anonymous_Access_Subprogram_Type
)
7325 and then not Has_Convention_Pragma
(Comp
)
7327 Set_Convention
(Comp
, C
);
7330 Next_Component
(Comp
);
7335 -- Deal with incomplete/private type case, where underlying type
7336 -- is available, so set convention of that underlying type.
7338 if Is_Incomplete_Or_Private_Type
(E
)
7339 and then Present
(Underlying_Type
(E
))
7341 Set_Convention
(Underlying_Type
(E
), C
);
7342 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7345 -- A class-wide type should inherit the convention of the specific
7346 -- root type (although this isn't specified clearly by the RM).
7348 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7349 Set_Convention
(Class_Wide_Type
(E
), C
);
7352 -- If the entity is a record type, then check for special case of
7353 -- C_Pass_By_Copy, which is treated the same as C except that the
7354 -- special record flag is set. This convention is only permitted
7355 -- on record types (see AI95-00131).
7357 if Cname
= Name_C_Pass_By_Copy
then
7358 if Is_Record_Type
(E
) then
7359 Set_C_Pass_By_Copy
(Base_Type
(E
));
7360 elsif Is_Incomplete_Or_Private_Type
(E
)
7361 and then Is_Record_Type
(Underlying_Type
(E
))
7363 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7366 ("C_Pass_By_Copy convention allowed only for record type",
7371 -- If the entity is a derived boolean type, check for the special
7372 -- case of convention C, C++, or Fortran, where we consider any
7373 -- nonzero value to represent true.
7375 if Is_Discrete_Type
(E
)
7376 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7382 C
= Convention_Fortran
)
7384 Set_Nonzero_Is_True
(Base_Type
(E
));
7386 end Set_Convention_From_Pragma
;
7390 Comp_Unit
: Unit_Number_Type
;
7395 -- Start of processing for Process_Convention
7398 Check_At_Least_N_Arguments
(2);
7399 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7400 Check_Arg_Is_Identifier
(Arg1
);
7401 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7403 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7404 -- tested again below to set the critical flag).
7406 if Cname
= Name_C_Pass_By_Copy
then
7409 -- Otherwise we must have something in the standard convention list
7411 elsif Is_Convention_Name
(Cname
) then
7412 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7414 -- Otherwise warn on unrecognized convention
7417 if Warn_On_Export_Import
then
7419 ("??unrecognized convention name, C assumed",
7420 Get_Pragma_Arg
(Arg1
));
7426 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7427 Check_Arg_Is_Local_Name
(Arg2
);
7429 Id
:= Get_Pragma_Arg
(Arg2
);
7432 if not Is_Entity_Name
(Id
) then
7433 Error_Pragma_Arg
("entity name required", Arg2
);
7438 -- Set entity to return
7442 -- Ada_Pass_By_Copy special checking
7444 if C
= Convention_Ada_Pass_By_Copy
then
7445 if not Is_First_Subtype
(E
) then
7447 ("convention `Ada_Pass_By_Copy` only allowed for types",
7451 if Is_By_Reference_Type
(E
) then
7453 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7457 -- Ada_Pass_By_Reference special checking
7459 elsif C
= Convention_Ada_Pass_By_Reference
then
7460 if not Is_First_Subtype
(E
) then
7462 ("convention `Ada_Pass_By_Reference` only allowed for types",
7466 if Is_By_Copy_Type
(E
) then
7468 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7473 -- Go to renamed subprogram if present, since convention applies to
7474 -- the actual renamed entity, not to the renaming entity. If the
7475 -- subprogram is inherited, go to parent subprogram.
7477 if Is_Subprogram
(E
)
7478 and then Present
(Alias
(E
))
7480 if Nkind
(Parent
(Declaration_Node
(E
))) =
7481 N_Subprogram_Renaming_Declaration
7483 if Scope
(E
) /= Scope
(Alias
(E
)) then
7485 ("cannot apply pragma% to non-local entity&#", E
);
7490 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7491 N_Private_Extension_Declaration
)
7492 and then Scope
(E
) = Scope
(Alias
(E
))
7496 -- Return the parent subprogram the entity was inherited from
7502 -- Check that we are not applying this to a specless body. Relax this
7503 -- check if Relaxed_RM_Semantics to accomodate other Ada compilers.
7505 if Is_Subprogram
(E
)
7506 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7507 and then not Relaxed_RM_Semantics
7510 ("pragma% requires separate spec and must come before body");
7513 -- Check that we are not applying this to a named constant
7515 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7516 Error_Msg_Name_1
:= Pname
;
7518 ("cannot apply pragma% to named constant!",
7519 Get_Pragma_Arg
(Arg2
));
7521 ("\supply appropriate type for&!", Arg2
);
7524 if Ekind
(E
) = E_Enumeration_Literal
then
7525 Error_Pragma
("enumeration literal not allowed for pragma%");
7528 -- Check for rep item appearing too early or too late
7530 if Etype
(E
) = Any_Type
7531 or else Rep_Item_Too_Early
(E
, N
)
7535 elsif Present
(Underlying_Type
(E
)) then
7536 E
:= Underlying_Type
(E
);
7539 if Rep_Item_Too_Late
(E
, N
) then
7543 if Has_Convention_Pragma
(E
) then
7544 Diagnose_Multiple_Pragmas
(E
);
7546 elsif Convention
(E
) = Convention_Protected
7547 or else Ekind
(Scope
(E
)) = E_Protected_Type
7550 ("a protected operation cannot be given a different convention",
7554 -- For Intrinsic, a subprogram is required
7556 if C
= Convention_Intrinsic
7557 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7559 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7561 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7563 ("second argument of pragma% must be a subprogram", Arg2
);
7567 -- Deal with non-subprogram cases
7569 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7570 Set_Convention_From_Pragma
(E
);
7574 -- The pragma must apply to a first subtype, but it can also
7575 -- apply to a generic type in a generic formal part, in which
7576 -- case it will also appear in the corresponding instance.
7578 if Is_Generic_Type
(E
) or else In_Instance
then
7581 Check_First_Subtype
(Arg2
);
7584 Set_Convention_From_Pragma
(Base_Type
(E
));
7586 -- For access subprograms, we must set the convention on the
7587 -- internally generated directly designated type as well.
7589 if Ekind
(E
) = E_Access_Subprogram_Type
then
7590 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7594 -- For the subprogram case, set proper convention for all homonyms
7595 -- in same scope and the same declarative part, i.e. the same
7596 -- compilation unit.
7599 Comp_Unit
:= Get_Source_Unit
(E
);
7600 Set_Convention_From_Pragma
(E
);
7602 -- Treat a pragma Import as an implicit body, and pragma import
7603 -- as implicit reference (for navigation in GPS).
7605 if Prag_Id
= Pragma_Import
then
7606 Generate_Reference
(E
, Id
, 'b');
7608 -- For exported entities we restrict the generation of references
7609 -- to entities exported to foreign languages since entities
7610 -- exported to Ada do not provide further information to GPS and
7611 -- add undesired references to the output of the gnatxref tool.
7613 elsif Prag_Id
= Pragma_Export
7614 and then Convention
(E
) /= Convention_Ada
7616 Generate_Reference
(E
, Id
, 'i');
7619 -- If the pragma comes from an aspect, it only applies to the
7620 -- given entity, not its homonyms.
7622 if From_Aspect_Specification
(N
) then
7626 -- Otherwise Loop through the homonyms of the pragma argument's
7627 -- entity, an apply convention to those in the current scope.
7633 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7635 -- Ignore entry for which convention is already set
7637 if Has_Convention_Pragma
(E1
) then
7641 if Is_Subprogram
(E1
)
7642 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
7644 and then not Relaxed_RM_Semantics
7646 Set_Has_Completion
(E
); -- to prevent cascaded error
7648 ("pragma% requires separate spec and must come before "
7652 -- Do not set the pragma on inherited operations or on formal
7655 if Comes_From_Source
(E1
)
7656 and then Comp_Unit
= Get_Source_Unit
(E1
)
7657 and then not Is_Formal_Subprogram
(E1
)
7658 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7659 N_Full_Type_Declaration
7661 if Present
(Alias
(E1
))
7662 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7665 ("cannot apply pragma% to non-local entity& declared#",
7669 Set_Convention_From_Pragma
(E1
);
7671 if Prag_Id
= Pragma_Import
then
7672 Generate_Reference
(E1
, Id
, 'b');
7680 end Process_Convention
;
7682 ----------------------------------------
7683 -- Process_Disable_Enable_Atomic_Sync --
7684 ----------------------------------------
7686 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7688 Check_No_Identifiers
;
7689 Check_At_Most_N_Arguments
(1);
7691 -- Modeled internally as
7692 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7697 Pragma_Argument_Associations
=> New_List
(
7698 Make_Pragma_Argument_Association
(Loc
,
7700 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7702 if Present
(Arg1
) then
7703 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7707 end Process_Disable_Enable_Atomic_Sync
;
7709 -------------------------------------------------
7710 -- Process_Extended_Import_Export_Internal_Arg --
7711 -------------------------------------------------
7713 procedure Process_Extended_Import_Export_Internal_Arg
7714 (Arg_Internal
: Node_Id
:= Empty
)
7717 if No
(Arg_Internal
) then
7718 Error_Pragma
("Internal parameter required for pragma%");
7721 if Nkind
(Arg_Internal
) = N_Identifier
then
7724 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7725 and then (Prag_Id
= Pragma_Import_Function
7727 Prag_Id
= Pragma_Export_Function
)
7733 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7736 Check_Arg_Is_Local_Name
(Arg_Internal
);
7737 end Process_Extended_Import_Export_Internal_Arg
;
7739 --------------------------------------------------
7740 -- Process_Extended_Import_Export_Object_Pragma --
7741 --------------------------------------------------
7743 procedure Process_Extended_Import_Export_Object_Pragma
7744 (Arg_Internal
: Node_Id
;
7745 Arg_External
: Node_Id
;
7751 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7752 Def_Id
:= Entity
(Arg_Internal
);
7754 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7756 ("pragma% must designate an object", Arg_Internal
);
7759 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7761 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7764 ("previous Common/Psect_Object applies, pragma % not permitted",
7768 if Rep_Item_Too_Late
(Def_Id
, N
) then
7772 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7774 if Present
(Arg_Size
) then
7775 Check_Arg_Is_External_Name
(Arg_Size
);
7778 -- Export_Object case
7780 if Prag_Id
= Pragma_Export_Object
then
7781 if not Is_Library_Level_Entity
(Def_Id
) then
7783 ("argument for pragma% must be library level entity",
7787 if Ekind
(Current_Scope
) = E_Generic_Package
then
7788 Error_Pragma
("pragma& cannot appear in a generic unit");
7791 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7793 ("exported object must have compile time known size",
7797 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7798 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7800 Set_Exported
(Def_Id
, Arg_Internal
);
7803 -- Import_Object case
7806 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7808 ("cannot use pragma% for task/protected object",
7812 if Ekind
(Def_Id
) = E_Constant
then
7814 ("cannot import a constant", Arg_Internal
);
7817 if Warn_On_Export_Import
7818 and then Has_Discriminants
(Etype
(Def_Id
))
7821 ("imported value must be initialized??", Arg_Internal
);
7824 if Warn_On_Export_Import
7825 and then Is_Access_Type
(Etype
(Def_Id
))
7828 ("cannot import object of an access type??", Arg_Internal
);
7831 if Warn_On_Export_Import
7832 and then Is_Imported
(Def_Id
)
7834 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7836 -- Check for explicit initialization present. Note that an
7837 -- initialization generated by the code generator, e.g. for an
7838 -- access type, does not count here.
7840 elsif Present
(Expression
(Parent
(Def_Id
)))
7843 (Original_Node
(Expression
(Parent
(Def_Id
))))
7845 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7847 ("imported entities cannot be initialized (RM B.1(24))",
7848 "\no initialization allowed for & declared#", Arg1
);
7850 Set_Imported
(Def_Id
);
7851 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7854 end Process_Extended_Import_Export_Object_Pragma
;
7856 ------------------------------------------------------
7857 -- Process_Extended_Import_Export_Subprogram_Pragma --
7858 ------------------------------------------------------
7860 procedure Process_Extended_Import_Export_Subprogram_Pragma
7861 (Arg_Internal
: Node_Id
;
7862 Arg_External
: Node_Id
;
7863 Arg_Parameter_Types
: Node_Id
;
7864 Arg_Result_Type
: Node_Id
:= Empty
;
7865 Arg_Mechanism
: Node_Id
;
7866 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7872 Ambiguous
: Boolean;
7875 function Same_Base_Type
7877 Formal
: Entity_Id
) return Boolean;
7878 -- Determines if Ptype references the type of Formal. Note that only
7879 -- the base types need to match according to the spec. Ptype here is
7880 -- the argument from the pragma, which is either a type name, or an
7881 -- access attribute.
7883 --------------------
7884 -- Same_Base_Type --
7885 --------------------
7887 function Same_Base_Type
7889 Formal
: Entity_Id
) return Boolean
7891 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
7895 -- Case where pragma argument is typ'Access
7897 if Nkind
(Ptype
) = N_Attribute_Reference
7898 and then Attribute_Name
(Ptype
) = Name_Access
7900 Pref
:= Prefix
(Ptype
);
7903 if not Is_Entity_Name
(Pref
)
7904 or else Entity
(Pref
) = Any_Type
7909 -- We have a match if the corresponding argument is of an
7910 -- anonymous access type, and its designated type matches the
7911 -- type of the prefix of the access attribute
7913 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
7914 and then Base_Type
(Entity
(Pref
)) =
7915 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
7917 -- Case where pragma argument is a type name
7922 if not Is_Entity_Name
(Ptype
)
7923 or else Entity
(Ptype
) = Any_Type
7928 -- We have a match if the corresponding argument is of the type
7929 -- given in the pragma (comparing base types)
7931 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
7935 -- Start of processing for
7936 -- Process_Extended_Import_Export_Subprogram_Pragma
7939 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7943 -- Loop through homonyms (overloadings) of the entity
7945 Hom_Id
:= Entity
(Arg_Internal
);
7946 while Present
(Hom_Id
) loop
7947 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
7949 -- We need a subprogram in the current scope
7951 if not Is_Subprogram
(Def_Id
)
7952 or else Scope
(Def_Id
) /= Current_Scope
7959 -- Pragma cannot apply to subprogram body
7961 if Is_Subprogram
(Def_Id
)
7962 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
7966 ("pragma% requires separate spec"
7967 & " and must come before body");
7970 -- Test result type if given, note that the result type
7971 -- parameter can only be present for the function cases.
7973 if Present
(Arg_Result_Type
)
7974 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
7978 elsif Etype
(Def_Id
) /= Standard_Void_Type
7980 Nam_In
(Pname
, Name_Export_Procedure
, Name_Import_Procedure
)
7984 -- Test parameter types if given. Note that this parameter
7985 -- has not been analyzed (and must not be, since it is
7986 -- semantic nonsense), so we get it as the parser left it.
7988 elsif Present
(Arg_Parameter_Types
) then
7989 Check_Matching_Types
: declare
7994 Formal
:= First_Formal
(Def_Id
);
7996 if Nkind
(Arg_Parameter_Types
) = N_Null
then
7997 if Present
(Formal
) then
8001 -- A list of one type, e.g. (List) is parsed as
8002 -- a parenthesized expression.
8004 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8005 and then Paren_Count
(Arg_Parameter_Types
) = 1
8008 or else Present
(Next_Formal
(Formal
))
8013 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8016 -- A list of more than one type is parsed as a aggregate
8018 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8019 and then Paren_Count
(Arg_Parameter_Types
) = 0
8021 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8022 while Present
(Ptype
) or else Present
(Formal
) loop
8025 or else not Same_Base_Type
(Ptype
, Formal
)
8030 Next_Formal
(Formal
);
8035 -- Anything else is of the wrong form
8039 ("wrong form for Parameter_Types parameter",
8040 Arg_Parameter_Types
);
8042 end Check_Matching_Types
;
8045 -- Match is now False if the entry we found did not match
8046 -- either a supplied Parameter_Types or Result_Types argument
8052 -- Ambiguous case, the flag Ambiguous shows if we already
8053 -- detected this and output the initial messages.
8056 if not Ambiguous
then
8058 Error_Msg_Name_1
:= Pname
;
8060 ("pragma% does not uniquely identify subprogram!",
8062 Error_Msg_Sloc
:= Sloc
(Ent
);
8063 Error_Msg_N
("matching subprogram #!", N
);
8067 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8068 Error_Msg_N
("matching subprogram #!", N
);
8073 Hom_Id
:= Homonym
(Hom_Id
);
8076 -- See if we found an entry
8079 if not Ambiguous
then
8080 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8082 ("pragma% cannot be given for generic subprogram");
8085 ("pragma% does not identify local subprogram");
8092 -- Import pragmas must be for imported entities
8094 if Prag_Id
= Pragma_Import_Function
8096 Prag_Id
= Pragma_Import_Procedure
8098 Prag_Id
= Pragma_Import_Valued_Procedure
8100 if not Is_Imported
(Ent
) then
8102 ("pragma Import or Interface must precede pragma%");
8105 -- Here we have the Export case which can set the entity as exported
8107 -- But does not do so if the specified external name is null, since
8108 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8109 -- compatible) to request no external name.
8111 elsif Nkind
(Arg_External
) = N_String_Literal
8112 and then String_Length
(Strval
(Arg_External
)) = 0
8116 -- In all other cases, set entity as exported
8119 Set_Exported
(Ent
, Arg_Internal
);
8122 -- Special processing for Valued_Procedure cases
8124 if Prag_Id
= Pragma_Import_Valued_Procedure
8126 Prag_Id
= Pragma_Export_Valued_Procedure
8128 Formal
:= First_Formal
(Ent
);
8131 Error_Pragma
("at least one parameter required for pragma%");
8133 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8134 Error_Pragma
("first parameter must have mode out for pragma%");
8137 Set_Is_Valued_Procedure
(Ent
);
8141 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8143 -- Process Result_Mechanism argument if present. We have already
8144 -- checked that this is only allowed for the function case.
8146 if Present
(Arg_Result_Mechanism
) then
8147 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8150 -- Process Mechanism parameter if present. Note that this parameter
8151 -- is not analyzed, and must not be analyzed since it is semantic
8152 -- nonsense, so we get it in exactly as the parser left it.
8154 if Present
(Arg_Mechanism
) then
8162 -- A single mechanism association without a formal parameter
8163 -- name is parsed as a parenthesized expression. All other
8164 -- cases are parsed as aggregates, so we rewrite the single
8165 -- parameter case as an aggregate for consistency.
8167 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8168 and then Paren_Count
(Arg_Mechanism
) = 1
8170 Rewrite
(Arg_Mechanism
,
8171 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8172 Expressions
=> New_List
(
8173 Relocate_Node
(Arg_Mechanism
))));
8176 -- Case of only mechanism name given, applies to all formals
8178 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8179 Formal
:= First_Formal
(Ent
);
8180 while Present
(Formal
) loop
8181 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8182 Next_Formal
(Formal
);
8185 -- Case of list of mechanism associations given
8188 if Null_Record_Present
(Arg_Mechanism
) then
8190 ("inappropriate form for Mechanism parameter",
8194 -- Deal with positional ones first
8196 Formal
:= First_Formal
(Ent
);
8198 if Present
(Expressions
(Arg_Mechanism
)) then
8199 Mname
:= First
(Expressions
(Arg_Mechanism
));
8200 while Present
(Mname
) loop
8203 ("too many mechanism associations", Mname
);
8206 Set_Mechanism_Value
(Formal
, Mname
);
8207 Next_Formal
(Formal
);
8212 -- Deal with named entries
8214 if Present
(Component_Associations
(Arg_Mechanism
)) then
8215 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8216 while Present
(Massoc
) loop
8217 Choice
:= First
(Choices
(Massoc
));
8219 if Nkind
(Choice
) /= N_Identifier
8220 or else Present
(Next
(Choice
))
8223 ("incorrect form for mechanism association",
8227 Formal
:= First_Formal
(Ent
);
8231 ("parameter name & not present", Choice
);
8234 if Chars
(Choice
) = Chars
(Formal
) then
8236 (Formal
, Expression
(Massoc
));
8238 -- Set entity on identifier (needed by ASIS)
8240 Set_Entity
(Choice
, Formal
);
8245 Next_Formal
(Formal
);
8254 end Process_Extended_Import_Export_Subprogram_Pragma
;
8256 --------------------------
8257 -- Process_Generic_List --
8258 --------------------------
8260 procedure Process_Generic_List
is
8265 Check_No_Identifiers
;
8266 Check_At_Least_N_Arguments
(1);
8268 -- Check all arguments are names of generic units or instances
8271 while Present
(Arg
) loop
8272 Exp
:= Get_Pragma_Arg
(Arg
);
8275 if not Is_Entity_Name
(Exp
)
8277 (not Is_Generic_Instance
(Entity
(Exp
))
8279 not Is_Generic_Unit
(Entity
(Exp
)))
8282 ("pragma% argument must be name of generic unit/instance",
8288 end Process_Generic_List
;
8290 ------------------------------------
8291 -- Process_Import_Predefined_Type --
8292 ------------------------------------
8294 procedure Process_Import_Predefined_Type
is
8295 Loc
: constant Source_Ptr
:= Sloc
(N
);
8297 Ftyp
: Node_Id
:= Empty
;
8303 String_To_Name_Buffer
(Strval
(Expression
(Arg3
)));
8306 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8307 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8311 Ftyp
:= Node
(Elmt
);
8313 if Present
(Ftyp
) then
8315 -- Don't build a derived type declaration, because predefined C
8316 -- types have no declaration anywhere, so cannot really be named.
8317 -- Instead build a full type declaration, starting with an
8318 -- appropriate type definition is built
8320 if Is_Floating_Point_Type
(Ftyp
) then
8321 Def
:= Make_Floating_Point_Definition
(Loc
,
8322 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8323 Make_Real_Range_Specification
(Loc
,
8324 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8325 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8327 -- Should never have a predefined type we cannot handle
8330 raise Program_Error
;
8333 -- Build and insert a Full_Type_Declaration, which will be
8334 -- analyzed as soon as this list entry has been analyzed.
8336 Decl
:= Make_Full_Type_Declaration
(Loc
,
8337 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8338 Type_Definition
=> Def
);
8340 Insert_After
(N
, Decl
);
8341 Mark_Rewrite_Insertion
(Decl
);
8344 Error_Pragma_Arg
("no matching type found for pragma%",
8347 end Process_Import_Predefined_Type
;
8349 ---------------------------------
8350 -- Process_Import_Or_Interface --
8351 ---------------------------------
8353 procedure Process_Import_Or_Interface
is
8359 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8360 -- pragma Import (Entity, "external name");
8362 if Relaxed_RM_Semantics
8363 and then Arg_Count
= 2
8364 and then Prag_Id
= Pragma_Import
8365 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8368 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8371 if not Is_Entity_Name
(Def_Id
) then
8372 Error_Pragma_Arg
("entity name required", Arg1
);
8375 Def_Id
:= Entity
(Def_Id
);
8376 Kill_Size_Check_Code
(Def_Id
);
8377 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8380 Process_Convention
(C
, Def_Id
);
8382 -- A pragma that applies to a Ghost entity becomes Ghost for the
8383 -- purposes of legality checks and removal of ignored Ghost code.
8385 Mark_Ghost_Pragma
(N
, Def_Id
);
8386 Kill_Size_Check_Code
(Def_Id
);
8387 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8390 -- Various error checks
8392 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8394 -- We do not permit Import to apply to a renaming declaration
8396 if Present
(Renamed_Object
(Def_Id
)) then
8398 ("pragma% not allowed for object renaming", Arg2
);
8400 -- User initialization is not allowed for imported object, but
8401 -- the object declaration may contain a default initialization,
8402 -- that will be discarded. Note that an explicit initialization
8403 -- only counts if it comes from source, otherwise it is simply
8404 -- the code generator making an implicit initialization explicit.
8406 elsif Present
(Expression
(Parent
(Def_Id
)))
8407 and then Comes_From_Source
8408 (Original_Node
(Expression
(Parent
(Def_Id
))))
8410 -- Set imported flag to prevent cascaded errors
8412 Set_Is_Imported
(Def_Id
);
8414 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8416 ("no initialization allowed for declaration of& #",
8417 "\imported entities cannot be initialized (RM B.1(24))",
8421 -- If the pragma comes from an aspect specification the
8422 -- Is_Imported flag has already been set.
8424 if not From_Aspect_Specification
(N
) then
8425 Set_Imported
(Def_Id
);
8428 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8430 -- Note that we do not set Is_Public here. That's because we
8431 -- only want to set it if there is no address clause, and we
8432 -- don't know that yet, so we delay that processing till
8435 -- pragma Import completes deferred constants
8437 if Ekind
(Def_Id
) = E_Constant
then
8438 Set_Has_Completion
(Def_Id
);
8441 -- It is not possible to import a constant of an unconstrained
8442 -- array type (e.g. string) because there is no simple way to
8443 -- write a meaningful subtype for it.
8445 if Is_Array_Type
(Etype
(Def_Id
))
8446 and then not Is_Constrained
(Etype
(Def_Id
))
8449 ("imported constant& must have a constrained subtype",
8454 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8456 -- If the name is overloaded, pragma applies to all of the denoted
8457 -- entities in the same declarative part, unless the pragma comes
8458 -- from an aspect specification or was generated by the compiler
8459 -- (such as for pragma Provide_Shift_Operators).
8462 while Present
(Hom_Id
) loop
8464 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8466 -- Ignore inherited subprograms because the pragma will apply
8467 -- to the parent operation, which is the one called.
8469 if Is_Overloadable
(Def_Id
)
8470 and then Present
(Alias
(Def_Id
))
8474 -- If it is not a subprogram, it must be in an outer scope and
8475 -- pragma does not apply.
8477 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8480 -- The pragma does not apply to primitives of interfaces
8482 elsif Is_Dispatching_Operation
(Def_Id
)
8483 and then Present
(Find_Dispatching_Type
(Def_Id
))
8484 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8488 -- Verify that the homonym is in the same declarative part (not
8489 -- just the same scope). If the pragma comes from an aspect
8490 -- specification we know that it is part of the declaration.
8492 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8493 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8494 and then not From_Aspect_Specification
(N
)
8499 -- If the pragma comes from an aspect specification the
8500 -- Is_Imported flag has already been set.
8502 if not From_Aspect_Specification
(N
) then
8503 Set_Imported
(Def_Id
);
8506 -- Reject an Import applied to an abstract subprogram
8508 if Is_Subprogram
(Def_Id
)
8509 and then Is_Abstract_Subprogram
(Def_Id
)
8511 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8513 ("cannot import abstract subprogram& declared#",
8517 -- Special processing for Convention_Intrinsic
8519 if C
= Convention_Intrinsic
then
8521 -- Link_Name argument not allowed for intrinsic
8525 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8527 -- If no external name is present, then check that this
8528 -- is a valid intrinsic subprogram. If an external name
8529 -- is present, then this is handled by the back end.
8532 Check_Intrinsic_Subprogram
8533 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8537 -- Verify that the subprogram does not have a completion
8538 -- through a renaming declaration. For other completions the
8539 -- pragma appears as a too late representation.
8542 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8546 and then Nkind
(Decl
) = N_Subprogram_Declaration
8547 and then Present
(Corresponding_Body
(Decl
))
8548 and then Nkind
(Unit_Declaration_Node
8549 (Corresponding_Body
(Decl
))) =
8550 N_Subprogram_Renaming_Declaration
8552 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8554 ("cannot import&, renaming already provided for "
8555 & "declaration #", N
, Def_Id
);
8559 -- If the pragma comes from an aspect specification, there
8560 -- must be an Import aspect specified as well. In the rare
8561 -- case where Import is set to False, the suprogram needs to
8562 -- have a local completion.
8565 Imp_Aspect
: constant Node_Id
:=
8566 Find_Aspect
(Def_Id
, Aspect_Import
);
8570 if Present
(Imp_Aspect
)
8571 and then Present
(Expression
(Imp_Aspect
))
8573 Expr
:= Expression
(Imp_Aspect
);
8574 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8576 if Is_Entity_Name
(Expr
)
8577 and then Entity
(Expr
) = Standard_True
8579 Set_Has_Completion
(Def_Id
);
8582 -- If there is no expression, the default is True, as for
8583 -- all boolean aspects. Same for the older pragma.
8586 Set_Has_Completion
(Def_Id
);
8590 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
8593 if Is_Compilation_Unit
(Hom_Id
) then
8595 -- Its possible homonyms are not affected by the pragma.
8596 -- Such homonyms might be present in the context of other
8597 -- units being compiled.
8601 elsif From_Aspect_Specification
(N
) then
8604 -- If the pragma was created by the compiler, then we don't
8605 -- want it to apply to other homonyms. This kind of case can
8606 -- occur when using pragma Provide_Shift_Operators, which
8607 -- generates implicit shift and rotate operators with Import
8608 -- pragmas that might apply to earlier explicit or implicit
8609 -- declarations marked with Import (for example, coming from
8610 -- an earlier pragma Provide_Shift_Operators for another type),
8611 -- and we don't generally want other homonyms being treated
8612 -- as imported or the pragma flagged as an illegal duplicate.
8614 elsif not Comes_From_Source
(N
) then
8618 Hom_Id
:= Homonym
(Hom_Id
);
8622 -- Import a CPP class
8624 elsif C
= Convention_CPP
8625 and then (Is_Record_Type
(Def_Id
)
8626 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8628 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8629 if Present
(Full_View
(Def_Id
)) then
8630 Def_Id
:= Full_View
(Def_Id
);
8634 ("cannot import 'C'P'P type before full declaration seen",
8635 Get_Pragma_Arg
(Arg2
));
8637 -- Although we have reported the error we decorate it as
8638 -- CPP_Class to avoid reporting spurious errors
8640 Set_Is_CPP_Class
(Def_Id
);
8645 -- Types treated as CPP classes must be declared limited (note:
8646 -- this used to be a warning but there is no real benefit to it
8647 -- since we did effectively intend to treat the type as limited
8650 if not Is_Limited_Type
(Def_Id
) then
8652 ("imported 'C'P'P type must be limited",
8653 Get_Pragma_Arg
(Arg2
));
8656 if Etype
(Def_Id
) /= Def_Id
8657 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8659 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8662 Set_Is_CPP_Class
(Def_Id
);
8664 -- Imported CPP types must not have discriminants (because C++
8665 -- classes do not have discriminants).
8667 if Has_Discriminants
(Def_Id
) then
8669 ("imported 'C'P'P type cannot have discriminants",
8670 First
(Discriminant_Specifications
8671 (Declaration_Node
(Def_Id
))));
8674 -- Check that components of imported CPP types do not have default
8675 -- expressions. For private types this check is performed when the
8676 -- full view is analyzed (see Process_Full_View).
8678 if not Is_Private_Type
(Def_Id
) then
8679 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8682 -- Import a CPP exception
8684 elsif C
= Convention_CPP
8685 and then Ekind
(Def_Id
) = E_Exception
8689 ("'External_'Name arguments is required for 'Cpp exception",
8692 -- As only a string is allowed, Check_Arg_Is_External_Name
8695 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8698 if Present
(Arg4
) then
8700 ("Link_Name argument not allowed for imported Cpp exception",
8704 -- Do not call Set_Interface_Name as the name of the exception
8705 -- shouldn't be modified (and in particular it shouldn't be
8706 -- the External_Name). For exceptions, the External_Name is the
8707 -- name of the RTTI structure.
8709 -- ??? Emit an error if pragma Import/Export_Exception is present
8711 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8713 Check_Arg_Count
(3);
8714 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8716 Process_Import_Predefined_Type
;
8720 ("second argument of pragma% must be object, subprogram "
8721 & "or incomplete type",
8725 -- If this pragma applies to a compilation unit, then the unit, which
8726 -- is a subprogram, does not require (or allow) a body. We also do
8727 -- not need to elaborate imported procedures.
8729 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8731 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8733 Set_Body_Required
(Cunit
, False);
8736 end Process_Import_Or_Interface
;
8738 --------------------
8739 -- Process_Inline --
8740 --------------------
8742 procedure Process_Inline
(Status
: Inline_Status
) is
8749 Ghost_Error_Posted
: Boolean := False;
8750 -- Flag set when an error concerning the illegal mix of Ghost and
8751 -- non-Ghost subprograms is emitted.
8753 Ghost_Id
: Entity_Id
:= Empty
;
8754 -- The entity of the first Ghost subprogram encountered while
8755 -- processing the arguments of the pragma.
8757 procedure Make_Inline
(Subp
: Entity_Id
);
8758 -- Subp is the defining unit name of the subprogram declaration. If
8759 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8760 -- the corresponding body, if there is one present.
8762 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8763 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8764 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8766 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8767 -- Returns True if it can be determined at this stage that inlining
8768 -- is not possible, for example if the body is available and contains
8769 -- exception handlers, we prevent inlining, since otherwise we can
8770 -- get undefined symbols at link time. This function also emits a
8771 -- warning if the pragma appears too late.
8773 -- ??? is business with link symbols still valid, or does it relate
8774 -- to front end ZCX which is being phased out ???
8776 ---------------------------
8777 -- Inlining_Not_Possible --
8778 ---------------------------
8780 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8781 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8785 if Nkind
(Decl
) = N_Subprogram_Body
then
8786 Stats
:= Handled_Statement_Sequence
(Decl
);
8787 return Present
(Exception_Handlers
(Stats
))
8788 or else Present
(At_End_Proc
(Stats
));
8790 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8791 and then Present
(Corresponding_Body
(Decl
))
8793 if Analyzed
(Corresponding_Body
(Decl
)) then
8794 Error_Msg_N
("pragma appears too late, ignored??", N
);
8797 -- If the subprogram is a renaming as body, the body is just a
8798 -- call to the renamed subprogram, and inlining is trivially
8802 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8803 N_Subprogram_Renaming_Declaration
8809 Handled_Statement_Sequence
8810 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8813 Present
(Exception_Handlers
(Stats
))
8814 or else Present
(At_End_Proc
(Stats
));
8818 -- If body is not available, assume the best, the check is
8819 -- performed again when compiling enclosing package bodies.
8823 end Inlining_Not_Possible
;
8829 procedure Make_Inline
(Subp
: Entity_Id
) is
8830 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8831 Inner_Subp
: Entity_Id
:= Subp
;
8834 -- Ignore if bad type, avoid cascaded error
8836 if Etype
(Subp
) = Any_Type
then
8840 -- If inlining is not possible, for now do not treat as an error
8842 elsif Status
/= Suppressed
8843 and then Front_End_Inlining
8844 and then Inlining_Not_Possible
(Subp
)
8849 -- Here we have a candidate for inlining, but we must exclude
8850 -- derived operations. Otherwise we would end up trying to inline
8851 -- a phantom declaration, and the result would be to drag in a
8852 -- body which has no direct inlining associated with it. That
8853 -- would not only be inefficient but would also result in the
8854 -- backend doing cross-unit inlining in cases where it was
8855 -- definitely inappropriate to do so.
8857 -- However, a simple Comes_From_Source test is insufficient, since
8858 -- we do want to allow inlining of generic instances which also do
8859 -- not come from source. We also need to recognize specs generated
8860 -- by the front-end for bodies that carry the pragma. Finally,
8861 -- predefined operators do not come from source but are not
8862 -- inlineable either.
8864 elsif Is_Generic_Instance
(Subp
)
8865 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8869 elsif not Comes_From_Source
(Subp
)
8870 and then Scope
(Subp
) /= Standard_Standard
8876 -- The referenced entity must either be the enclosing entity, or
8877 -- an entity declared within the current open scope.
8879 if Present
(Scope
(Subp
))
8880 and then Scope
(Subp
) /= Current_Scope
8881 and then Subp
/= Current_Scope
8884 ("argument of% must be entity in current scope", Assoc
);
8888 -- Processing for procedure, operator or function. If subprogram
8889 -- is aliased (as for an instance) indicate that the renamed
8890 -- entity (if declared in the same unit) is inlined.
8891 -- If this is the anonymous subprogram created for a subprogram
8892 -- instance, the inlining applies to it directly. Otherwise we
8893 -- retrieve it as the alias of the visible subprogram instance.
8895 if Is_Subprogram
(Subp
) then
8896 if Is_Wrapper_Package
(Scope
(Subp
)) then
8899 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
8902 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
8903 Set_Inline_Flags
(Inner_Subp
);
8905 Decl
:= Parent
(Parent
(Inner_Subp
));
8907 if Nkind
(Decl
) = N_Subprogram_Declaration
8908 and then Present
(Corresponding_Body
(Decl
))
8910 Set_Inline_Flags
(Corresponding_Body
(Decl
));
8912 elsif Is_Generic_Instance
(Subp
)
8913 and then Comes_From_Source
(Subp
)
8915 -- Indicate that the body needs to be created for
8916 -- inlining subsequent calls. The instantiation node
8917 -- follows the declaration of the wrapper package
8918 -- created for it. The subprogram that requires the
8919 -- body is the anonymous one in the wrapper package.
8921 if Scope
(Subp
) /= Standard_Standard
8923 Need_Subprogram_Instance_Body
8924 (Next
(Unit_Declaration_Node
8925 (Scope
(Alias
(Subp
)))), Subp
)
8930 -- Inline is a program unit pragma (RM 10.1.5) and cannot
8931 -- appear in a formal part to apply to a formal subprogram.
8932 -- Do not apply check within an instance or a formal package
8933 -- the test will have been applied to the original generic.
8935 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
8936 and then List_Containing
(Decl
) = List_Containing
(N
)
8937 and then not In_Instance
8940 ("Inline cannot apply to a formal subprogram", N
);
8942 -- If Subp is a renaming, it is the renamed entity that
8943 -- will appear in any call, and be inlined. However, for
8944 -- ASIS uses it is convenient to indicate that the renaming
8945 -- itself is an inlined subprogram, so that some gnatcheck
8946 -- rules can be applied in the absence of expansion.
8948 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
8949 Set_Inline_Flags
(Subp
);
8955 -- For a generic subprogram set flag as well, for use at the point
8956 -- of instantiation, to determine whether the body should be
8959 elsif Is_Generic_Subprogram
(Subp
) then
8960 Set_Inline_Flags
(Subp
);
8963 -- Literals are by definition inlined
8965 elsif Kind
= E_Enumeration_Literal
then
8968 -- Anything else is an error
8972 ("expect subprogram name for pragma%", Assoc
);
8976 ----------------------
8977 -- Set_Inline_Flags --
8978 ----------------------
8980 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
8982 -- First set the Has_Pragma_XXX flags and issue the appropriate
8983 -- errors and warnings for suspicious combinations.
8985 if Prag_Id
= Pragma_No_Inline
then
8986 if Has_Pragma_Inline_Always
(Subp
) then
8988 ("Inline_Always and No_Inline are mutually exclusive", N
);
8989 elsif Has_Pragma_Inline
(Subp
) then
8991 ("Inline and No_Inline both specified for& ??",
8992 N
, Entity
(Subp_Id
));
8995 Set_Has_Pragma_No_Inline
(Subp
);
8997 if Prag_Id
= Pragma_Inline_Always
then
8998 if Has_Pragma_No_Inline
(Subp
) then
9000 ("Inline_Always and No_Inline are mutually exclusive",
9004 Set_Has_Pragma_Inline_Always
(Subp
);
9006 if Has_Pragma_No_Inline
(Subp
) then
9008 ("Inline and No_Inline both specified for& ??",
9009 N
, Entity
(Subp_Id
));
9013 Set_Has_Pragma_Inline
(Subp
);
9016 -- Then adjust the Is_Inlined flag. It can never be set if the
9017 -- subprogram is subject to pragma No_Inline.
9021 Set_Is_Inlined
(Subp
, False);
9027 if not Has_Pragma_No_Inline
(Subp
) then
9028 Set_Is_Inlined
(Subp
, True);
9032 -- A pragma that applies to a Ghost entity becomes Ghost for the
9033 -- purposes of legality checks and removal of ignored Ghost code.
9035 Mark_Ghost_Pragma
(N
, Subp
);
9037 -- Capture the entity of the first Ghost subprogram being
9038 -- processed for error detection purposes.
9040 if Is_Ghost_Entity
(Subp
) then
9041 if No
(Ghost_Id
) then
9045 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9046 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9048 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9049 Ghost_Error_Posted
:= True;
9051 Error_Msg_Name_1
:= Pname
;
9053 ("pragma % cannot mention ghost and non-ghost subprograms",
9056 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9057 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9059 Error_Msg_Sloc
:= Sloc
(Subp
);
9060 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9062 end Set_Inline_Flags
;
9064 -- Start of processing for Process_Inline
9067 Check_No_Identifiers
;
9068 Check_At_Least_N_Arguments
(1);
9070 if Status
= Enabled
then
9071 Inline_Processing_Required
:= True;
9075 while Present
(Assoc
) loop
9076 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9080 if Is_Entity_Name
(Subp_Id
) then
9081 Subp
:= Entity
(Subp_Id
);
9083 if Subp
= Any_Id
then
9085 -- If previous error, avoid cascaded errors
9087 Check_Error_Detected
;
9093 -- For the pragma case, climb homonym chain. This is
9094 -- what implements allowing the pragma in the renaming
9095 -- case, with the result applying to the ancestors, and
9096 -- also allows Inline to apply to all previous homonyms.
9098 if not From_Aspect_Specification
(N
) then
9099 while Present
(Homonym
(Subp
))
9100 and then Scope
(Homonym
(Subp
)) = Current_Scope
9102 Make_Inline
(Homonym
(Subp
));
9103 Subp
:= Homonym
(Subp
);
9110 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9117 ----------------------------
9118 -- Process_Interface_Name --
9119 ----------------------------
9121 procedure Process_Interface_Name
9122 (Subprogram_Def
: Entity_Id
;
9128 String_Val
: String_Id
;
9130 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9131 -- SN is a string literal node for an interface name. This routine
9132 -- performs some minimal checks that the name is reasonable. In
9133 -- particular that no spaces or other obviously incorrect characters
9134 -- appear. This is only a warning, since any characters are allowed.
9136 ----------------------------------
9137 -- Check_Form_Of_Interface_Name --
9138 ----------------------------------
9140 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9141 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9142 SL
: constant Nat
:= String_Length
(S
);
9147 Error_Msg_N
("interface name cannot be null string", SN
);
9150 for J
in 1 .. SL
loop
9151 C
:= Get_String_Char
(S
, J
);
9153 -- Look for dubious character and issue unconditional warning.
9154 -- Definitely dubious if not in character range.
9156 if not In_Character_Range
(C
)
9158 -- Commas, spaces and (back)slashes are dubious
9160 or else Get_Character
(C
) = ','
9161 or else Get_Character
(C
) = '\'
9162 or else Get_Character
(C
) = ' '
9163 or else Get_Character
(C
) = '/'
9166 ("??interface name contains illegal character",
9167 Sloc
(SN
) + Source_Ptr
(J
));
9170 end Check_Form_Of_Interface_Name
;
9172 -- Start of processing for Process_Interface_Name
9175 if No
(Link_Arg
) then
9176 if No
(Ext_Arg
) then
9179 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9181 Link_Nam
:= Expression
(Ext_Arg
);
9184 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9185 Ext_Nam
:= Expression
(Ext_Arg
);
9190 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9191 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9192 Ext_Nam
:= Expression
(Ext_Arg
);
9193 Link_Nam
:= Expression
(Link_Arg
);
9196 -- Check expressions for external name and link name are static
9198 if Present
(Ext_Nam
) then
9199 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9200 Check_Form_Of_Interface_Name
(Ext_Nam
);
9202 -- Verify that external name is not the name of a local entity,
9203 -- which would hide the imported one and could lead to run-time
9204 -- surprises. The problem can only arise for entities declared in
9205 -- a package body (otherwise the external name is fully qualified
9206 -- and will not conflict).
9214 if Prag_Id
= Pragma_Import
then
9215 String_To_Name_Buffer
(Strval
(Expr_Value_S
(Ext_Nam
)));
9217 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9219 if Nam
/= Chars
(Subprogram_Def
)
9220 and then Present
(E
)
9221 and then not Is_Overloadable
(E
)
9222 and then Is_Immediately_Visible
(E
)
9223 and then not Is_Imported
(E
)
9224 and then Ekind
(Scope
(E
)) = E_Package
9227 while Present
(Par
) loop
9228 if Nkind
(Par
) = N_Package_Body
then
9229 Error_Msg_Sloc
:= Sloc
(E
);
9231 ("imported entity is hidden by & declared#",
9236 Par
:= Parent
(Par
);
9243 if Present
(Link_Nam
) then
9244 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9245 Check_Form_Of_Interface_Name
(Link_Nam
);
9248 -- If there is no link name, just set the external name
9250 if No
(Link_Nam
) then
9251 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9253 -- For the Link_Name case, the given literal is preceded by an
9254 -- asterisk, which indicates to GCC that the given name should be
9255 -- taken literally, and in particular that no prepending of
9256 -- underlines should occur, even in systems where this is the
9261 Store_String_Char
(Get_Char_Code
('*'));
9262 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9263 Store_String_Chars
(String_Val
);
9265 Make_String_Literal
(Sloc
(Link_Nam
),
9266 Strval
=> End_String
);
9269 -- Set the interface name. If the entity is a generic instance, use
9270 -- its alias, which is the callable entity.
9272 if Is_Generic_Instance
(Subprogram_Def
) then
9273 Set_Encoded_Interface_Name
9274 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9276 Set_Encoded_Interface_Name
9277 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9280 Check_Duplicated_Export_Name
(Link_Nam
);
9281 end Process_Interface_Name
;
9283 -----------------------------------------
9284 -- Process_Interrupt_Or_Attach_Handler --
9285 -----------------------------------------
9287 procedure Process_Interrupt_Or_Attach_Handler
is
9288 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9289 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9292 -- A pragma that applies to a Ghost entity becomes Ghost for the
9293 -- purposes of legality checks and removal of ignored Ghost code.
9295 Mark_Ghost_Pragma
(N
, Handler
);
9296 Set_Is_Interrupt_Handler
(Handler
);
9298 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
9300 Record_Rep_Item
(Prot_Typ
, N
);
9302 -- Chain the pragma on the contract for completeness
9304 Add_Contract_Item
(N
, Handler
);
9305 end Process_Interrupt_Or_Attach_Handler
;
9307 --------------------------------------------------
9308 -- Process_Restrictions_Or_Restriction_Warnings --
9309 --------------------------------------------------
9311 -- Note: some of the simple identifier cases were handled in par-prag,
9312 -- but it is harmless (and more straightforward) to simply handle all
9313 -- cases here, even if it means we repeat a bit of work in some cases.
9315 procedure Process_Restrictions_Or_Restriction_Warnings
9319 R_Id
: Restriction_Id
;
9325 -- Ignore all Restrictions pragmas in CodePeer mode
9327 if CodePeer_Mode
then
9331 Check_Ada_83_Warning
;
9332 Check_At_Least_N_Arguments
(1);
9333 Check_Valid_Configuration_Pragma
;
9336 while Present
(Arg
) loop
9338 Expr
:= Get_Pragma_Arg
(Arg
);
9340 -- Case of no restriction identifier present
9342 if Id
= No_Name
then
9343 if Nkind
(Expr
) /= N_Identifier
then
9345 ("invalid form for restriction", Arg
);
9350 (Process_Restriction_Synonyms
(Expr
));
9352 if R_Id
not in All_Boolean_Restrictions
then
9353 Error_Msg_Name_1
:= Pname
;
9355 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9357 -- Check for possible misspelling
9359 for J
in Restriction_Id
loop
9361 Rnm
: constant String := Restriction_Id
'Image (J
);
9364 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9365 Name_Len
:= Rnm
'Length;
9366 Set_Casing
(All_Lower_Case
);
9368 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9370 (Identifier_Casing
(Current_Source_File
));
9371 Error_Msg_String
(1 .. Rnm
'Length) :=
9372 Name_Buffer
(1 .. Name_Len
);
9373 Error_Msg_Strlen
:= Rnm
'Length;
9374 Error_Msg_N
-- CODEFIX
9375 ("\possible misspelling of ""~""",
9376 Get_Pragma_Arg
(Arg
));
9385 if Implementation_Restriction
(R_Id
) then
9386 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
9389 -- Special processing for No_Elaboration_Code restriction
9391 if R_Id
= No_Elaboration_Code
then
9393 -- Restriction is only recognized within a configuration
9394 -- pragma file, or within a unit of the main extended
9395 -- program. Note: the test for Main_Unit is needed to
9396 -- properly include the case of configuration pragma files.
9398 if not (Current_Sem_Unit
= Main_Unit
9399 or else In_Extended_Main_Source_Unit
(N
))
9403 -- Don't allow in a subunit unless already specified in
9406 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
9407 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
9408 and then not Restriction_Active
(No_Elaboration_Code
)
9411 ("invalid specification of ""No_Elaboration_Code""",
9414 ("\restriction cannot be specified in a subunit", N
);
9416 ("\unless also specified in body or spec", N
);
9419 -- If we accept a No_Elaboration_Code restriction, then it
9420 -- needs to be added to the configuration restriction set so
9421 -- that we get proper application to other units in the main
9422 -- extended source as required.
9425 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9429 -- If this is a warning, then set the warning unless we already
9430 -- have a real restriction active (we never want a warning to
9431 -- override a real restriction).
9434 if not Restriction_Active
(R_Id
) then
9435 Set_Restriction
(R_Id
, N
);
9436 Restriction_Warnings
(R_Id
) := True;
9439 -- If real restriction case, then set it and make sure that the
9440 -- restriction warning flag is off, since a real restriction
9441 -- always overrides a warning.
9444 Set_Restriction
(R_Id
, N
);
9445 Restriction_Warnings
(R_Id
) := False;
9448 -- Check for obsolescent restrictions in Ada 2005 mode
9451 and then Ada_Version
>= Ada_2005
9452 and then (R_Id
= No_Asynchronous_Control
9454 R_Id
= No_Unchecked_Deallocation
9456 R_Id
= No_Unchecked_Conversion
)
9458 Check_Restriction
(No_Obsolescent_Features
, N
);
9461 -- A very special case that must be processed here: pragma
9462 -- Restrictions (No_Exceptions) turns off all run-time
9463 -- checking. This is a bit dubious in terms of the formal
9464 -- language definition, but it is what is intended by RM
9465 -- H.4(12). Restriction_Warnings never affects generated code
9466 -- so this is done only in the real restriction case.
9468 -- Atomic_Synchronization is not a real check, so it is not
9469 -- affected by this processing).
9471 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9472 -- run-time checks in CodePeer and GNATprove modes: we want to
9473 -- generate checks for analysis purposes, as set respectively
9474 -- by -gnatC and -gnatd.F
9477 and then not (CodePeer_Mode
or GNATprove_Mode
)
9478 and then R_Id
= No_Exceptions
9480 for J
in Scope_Suppress
.Suppress
'Range loop
9481 if J
/= Atomic_Synchronization
then
9482 Scope_Suppress
.Suppress
(J
) := True;
9487 -- Case of No_Dependence => unit-name. Note that the parser
9488 -- already made the necessary entry in the No_Dependence table.
9490 elsif Id
= Name_No_Dependence
then
9491 if not OK_No_Dependence_Unit_Name
(Expr
) then
9495 -- Case of No_Specification_Of_Aspect => aspect-identifier
9497 elsif Id
= Name_No_Specification_Of_Aspect
then
9502 if Nkind
(Expr
) /= N_Identifier
then
9505 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9508 if A_Id
= No_Aspect
then
9509 Error_Pragma_Arg
("invalid restriction name", Arg
);
9511 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9515 -- Case of No_Use_Of_Attribute => attribute-identifier
9517 elsif Id
= Name_No_Use_Of_Attribute
then
9518 if Nkind
(Expr
) /= N_Identifier
9519 or else not Is_Attribute_Name
(Chars
(Expr
))
9521 Error_Msg_N
("unknown attribute name??", Expr
);
9524 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9527 -- Case of No_Use_Of_Entity => fully-qualified-name
9529 elsif Id
= Name_No_Use_Of_Entity
then
9531 -- Restriction is only recognized within a configuration
9532 -- pragma file, or within a unit of the main extended
9533 -- program. Note: the test for Main_Unit is needed to
9534 -- properly include the case of configuration pragma files.
9536 if Current_Sem_Unit
= Main_Unit
9537 or else In_Extended_Main_Source_Unit
(N
)
9539 if not OK_No_Dependence_Unit_Name
(Expr
) then
9540 Error_Msg_N
("wrong form for entity name", Expr
);
9542 Set_Restriction_No_Use_Of_Entity
9543 (Expr
, Warn
, No_Profile
);
9547 -- Case of No_Use_Of_Pragma => pragma-identifier
9549 elsif Id
= Name_No_Use_Of_Pragma
then
9550 if Nkind
(Expr
) /= N_Identifier
9551 or else not Is_Pragma_Name
(Chars
(Expr
))
9553 Error_Msg_N
("unknown pragma name??", Expr
);
9555 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9558 -- All other cases of restriction identifier present
9561 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9562 Analyze_And_Resolve
(Expr
, Any_Integer
);
9564 if R_Id
not in All_Parameter_Restrictions
then
9566 ("invalid restriction parameter identifier", Arg
);
9568 elsif not Is_OK_Static_Expression
(Expr
) then
9569 Flag_Non_Static_Expr
9570 ("value must be static expression!", Expr
);
9573 elsif not Is_Integer_Type
(Etype
(Expr
))
9574 or else Expr_Value
(Expr
) < 0
9577 ("value must be non-negative integer", Arg
);
9580 -- Restriction pragma is active
9582 Val
:= Expr_Value
(Expr
);
9584 if not UI_Is_In_Int_Range
(Val
) then
9586 ("pragma ignored, value too large??", Arg
);
9589 -- Warning case. If the real restriction is active, then we
9590 -- ignore the request, since warning never overrides a real
9591 -- restriction. Otherwise we set the proper warning. Note that
9592 -- this circuit sets the warning again if it is already set,
9593 -- which is what we want, since the constant may have changed.
9596 if not Restriction_Active
(R_Id
) then
9598 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9599 Restriction_Warnings
(R_Id
) := True;
9602 -- Real restriction case, set restriction and make sure warning
9603 -- flag is off since real restriction always overrides warning.
9606 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9607 Restriction_Warnings
(R_Id
) := False;
9613 end Process_Restrictions_Or_Restriction_Warnings
;
9615 ---------------------------------
9616 -- Process_Suppress_Unsuppress --
9617 ---------------------------------
9619 -- Note: this procedure makes entries in the check suppress data
9620 -- structures managed by Sem. See spec of package Sem for full
9621 -- details on how we handle recording of check suppression.
9623 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9628 In_Package_Spec
: constant Boolean :=
9629 Is_Package_Or_Generic_Package
(Current_Scope
)
9630 and then not In_Package_Body
(Current_Scope
);
9632 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9633 -- Used to suppress a single check on the given entity
9635 --------------------------------
9636 -- Suppress_Unsuppress_Echeck --
9637 --------------------------------
9639 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9641 -- Check for error of trying to set atomic synchronization for
9642 -- a non-atomic variable.
9644 if C
= Atomic_Synchronization
9645 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9648 ("pragma & requires atomic type or variable",
9649 Pragma_Identifier
(Original_Node
(N
)));
9652 Set_Checks_May_Be_Suppressed
(E
);
9654 if In_Package_Spec
then
9655 Push_Global_Suppress_Stack_Entry
9658 Suppress
=> Suppress_Case
);
9660 Push_Local_Suppress_Stack_Entry
9663 Suppress
=> Suppress_Case
);
9666 -- If this is a first subtype, and the base type is distinct,
9667 -- then also set the suppress flags on the base type.
9669 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9670 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9672 end Suppress_Unsuppress_Echeck
;
9674 -- Start of processing for Process_Suppress_Unsuppress
9677 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9678 -- on user code: we want to generate checks for analysis purposes, as
9679 -- set respectively by -gnatC and -gnatd.F
9681 if Comes_From_Source
(N
)
9682 and then (CodePeer_Mode
or GNATprove_Mode
)
9687 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9688 -- declarative part or a package spec (RM 11.5(5)).
9690 if not Is_Configuration_Pragma
then
9691 Check_Is_In_Decl_Part_Or_Package_Spec
;
9694 Check_At_Least_N_Arguments
(1);
9695 Check_At_Most_N_Arguments
(2);
9696 Check_No_Identifier
(Arg1
);
9697 Check_Arg_Is_Identifier
(Arg1
);
9699 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9701 if C
= No_Check_Id
then
9703 ("argument of pragma% is not valid check name", Arg1
);
9706 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9708 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9710 ("Suppress of Elaboration_Check ignored in SPARK??",
9711 "\elaboration checking rules are statically enforced "
9712 & "(SPARK RM 7.7)", Arg1
);
9715 -- One-argument case
9717 if Arg_Count
= 1 then
9719 -- Make an entry in the local scope suppress table. This is the
9720 -- table that directly shows the current value of the scope
9721 -- suppress check for any check id value.
9723 if C
= All_Checks
then
9725 -- For All_Checks, we set all specific predefined checks with
9726 -- the exception of Elaboration_Check, which is handled
9727 -- specially because of not wanting All_Checks to have the
9728 -- effect of deactivating static elaboration order processing.
9729 -- Atomic_Synchronization is also not affected, since this is
9730 -- not a real check.
9732 for J
in Scope_Suppress
.Suppress
'Range loop
9733 if J
/= Elaboration_Check
9735 J
/= Atomic_Synchronization
9737 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9741 -- If not All_Checks, and predefined check, then set appropriate
9742 -- scope entry. Note that we will set Elaboration_Check if this
9743 -- is explicitly specified. Atomic_Synchronization is allowed
9744 -- only if internally generated and entity is atomic.
9746 elsif C
in Predefined_Check_Id
9747 and then (not Comes_From_Source
(N
)
9748 or else C
/= Atomic_Synchronization
)
9750 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9753 -- Also make an entry in the Local_Entity_Suppress table
9755 Push_Local_Suppress_Stack_Entry
9758 Suppress
=> Suppress_Case
);
9760 -- Case of two arguments present, where the check is suppressed for
9761 -- a specified entity (given as the second argument of the pragma)
9764 -- This is obsolescent in Ada 2005 mode
9766 if Ada_Version
>= Ada_2005
then
9767 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9770 Check_Optional_Identifier
(Arg2
, Name_On
);
9771 E_Id
:= Get_Pragma_Arg
(Arg2
);
9774 if not Is_Entity_Name
(E_Id
) then
9776 ("second argument of pragma% must be entity name", Arg2
);
9785 -- A pragma that applies to a Ghost entity becomes Ghost for the
9786 -- purposes of legality checks and removal of ignored Ghost code.
9788 Mark_Ghost_Pragma
(N
, E
);
9790 -- Enforce RM 11.5(7) which requires that for a pragma that
9791 -- appears within a package spec, the named entity must be
9792 -- within the package spec. We allow the package name itself
9793 -- to be mentioned since that makes sense, although it is not
9794 -- strictly allowed by 11.5(7).
9797 and then E
/= Current_Scope
9798 and then Scope
(E
) /= Current_Scope
9801 ("entity in pragma% is not in package spec (RM 11.5(7))",
9805 -- Loop through homonyms. As noted below, in the case of a package
9806 -- spec, only homonyms within the package spec are considered.
9809 Suppress_Unsuppress_Echeck
(E
, C
);
9811 if Is_Generic_Instance
(E
)
9812 and then Is_Subprogram
(E
)
9813 and then Present
(Alias
(E
))
9815 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9818 -- Move to next homonym if not aspect spec case
9820 exit when From_Aspect_Specification
(N
);
9824 -- If we are within a package specification, the pragma only
9825 -- applies to homonyms in the same scope.
9827 exit when In_Package_Spec
9828 and then Scope
(E
) /= Current_Scope
;
9831 end Process_Suppress_Unsuppress
;
9833 -------------------------------
9834 -- Record_Independence_Check --
9835 -------------------------------
9837 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
9839 -- For GCC back ends the validation is done a priori
9841 if not AAMP_On_Target
then
9845 Independence_Checks
.Append
((N
, E
));
9846 end Record_Independence_Check
;
9852 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
9854 if Is_Imported
(E
) then
9856 ("cannot export entity& that was previously imported", Arg
);
9858 elsif Present
(Address_Clause
(E
))
9859 and then not Relaxed_RM_Semantics
9862 ("cannot export entity& that has an address clause", Arg
);
9865 Set_Is_Exported
(E
);
9867 -- Generate a reference for entity explicitly, because the
9868 -- identifier may be overloaded and name resolution will not
9871 Generate_Reference
(E
, Arg
);
9873 -- Deal with exporting non-library level entity
9875 if not Is_Library_Level_Entity
(E
) then
9877 -- Not allowed at all for subprograms
9879 if Is_Subprogram
(E
) then
9880 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
9882 -- Otherwise set public and statically allocated
9886 Set_Is_Statically_Allocated
(E
);
9888 -- Warn if the corresponding W flag is set
9890 if Warn_On_Export_Import
9892 -- Only do this for something that was in the source. Not
9893 -- clear if this can be False now (there used for sure to be
9894 -- cases on some systems where it was False), but anyway the
9895 -- test is harmless if not needed, so it is retained.
9897 and then Comes_From_Source
(Arg
)
9900 ("?x?& has been made static as a result of Export",
9903 ("\?x?this usage is non-standard and non-portable",
9909 if Warn_On_Export_Import
and then Is_Type
(E
) then
9910 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
9913 if Warn_On_Export_Import
and Inside_A_Generic
then
9915 ("all instances of& will have the same external name?x?",
9920 ----------------------------------------------
9921 -- Set_Extended_Import_Export_External_Name --
9922 ----------------------------------------------
9924 procedure Set_Extended_Import_Export_External_Name
9925 (Internal_Ent
: Entity_Id
;
9926 Arg_External
: Node_Id
)
9928 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
9932 if No
(Arg_External
) then
9936 Check_Arg_Is_External_Name
(Arg_External
);
9938 if Nkind
(Arg_External
) = N_String_Literal
then
9939 if String_Length
(Strval
(Arg_External
)) = 0 then
9942 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
9945 elsif Nkind
(Arg_External
) = N_Identifier
then
9946 New_Name
:= Get_Default_External_Name
(Arg_External
);
9948 -- Check_Arg_Is_External_Name should let through only identifiers and
9949 -- string literals or static string expressions (which are folded to
9950 -- string literals).
9953 raise Program_Error
;
9956 -- If we already have an external name set (by a prior normal Import
9957 -- or Export pragma), then the external names must match
9959 if Present
(Interface_Name
(Internal_Ent
)) then
9961 -- Ignore mismatching names in CodePeer mode, to support some
9962 -- old compilers which would export the same procedure under
9963 -- different names, e.g:
9965 -- pragma Export_Procedure (P, "a");
9966 -- pragma Export_Procedure (P, "b");
9968 if CodePeer_Mode
then
9972 Check_Matching_Internal_Names
: declare
9973 S1
: constant String_Id
:= Strval
(Old_Name
);
9974 S2
: constant String_Id
:= Strval
(New_Name
);
9977 pragma No_Return
(Mismatch
);
9978 -- Called if names do not match
9984 procedure Mismatch
is
9986 Error_Msg_Sloc
:= Sloc
(Old_Name
);
9988 ("external name does not match that given #",
9992 -- Start of processing for Check_Matching_Internal_Names
9995 if String_Length
(S1
) /= String_Length
(S2
) then
9999 for J
in 1 .. String_Length
(S1
) loop
10000 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10005 end Check_Matching_Internal_Names
;
10007 -- Otherwise set the given name
10010 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10011 Check_Duplicated_Export_Name
(New_Name
);
10013 end Set_Extended_Import_Export_External_Name
;
10019 procedure Set_Imported
(E
: Entity_Id
) is
10021 -- Error message if already imported or exported
10023 if Is_Exported
(E
) or else Is_Imported
(E
) then
10025 -- Error if being set Exported twice
10027 if Is_Exported
(E
) then
10028 Error_Msg_NE
("entity& was previously exported", N
, E
);
10030 -- Ignore error in CodePeer mode where we treat all imported
10031 -- subprograms as unknown.
10033 elsif CodePeer_Mode
then
10036 -- OK if Import/Interface case
10038 elsif Import_Interface_Present
(N
) then
10041 -- Error if being set Imported twice
10044 Error_Msg_NE
("entity& was previously imported", N
, E
);
10047 Error_Msg_Name_1
:= Pname
;
10049 ("\(pragma% applies to all previous entities)", N
);
10051 Error_Msg_Sloc
:= Sloc
(E
);
10052 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10054 -- Here if not previously imported or exported, OK to import
10057 Set_Is_Imported
(E
);
10059 -- For subprogram, set Import_Pragma field
10061 if Is_Subprogram
(E
) then
10062 Set_Import_Pragma
(E
, N
);
10065 -- If the entity is an object that is not at the library level,
10066 -- then it is statically allocated. We do not worry about objects
10067 -- with address clauses in this context since they are not really
10068 -- imported in the linker sense.
10071 and then not Is_Library_Level_Entity
(E
)
10072 and then No
(Address_Clause
(E
))
10074 Set_Is_Statically_Allocated
(E
);
10081 -------------------------
10082 -- Set_Mechanism_Value --
10083 -------------------------
10085 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10086 -- analyzed, since it is semantic nonsense), so we get it in the exact
10087 -- form created by the parser.
10089 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10090 procedure Bad_Mechanism
;
10091 pragma No_Return
(Bad_Mechanism
);
10092 -- Signal bad mechanism name
10094 -------------------------
10095 -- Bad_Mechanism_Value --
10096 -------------------------
10098 procedure Bad_Mechanism
is
10100 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10103 -- Start of processing for Set_Mechanism_Value
10106 if Mechanism
(Ent
) /= Default_Mechanism
then
10108 ("mechanism for & has already been set", Mech_Name
, Ent
);
10111 -- MECHANISM_NAME ::= value | reference
10113 if Nkind
(Mech_Name
) = N_Identifier
then
10114 if Chars
(Mech_Name
) = Name_Value
then
10115 Set_Mechanism
(Ent
, By_Copy
);
10118 elsif Chars
(Mech_Name
) = Name_Reference
then
10119 Set_Mechanism
(Ent
, By_Reference
);
10122 elsif Chars
(Mech_Name
) = Name_Copy
then
10124 ("bad mechanism name, Value assumed", Mech_Name
);
10133 end Set_Mechanism_Value
;
10135 --------------------------
10136 -- Set_Rational_Profile --
10137 --------------------------
10139 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10140 -- extension to the semantics of renaming declarations.
10142 procedure Set_Rational_Profile
is
10144 Implicit_Packing
:= True;
10145 Overriding_Renamings
:= True;
10146 Use_VADS_Size
:= True;
10147 end Set_Rational_Profile
;
10149 ---------------------------
10150 -- Set_Ravenscar_Profile --
10151 ---------------------------
10153 -- The tasks to be done here are
10155 -- Set required policies
10157 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10158 -- pragma Locking_Policy (Ceiling_Locking)
10160 -- Set Detect_Blocking mode
10162 -- Set required restrictions (see System.Rident for detailed list)
10164 -- Set the No_Dependence rules
10165 -- No_Dependence => Ada.Asynchronous_Task_Control
10166 -- No_Dependence => Ada.Calendar
10167 -- No_Dependence => Ada.Execution_Time.Group_Budget
10168 -- No_Dependence => Ada.Execution_Time.Timers
10169 -- No_Dependence => Ada.Task_Attributes
10170 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10172 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10173 procedure Set_Error_Msg_To_Profile_Name
;
10174 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10177 -----------------------------------
10178 -- Set_Error_Msg_To_Profile_Name --
10179 -----------------------------------
10181 procedure Set_Error_Msg_To_Profile_Name
is
10182 Prof_Nam
: constant Node_Id
:=
10184 (First
(Pragma_Argument_Associations
(N
)));
10187 Get_Name_String
(Chars
(Prof_Nam
));
10188 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10189 Error_Msg_Strlen
:= Name_Len
;
10190 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10191 end Set_Error_Msg_To_Profile_Name
;
10200 -- Start of processing for Set_Ravenscar_Profile
10203 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10205 if Task_Dispatching_Policy
/= ' '
10206 and then Task_Dispatching_Policy
/= 'F'
10208 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10209 Set_Error_Msg_To_Profile_Name
;
10210 Error_Pragma
("Profile (~) incompatible with policy#");
10212 -- Set the FIFO_Within_Priorities policy, but always preserve
10213 -- System_Location since we like the error message with the run time
10217 Task_Dispatching_Policy
:= 'F';
10219 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10220 Task_Dispatching_Policy_Sloc
:= Loc
;
10224 -- pragma Locking_Policy (Ceiling_Locking)
10226 if Locking_Policy
/= ' '
10227 and then Locking_Policy
/= 'C'
10229 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10230 Set_Error_Msg_To_Profile_Name
;
10231 Error_Pragma
("Profile (~) incompatible with policy#");
10233 -- Set the Ceiling_Locking policy, but preserve System_Location since
10234 -- we like the error message with the run time name.
10237 Locking_Policy
:= 'C';
10239 if Locking_Policy_Sloc
/= System_Location
then
10240 Locking_Policy_Sloc
:= Loc
;
10244 -- pragma Detect_Blocking
10246 Detect_Blocking
:= True;
10248 -- Set the corresponding restrictions
10250 Set_Profile_Restrictions
10251 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10253 -- Set the No_Dependence restrictions
10255 -- The following No_Dependence restrictions:
10256 -- No_Dependence => Ada.Asynchronous_Task_Control
10257 -- No_Dependence => Ada.Calendar
10258 -- No_Dependence => Ada.Task_Attributes
10259 -- are already set by previous call to Set_Profile_Restrictions.
10261 -- Set the following restrictions which were added to Ada 2005:
10262 -- No_Dependence => Ada.Execution_Time.Group_Budget
10263 -- No_Dependence => Ada.Execution_Time.Timers
10265 -- ??? The use of Name_Buffer here is suspicious. The names should
10266 -- be registered in snames.ads-tmpl and used to build the qualified
10269 if Ada_Version
>= Ada_2005
then
10270 Name_Buffer
(1 .. 3) := "ada";
10273 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
10275 Name_Buffer
(1 .. 14) := "execution_time";
10278 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10281 Make_Selected_Component
10284 Selector_Name
=> Sel_Id
);
10286 Name_Buffer
(1 .. 13) := "group_budgets";
10289 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10292 Make_Selected_Component
10295 Selector_Name
=> Sel_Id
);
10297 Set_Restriction_No_Dependence
10299 Warn
=> Treat_Restrictions_As_Warnings
,
10300 Profile
=> Ravenscar
);
10302 Name_Buffer
(1 .. 6) := "timers";
10305 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10308 Make_Selected_Component
10311 Selector_Name
=> Sel_Id
);
10313 Set_Restriction_No_Dependence
10315 Warn
=> Treat_Restrictions_As_Warnings
,
10316 Profile
=> Ravenscar
);
10319 -- Set the following restriction which was added to Ada 2012 (see
10321 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10323 if Ada_Version
>= Ada_2012
then
10324 Name_Buffer
(1 .. 6) := "system";
10327 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
);
10329 Name_Buffer
(1 .. 15) := "multiprocessors";
10332 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10335 Make_Selected_Component
10338 Selector_Name
=> Sel_Id
);
10340 Name_Buffer
(1 .. 19) := "dispatching_domains";
10343 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
);
10346 Make_Selected_Component
10349 Selector_Name
=> Sel_Id
);
10351 Set_Restriction_No_Dependence
10353 Warn
=> Treat_Restrictions_As_Warnings
,
10354 Profile
=> Ravenscar
);
10356 end Set_Ravenscar_Profile
;
10358 -- Start of processing for Analyze_Pragma
10361 -- The following code is a defense against recursion. Not clear that
10362 -- this can happen legitimately, but perhaps some error situations can
10363 -- cause it, and we did see this recursion during testing.
10365 if Analyzed
(N
) then
10371 Check_Restriction_No_Use_Of_Pragma
(N
);
10373 -- Ignore pragma if Ignore_Pragma applies
10375 if Get_Name_Table_Boolean3
(Pname
) then
10379 -- Deal with unrecognized pragma
10381 if not Is_Pragma_Name
(Pname
) then
10382 if Warn_On_Unrecognized_Pragma
then
10383 Error_Msg_Name_1
:= Pname
;
10384 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10386 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10387 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10388 Error_Msg_Name_1
:= PN
;
10389 Error_Msg_N
-- CODEFIX
10390 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
10399 -- Here to start processing for recognized pragma
10401 Prag_Id
:= Get_Pragma_Id
(Pname
);
10402 Pname
:= Original_Aspect_Pragma_Name
(N
);
10404 -- Capture setting of Opt.Uneval_Old
10406 case Opt
.Uneval_Old
is
10408 Set_Uneval_Old_Accept
(N
);
10414 Set_Uneval_Old_Warn
(N
);
10417 raise Program_Error
;
10420 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10421 -- is already set, indicating that we have already checked the policy
10422 -- at the right point. This happens for example in the case of a pragma
10423 -- that is derived from an Aspect.
10425 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10428 -- For a pragma that is a rewriting of another pragma, copy the
10429 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10431 elsif Is_Rewrite_Substitution
(N
)
10432 and then Nkind
(Original_Node
(N
)) = N_Pragma
10433 and then Original_Node
(N
) /= N
10435 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10436 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10438 -- Otherwise query the applicable policy at this point
10441 Check_Applicable_Policy
(N
);
10443 -- If pragma is disabled, rewrite as NULL and skip analysis
10445 if Is_Disabled
(N
) then
10446 Rewrite
(N
, Make_Null_Statement
(Loc
));
10452 -- Preset arguments
10460 if Present
(Pragma_Argument_Associations
(N
)) then
10461 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10462 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10464 if Present
(Arg1
) then
10465 Arg2
:= Next
(Arg1
);
10467 if Present
(Arg2
) then
10468 Arg3
:= Next
(Arg2
);
10470 if Present
(Arg3
) then
10471 Arg4
:= Next
(Arg3
);
10477 -- An enumeration type defines the pragmas that are supported by the
10478 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10479 -- into the corresponding enumeration value for the following case.
10487 -- pragma Abort_Defer;
10489 when Pragma_Abort_Defer
=>
10491 Check_Arg_Count
(0);
10493 -- The only required semantic processing is to check the
10494 -- placement. This pragma must appear at the start of the
10495 -- statement sequence of a handled sequence of statements.
10497 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10498 or else N
/= First
(Statements
(Parent
(N
)))
10503 --------------------
10504 -- Abstract_State --
10505 --------------------
10507 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10509 -- ABSTRACT_STATE_LIST ::=
10511 -- | STATE_NAME_WITH_OPTIONS
10512 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10514 -- STATE_NAME_WITH_OPTIONS ::=
10516 -- | (STATE_NAME with OPTION_LIST)
10518 -- OPTION_LIST ::= OPTION {, OPTION}
10522 -- | NAME_VALUE_OPTION
10524 -- SIMPLE_OPTION ::= Ghost | Synchronous
10526 -- NAME_VALUE_OPTION ::=
10527 -- Part_Of => ABSTRACT_STATE
10528 -- | External [=> EXTERNAL_PROPERTY_LIST]
10530 -- EXTERNAL_PROPERTY_LIST ::=
10531 -- EXTERNAL_PROPERTY
10532 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10534 -- EXTERNAL_PROPERTY ::=
10535 -- Async_Readers [=> boolean_EXPRESSION]
10536 -- | Async_Writers [=> boolean_EXPRESSION]
10537 -- | Effective_Reads [=> boolean_EXPRESSION]
10538 -- | Effective_Writes [=> boolean_EXPRESSION]
10539 -- others => boolean_EXPRESSION
10541 -- STATE_NAME ::= defining_identifier
10543 -- ABSTRACT_STATE ::= name
10545 -- Characteristics:
10547 -- * Analysis - The annotation is fully analyzed immediately upon
10548 -- elaboration as it cannot forward reference entities.
10550 -- * Expansion - None.
10552 -- * Template - The annotation utilizes the generic template of the
10553 -- related package declaration.
10555 -- * Globals - The annotation cannot reference global entities.
10557 -- * Instance - The annotation is instantiated automatically when
10558 -- the related generic package is instantiated.
10560 when Pragma_Abstract_State
=> Abstract_State
: declare
10561 Missing_Parentheses
: Boolean := False;
10562 -- Flag set when a state declaration with options is not properly
10565 -- Flags used to verify the consistency of states
10567 Non_Null_Seen
: Boolean := False;
10568 Null_Seen
: Boolean := False;
10570 procedure Analyze_Abstract_State
10572 Pack_Id
: Entity_Id
);
10573 -- Verify the legality of a single state declaration. Create and
10574 -- decorate a state abstraction entity and introduce it into the
10575 -- visibility chain. Pack_Id denotes the entity or the related
10576 -- package where pragma Abstract_State appears.
10578 procedure Malformed_State_Error
(State
: Node_Id
);
10579 -- Emit an error concerning the illegal declaration of abstract
10580 -- state State. This routine diagnoses syntax errors that lead to
10581 -- a different parse tree. The error is issued regardless of the
10582 -- SPARK mode in effect.
10584 ----------------------------
10585 -- Analyze_Abstract_State --
10586 ----------------------------
10588 procedure Analyze_Abstract_State
10590 Pack_Id
: Entity_Id
)
10592 -- Flags used to verify the consistency of options
10594 AR_Seen
: Boolean := False;
10595 AW_Seen
: Boolean := False;
10596 ER_Seen
: Boolean := False;
10597 EW_Seen
: Boolean := False;
10598 External_Seen
: Boolean := False;
10599 Ghost_Seen
: Boolean := False;
10600 Others_Seen
: Boolean := False;
10601 Part_Of_Seen
: Boolean := False;
10602 Synchronous_Seen
: Boolean := False;
10604 -- Flags used to store the static value of all external states'
10607 AR_Val
: Boolean := False;
10608 AW_Val
: Boolean := False;
10609 ER_Val
: Boolean := False;
10610 EW_Val
: Boolean := False;
10612 State_Id
: Entity_Id
:= Empty
;
10613 -- The entity to be generated for the current state declaration
10615 procedure Analyze_External_Option
(Opt
: Node_Id
);
10616 -- Verify the legality of option External
10618 procedure Analyze_External_Property
10620 Expr
: Node_Id
:= Empty
);
10621 -- Verify the legailty of a single external property. Prop
10622 -- denotes the external property. Expr is the expression used
10623 -- to set the property.
10625 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10626 -- Verify the legality of option Part_Of
10628 procedure Check_Duplicate_Option
10630 Status
: in out Boolean);
10631 -- Flag Status denotes whether a particular option has been
10632 -- seen while processing a state. This routine verifies that
10633 -- Opt is not a duplicate option and sets the flag Status
10634 -- (SPARK RM 7.1.4(1)).
10636 procedure Check_Duplicate_Property
10638 Status
: in out Boolean);
10639 -- Flag Status denotes whether a particular property has been
10640 -- seen while processing option External. This routine verifies
10641 -- that Prop is not a duplicate property and sets flag Status.
10642 -- Opt is not a duplicate property and sets the flag Status.
10643 -- (SPARK RM 7.1.4(2))
10645 procedure Check_Ghost_Synchronous
;
10646 -- Ensure that the abstract state is not subject to both Ghost
10647 -- and Synchronous simple options. Emit an error if this is the
10650 procedure Create_Abstract_State
10654 Is_Null
: Boolean);
10655 -- Generate an abstract state entity with name Nam and enter it
10656 -- into visibility. Decl is the "declaration" of the state as
10657 -- it appears in pragma Abstract_State. Loc is the location of
10658 -- the related state "declaration". Flag Is_Null should be set
10659 -- when the associated Abstract_State pragma defines a null
10662 -----------------------------
10663 -- Analyze_External_Option --
10664 -----------------------------
10666 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10667 Errors
: constant Nat
:= Serious_Errors_Detected
;
10669 Props
: Node_Id
:= Empty
;
10672 if Nkind
(Opt
) = N_Component_Association
then
10673 Props
:= Expression
(Opt
);
10676 -- External state with properties
10678 if Present
(Props
) then
10680 -- Multiple properties appear as an aggregate
10682 if Nkind
(Props
) = N_Aggregate
then
10684 -- Simple property form
10686 Prop
:= First
(Expressions
(Props
));
10687 while Present
(Prop
) loop
10688 Analyze_External_Property
(Prop
);
10692 -- Property with expression form
10694 Prop
:= First
(Component_Associations
(Props
));
10695 while Present
(Prop
) loop
10696 Analyze_External_Property
10697 (Prop
=> First
(Choices
(Prop
)),
10698 Expr
=> Expression
(Prop
));
10706 Analyze_External_Property
(Props
);
10709 -- An external state defined without any properties defaults
10710 -- all properties to True.
10719 -- Once all external properties have been processed, verify
10720 -- their mutual interaction. Do not perform the check when
10721 -- at least one of the properties is illegal as this will
10722 -- produce a bogus error.
10724 if Errors
= Serious_Errors_Detected
then
10725 Check_External_Properties
10726 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10728 end Analyze_External_Option
;
10730 -------------------------------
10731 -- Analyze_External_Property --
10732 -------------------------------
10734 procedure Analyze_External_Property
10736 Expr
: Node_Id
:= Empty
)
10738 Expr_Val
: Boolean;
10741 -- Check the placement of "others" (if available)
10743 if Nkind
(Prop
) = N_Others_Choice
then
10744 if Others_Seen
then
10746 ("only one others choice allowed in option External",
10749 Others_Seen
:= True;
10752 elsif Others_Seen
then
10754 ("others must be the last property in option External",
10757 -- The only remaining legal options are the four predefined
10758 -- external properties.
10760 elsif Nkind
(Prop
) = N_Identifier
10761 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10762 Name_Async_Writers
,
10763 Name_Effective_Reads
,
10764 Name_Effective_Writes
)
10768 -- Otherwise the construct is not a valid property
10771 SPARK_Msg_N
("invalid external state property", Prop
);
10775 -- Ensure that the expression of the external state property
10776 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10778 if Present
(Expr
) then
10779 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10781 if Is_OK_Static_Expression
(Expr
) then
10782 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10785 ("expression of external state property must be "
10789 -- The lack of expression defaults the property to True
10795 -- Named properties
10797 if Nkind
(Prop
) = N_Identifier
then
10798 if Chars
(Prop
) = Name_Async_Readers
then
10799 Check_Duplicate_Property
(Prop
, AR_Seen
);
10800 AR_Val
:= Expr_Val
;
10802 elsif Chars
(Prop
) = Name_Async_Writers
then
10803 Check_Duplicate_Property
(Prop
, AW_Seen
);
10804 AW_Val
:= Expr_Val
;
10806 elsif Chars
(Prop
) = Name_Effective_Reads
then
10807 Check_Duplicate_Property
(Prop
, ER_Seen
);
10808 ER_Val
:= Expr_Val
;
10811 Check_Duplicate_Property
(Prop
, EW_Seen
);
10812 EW_Val
:= Expr_Val
;
10815 -- The handling of property "others" must take into account
10816 -- all other named properties that have been encountered so
10817 -- far. Only those that have not been seen are affected by
10821 if not AR_Seen
then
10822 AR_Val
:= Expr_Val
;
10825 if not AW_Seen
then
10826 AW_Val
:= Expr_Val
;
10829 if not ER_Seen
then
10830 ER_Val
:= Expr_Val
;
10833 if not EW_Seen
then
10834 EW_Val
:= Expr_Val
;
10837 end Analyze_External_Property
;
10839 ----------------------------
10840 -- Analyze_Part_Of_Option --
10841 ----------------------------
10843 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
10844 Encap
: constant Node_Id
:= Expression
(Opt
);
10845 Constits
: Elist_Id
;
10846 Encap_Id
: Entity_Id
;
10850 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
10853 (Indic
=> First
(Choices
(Opt
)),
10854 Item_Id
=> State_Id
,
10856 Encap_Id
=> Encap_Id
,
10859 -- The Part_Of indicator transforms the abstract state into
10860 -- a constituent of the encapsulating state or single
10861 -- concurrent type.
10864 pragma Assert
(Present
(Encap_Id
));
10865 Constits
:= Part_Of_Constituents
(Encap_Id
);
10867 if No
(Constits
) then
10868 Constits
:= New_Elmt_List
;
10869 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
10872 Append_Elmt
(State_Id
, Constits
);
10873 Set_Encapsulating_State
(State_Id
, Encap_Id
);
10875 end Analyze_Part_Of_Option
;
10877 ----------------------------
10878 -- Check_Duplicate_Option --
10879 ----------------------------
10881 procedure Check_Duplicate_Option
10883 Status
: in out Boolean)
10887 SPARK_Msg_N
("duplicate state option", Opt
);
10891 end Check_Duplicate_Option
;
10893 ------------------------------
10894 -- Check_Duplicate_Property --
10895 ------------------------------
10897 procedure Check_Duplicate_Property
10899 Status
: in out Boolean)
10903 SPARK_Msg_N
("duplicate external property", Prop
);
10907 end Check_Duplicate_Property
;
10909 -----------------------------
10910 -- Check_Ghost_Synchronous --
10911 -----------------------------
10913 procedure Check_Ghost_Synchronous
is
10915 -- A synchronized abstract state cannot be Ghost and vice
10916 -- versa (SPARK RM 6.9(19)).
10918 if Ghost_Seen
and Synchronous_Seen
then
10919 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
10921 end Check_Ghost_Synchronous
;
10923 ---------------------------
10924 -- Create_Abstract_State --
10925 ---------------------------
10927 procedure Create_Abstract_State
10934 -- The abstract state may be semi-declared when the related
10935 -- package was withed through a limited with clause. In that
10936 -- case reuse the entity to fully declare the state.
10938 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
10939 State_Id
:= Entity
(Decl
);
10941 -- Otherwise the elaboration of pragma Abstract_State
10942 -- declares the state.
10945 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
10947 if Present
(Decl
) then
10948 Set_Entity
(Decl
, State_Id
);
10952 -- Null states never come from source
10954 Set_Comes_From_Source
(State_Id
, not Is_Null
);
10955 Set_Parent
(State_Id
, State
);
10956 Set_Ekind
(State_Id
, E_Abstract_State
);
10957 Set_Etype
(State_Id
, Standard_Void_Type
);
10958 Set_Encapsulating_State
(State_Id
, Empty
);
10960 -- An abstract state declared within a Ghost region becomes
10961 -- Ghost (SPARK RM 6.9(2)).
10963 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
10964 Set_Is_Ghost_Entity
(State_Id
);
10967 -- Establish a link between the state declaration and the
10968 -- abstract state entity. Note that a null state remains as
10969 -- N_Null and does not carry any linkages.
10971 if not Is_Null
then
10972 if Present
(Decl
) then
10973 Set_Entity
(Decl
, State_Id
);
10974 Set_Etype
(Decl
, Standard_Void_Type
);
10977 -- Every non-null state must be defined, nameable and
10980 Push_Scope
(Pack_Id
);
10981 Generate_Definition
(State_Id
);
10982 Enter_Name
(State_Id
);
10985 end Create_Abstract_State
;
10992 -- Start of processing for Analyze_Abstract_State
10995 -- A package with a null abstract state is not allowed to
10996 -- declare additional states.
11000 ("package & has null abstract state", State
, Pack_Id
);
11002 -- Null states appear as internally generated entities
11004 elsif Nkind
(State
) = N_Null
then
11005 Create_Abstract_State
11006 (Nam
=> New_Internal_Name
('S'),
11008 Loc
=> Sloc
(State
),
11012 -- Catch a case where a null state appears in a list of
11013 -- non-null states.
11015 if Non_Null_Seen
then
11017 ("package & has non-null abstract state",
11021 -- Simple state declaration
11023 elsif Nkind
(State
) = N_Identifier
then
11024 Create_Abstract_State
11025 (Nam
=> Chars
(State
),
11027 Loc
=> Sloc
(State
),
11029 Non_Null_Seen
:= True;
11031 -- State declaration with various options. This construct
11032 -- appears as an extension aggregate in the tree.
11034 elsif Nkind
(State
) = N_Extension_Aggregate
then
11035 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11036 Create_Abstract_State
11037 (Nam
=> Chars
(Ancestor_Part
(State
)),
11038 Decl
=> Ancestor_Part
(State
),
11039 Loc
=> Sloc
(Ancestor_Part
(State
)),
11041 Non_Null_Seen
:= True;
11044 ("state name must be an identifier",
11045 Ancestor_Part
(State
));
11048 -- Options External, Ghost and Synchronous appear as
11051 Opt
:= First
(Expressions
(State
));
11052 while Present
(Opt
) loop
11053 if Nkind
(Opt
) = N_Identifier
then
11057 if Chars
(Opt
) = Name_External
then
11058 Check_Duplicate_Option
(Opt
, External_Seen
);
11059 Analyze_External_Option
(Opt
);
11063 elsif Chars
(Opt
) = Name_Ghost
then
11064 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11065 Check_Ghost_Synchronous
;
11067 if Present
(State_Id
) then
11068 Set_Is_Ghost_Entity
(State_Id
);
11073 elsif Chars
(Opt
) = Name_Synchronous
then
11074 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11075 Check_Ghost_Synchronous
;
11077 -- Option Part_Of without an encapsulating state is
11078 -- illegal (SPARK RM 7.1.4(9)).
11080 elsif Chars
(Opt
) = Name_Part_Of
then
11082 ("indicator Part_Of must denote abstract state, "
11083 & "single protected type or single task type",
11086 -- Do not emit an error message when a previous state
11087 -- declaration with options was not parenthesized as
11088 -- the option is actually another state declaration.
11090 -- with Abstract_State
11091 -- (State_1 with ..., -- missing parentheses
11092 -- (State_2 with ...),
11093 -- State_3) -- ok state declaration
11095 elsif Missing_Parentheses
then
11098 -- Otherwise the option is not allowed. Note that it
11099 -- is not possible to distinguish between an option
11100 -- and a state declaration when a previous state with
11101 -- options not properly parentheses.
11103 -- with Abstract_State
11104 -- (State_1 with ..., -- missing parentheses
11105 -- State_2); -- could be an option
11109 ("simple option not allowed in state declaration",
11113 -- Catch a case where missing parentheses around a state
11114 -- declaration with options cause a subsequent state
11115 -- declaration with options to be treated as an option.
11117 -- with Abstract_State
11118 -- (State_1 with ..., -- missing parentheses
11119 -- (State_2 with ...))
11121 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11122 Missing_Parentheses
:= True;
11124 ("state declaration must be parenthesized",
11125 Ancestor_Part
(State
));
11127 -- Otherwise the option is malformed
11130 SPARK_Msg_N
("malformed option", Opt
);
11136 -- Options External and Part_Of appear as component
11139 Opt
:= First
(Component_Associations
(State
));
11140 while Present
(Opt
) loop
11141 Opt_Nam
:= First
(Choices
(Opt
));
11143 if Nkind
(Opt_Nam
) = N_Identifier
then
11144 if Chars
(Opt_Nam
) = Name_External
then
11145 Analyze_External_Option
(Opt
);
11147 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11148 Analyze_Part_Of_Option
(Opt
);
11151 SPARK_Msg_N
("invalid state option", Opt
);
11154 SPARK_Msg_N
("invalid state option", Opt
);
11160 -- Any other attempt to declare a state is illegal
11163 Malformed_State_Error
(State
);
11167 -- Guard against a junk state. In such cases no entity is
11168 -- generated and the subsequent checks cannot be applied.
11170 if Present
(State_Id
) then
11172 -- Verify whether the state does not introduce an illegal
11173 -- hidden state within a package subject to a null abstract
11176 Check_No_Hidden_State
(State_Id
);
11178 -- Check whether the lack of option Part_Of agrees with the
11179 -- placement of the abstract state with respect to the state
11182 if not Part_Of_Seen
then
11183 Check_Missing_Part_Of
(State_Id
);
11186 -- Associate the state with its related package
11188 if No
(Abstract_States
(Pack_Id
)) then
11189 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11192 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11194 end Analyze_Abstract_State
;
11196 ---------------------------
11197 -- Malformed_State_Error --
11198 ---------------------------
11200 procedure Malformed_State_Error
(State
: Node_Id
) is
11202 Error_Msg_N
("malformed abstract state declaration", State
);
11204 -- An abstract state with a simple option is being declared
11205 -- with "=>" rather than the legal "with". The state appears
11206 -- as a component association.
11208 if Nkind
(State
) = N_Component_Association
then
11209 Error_Msg_N
("\use WITH to specify simple option", State
);
11211 end Malformed_State_Error
;
11215 Pack_Decl
: Node_Id
;
11216 Pack_Id
: Entity_Id
;
11220 -- Start of processing for Abstract_State
11224 Check_No_Identifiers
;
11225 Check_Arg_Count
(1);
11227 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11229 -- Ensure the proper placement of the pragma. Abstract states must
11230 -- be associated with a package declaration.
11232 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11233 N_Package_Declaration
)
11237 -- Otherwise the pragma is associated with an illegal construct
11244 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11246 -- A pragma that applies to a Ghost entity becomes Ghost for the
11247 -- purposes of legality checks and removal of ignored Ghost code.
11249 Mark_Ghost_Pragma
(N
, Pack_Id
);
11250 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11252 -- Chain the pragma on the contract for completeness
11254 Add_Contract_Item
(N
, Pack_Id
);
11256 -- The legality checks of pragmas Abstract_State, Initializes, and
11257 -- Initial_Condition are affected by the SPARK mode in effect. In
11258 -- addition, these three pragmas are subject to an inherent order:
11260 -- 1) Abstract_State
11262 -- 3) Initial_Condition
11264 -- Analyze all these pragmas in the order outlined above
11266 Analyze_If_Present
(Pragma_SPARK_Mode
);
11267 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11269 -- Multiple non-null abstract states appear as an aggregate
11271 if Nkind
(States
) = N_Aggregate
then
11272 State
:= First
(Expressions
(States
));
11273 while Present
(State
) loop
11274 Analyze_Abstract_State
(State
, Pack_Id
);
11278 -- An abstract state with a simple option is being illegaly
11279 -- declared with "=>" rather than "with". In this case the
11280 -- state declaration appears as a component association.
11282 if Present
(Component_Associations
(States
)) then
11283 State
:= First
(Component_Associations
(States
));
11284 while Present
(State
) loop
11285 Malformed_State_Error
(State
);
11290 -- Various forms of a single abstract state. Note that these may
11291 -- include malformed state declarations.
11294 Analyze_Abstract_State
(States
, Pack_Id
);
11297 Analyze_If_Present
(Pragma_Initializes
);
11298 Analyze_If_Present
(Pragma_Initial_Condition
);
11299 end Abstract_State
;
11307 -- Note: this pragma also has some specific processing in Par.Prag
11308 -- because we want to set the Ada version mode during parsing.
11310 when Pragma_Ada_83
=>
11312 Check_Arg_Count
(0);
11314 -- We really should check unconditionally for proper configuration
11315 -- pragma placement, since we really don't want mixed Ada modes
11316 -- within a single unit, and the GNAT reference manual has always
11317 -- said this was a configuration pragma, but we did not check and
11318 -- are hesitant to add the check now.
11320 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11321 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11322 -- or Ada 2012 mode.
11324 if Ada_Version
>= Ada_2005
then
11325 Check_Valid_Configuration_Pragma
;
11328 -- Now set Ada 83 mode
11330 if not Latest_Ada_Only
then
11331 Ada_Version
:= Ada_83
;
11332 Ada_Version_Explicit
:= Ada_83
;
11333 Ada_Version_Pragma
:= N
;
11342 -- Note: this pragma also has some specific processing in Par.Prag
11343 -- because we want to set the Ada 83 version mode during parsing.
11345 when Pragma_Ada_95
=>
11347 Check_Arg_Count
(0);
11349 -- We really should check unconditionally for proper configuration
11350 -- pragma placement, since we really don't want mixed Ada modes
11351 -- within a single unit, and the GNAT reference manual has always
11352 -- said this was a configuration pragma, but we did not check and
11353 -- are hesitant to add the check now.
11355 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11356 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11358 if Ada_Version
>= Ada_2005
then
11359 Check_Valid_Configuration_Pragma
;
11362 -- Now set Ada 95 mode
11364 if not Latest_Ada_Only
then
11365 Ada_Version
:= Ada_95
;
11366 Ada_Version_Explicit
:= Ada_95
;
11367 Ada_Version_Pragma
:= N
;
11370 ---------------------
11371 -- Ada_05/Ada_2005 --
11372 ---------------------
11375 -- pragma Ada_05 (LOCAL_NAME);
11377 -- pragma Ada_2005;
11378 -- pragma Ada_2005 (LOCAL_NAME):
11380 -- Note: these pragmas also have some specific processing in Par.Prag
11381 -- because we want to set the Ada 2005 version mode during parsing.
11383 -- The one argument form is used for managing the transition from
11384 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11385 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11386 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11387 -- mode, a preference rule is established which does not choose
11388 -- such an entity unless it is unambiguously specified. This avoids
11389 -- extra subprograms marked this way from generating ambiguities in
11390 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11391 -- intended for exclusive use in the GNAT run-time library.
11402 if Arg_Count
= 1 then
11403 Check_Arg_Is_Local_Name
(Arg1
);
11404 E_Id
:= Get_Pragma_Arg
(Arg1
);
11406 if Etype
(E_Id
) = Any_Type
then
11410 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
11411 Record_Rep_Item
(Entity
(E_Id
), N
);
11414 Check_Arg_Count
(0);
11416 -- For Ada_2005 we unconditionally enforce the documented
11417 -- configuration pragma placement, since we do not want to
11418 -- tolerate mixed modes in a unit involving Ada 2005. That
11419 -- would cause real difficulties for those cases where there
11420 -- are incompatibilities between Ada 95 and Ada 2005.
11422 Check_Valid_Configuration_Pragma
;
11424 -- Now set appropriate Ada mode
11426 if not Latest_Ada_Only
then
11427 Ada_Version
:= Ada_2005
;
11428 Ada_Version_Explicit
:= Ada_2005
;
11429 Ada_Version_Pragma
:= N
;
11434 ---------------------
11435 -- Ada_12/Ada_2012 --
11436 ---------------------
11439 -- pragma Ada_12 (LOCAL_NAME);
11441 -- pragma Ada_2012;
11442 -- pragma Ada_2012 (LOCAL_NAME):
11444 -- Note: these pragmas also have some specific processing in Par.Prag
11445 -- because we want to set the Ada 2012 version mode during parsing.
11447 -- The one argument form is used for managing the transition from Ada
11448 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11449 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11450 -- mode will generate a warning. In addition, in any pre-Ada_2012
11451 -- mode, a preference rule is established which does not choose
11452 -- such an entity unless it is unambiguously specified. This avoids
11453 -- extra subprograms marked this way from generating ambiguities in
11454 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11455 -- intended for exclusive use in the GNAT run-time library.
11466 if Arg_Count
= 1 then
11467 Check_Arg_Is_Local_Name
(Arg1
);
11468 E_Id
:= Get_Pragma_Arg
(Arg1
);
11470 if Etype
(E_Id
) = Any_Type
then
11474 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
11475 Record_Rep_Item
(Entity
(E_Id
), N
);
11478 Check_Arg_Count
(0);
11480 -- For Ada_2012 we unconditionally enforce the documented
11481 -- configuration pragma placement, since we do not want to
11482 -- tolerate mixed modes in a unit involving Ada 2012. That
11483 -- would cause real difficulties for those cases where there
11484 -- are incompatibilities between Ada 95 and Ada 2012. We could
11485 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11487 Check_Valid_Configuration_Pragma
;
11489 -- Now set appropriate Ada mode
11491 Ada_Version
:= Ada_2012
;
11492 Ada_Version_Explicit
:= Ada_2012
;
11493 Ada_Version_Pragma
:= N
;
11497 ----------------------
11498 -- All_Calls_Remote --
11499 ----------------------
11501 -- pragma All_Calls_Remote [(library_package_NAME)];
11503 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
11504 Lib_Entity
: Entity_Id
;
11507 Check_Ada_83_Warning
;
11508 Check_Valid_Library_Unit_Pragma
;
11510 if Nkind
(N
) = N_Null_Statement
then
11514 Lib_Entity
:= Find_Lib_Unit_Name
;
11516 -- A pragma that applies to a Ghost entity becomes Ghost for the
11517 -- purposes of legality checks and removal of ignored Ghost code.
11519 Mark_Ghost_Pragma
(N
, Lib_Entity
);
11521 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11523 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
11524 if not Is_Remote_Call_Interface
(Lib_Entity
) then
11525 Error_Pragma
("pragma% only apply to rci unit");
11527 -- Set flag for entity of the library unit
11530 Set_Has_All_Calls_Remote
(Lib_Entity
);
11533 end All_Calls_Remote
;
11535 ---------------------------
11536 -- Allow_Integer_Address --
11537 ---------------------------
11539 -- pragma Allow_Integer_Address;
11541 when Pragma_Allow_Integer_Address
=>
11543 Check_Valid_Configuration_Pragma
;
11544 Check_Arg_Count
(0);
11546 -- If Address is a private type, then set the flag to allow
11547 -- integer address values. If Address is not private, then this
11548 -- pragma has no purpose, so it is simply ignored. Not clear if
11549 -- there are any such targets now.
11551 if Opt
.Address_Is_Private
then
11552 Opt
.Allow_Integer_Address
:= True;
11560 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11561 -- ARG ::= NAME | EXPRESSION
11563 -- The first two arguments are by convention intended to refer to an
11564 -- external tool and a tool-specific function. These arguments are
11567 when Pragma_Annotate
=> Annotate
: declare
11574 Check_At_Least_N_Arguments
(1);
11576 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
11578 -- Determine whether the last argument is "Entity => local_NAME"
11579 -- and if it is, perform the required semantic checks. Remove the
11580 -- argument from further processing.
11582 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
11583 and then Chars
(Nam_Arg
) = Name_Entity
11585 Check_Arg_Is_Local_Name
(Nam_Arg
);
11586 Arg_Count
:= Arg_Count
- 1;
11588 -- A pragma that applies to a Ghost entity becomes Ghost for
11589 -- the purposes of legality checks and removal of ignored Ghost
11592 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
11593 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
11595 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
11598 -- Not allowed in compiler units (bootstrap issues)
11600 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
11603 -- Continue the processing with last argument removed for now
11605 Check_Arg_Is_Identifier
(Arg1
);
11606 Check_No_Identifiers
;
11609 -- The second parameter is optional, it is never analyzed
11614 -- Otherwise there is a second parameter
11617 -- The second parameter must be an identifier
11619 Check_Arg_Is_Identifier
(Arg2
);
11621 -- Process the remaining parameters (if any)
11623 Arg
:= Next
(Arg2
);
11624 while Present
(Arg
) loop
11625 Expr
:= Get_Pragma_Arg
(Arg
);
11628 if Is_Entity_Name
(Expr
) then
11631 -- For string literals, we assume Standard_String as the
11632 -- type, unless the string contains wide or wide_wide
11635 elsif Nkind
(Expr
) = N_String_Literal
then
11636 if Has_Wide_Wide_Character
(Expr
) then
11637 Resolve
(Expr
, Standard_Wide_Wide_String
);
11638 elsif Has_Wide_Character
(Expr
) then
11639 Resolve
(Expr
, Standard_Wide_String
);
11641 Resolve
(Expr
, Standard_String
);
11644 elsif Is_Overloaded
(Expr
) then
11645 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
11656 -------------------------------------------------
11657 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11658 -------------------------------------------------
11661 -- ( [Check => ] Boolean_EXPRESSION
11662 -- [, [Message =>] Static_String_EXPRESSION]);
11664 -- pragma Assert_And_Cut
11665 -- ( [Check => ] Boolean_EXPRESSION
11666 -- [, [Message =>] Static_String_EXPRESSION]);
11669 -- ( [Check => ] Boolean_EXPRESSION
11670 -- [, [Message =>] Static_String_EXPRESSION]);
11672 -- pragma Loop_Invariant
11673 -- ( [Check => ] Boolean_EXPRESSION
11674 -- [, [Message =>] Static_String_EXPRESSION]);
11677 | Pragma_Assert_And_Cut
11679 | Pragma_Loop_Invariant
11682 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
11683 -- Determine whether expression Expr contains a Loop_Entry
11684 -- attribute reference.
11686 -------------------------
11687 -- Contains_Loop_Entry --
11688 -------------------------
11690 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
11691 Has_Loop_Entry
: Boolean := False;
11693 function Process
(N
: Node_Id
) return Traverse_Result
;
11694 -- Process function for traversal to look for Loop_Entry
11700 function Process
(N
: Node_Id
) return Traverse_Result
is
11702 if Nkind
(N
) = N_Attribute_Reference
11703 and then Attribute_Name
(N
) = Name_Loop_Entry
11705 Has_Loop_Entry
:= True;
11712 procedure Traverse
is new Traverse_Proc
(Process
);
11714 -- Start of processing for Contains_Loop_Entry
11718 return Has_Loop_Entry
;
11719 end Contains_Loop_Entry
;
11724 New_Args
: List_Id
;
11726 -- Start of processing for Assert
11729 -- Assert is an Ada 2005 RM-defined pragma
11731 if Prag_Id
= Pragma_Assert
then
11734 -- The remaining ones are GNAT pragmas
11740 Check_At_Least_N_Arguments
(1);
11741 Check_At_Most_N_Arguments
(2);
11742 Check_Arg_Order
((Name_Check
, Name_Message
));
11743 Check_Optional_Identifier
(Arg1
, Name_Check
);
11744 Expr
:= Get_Pragma_Arg
(Arg1
);
11746 -- Special processing for Loop_Invariant, Loop_Variant or for
11747 -- other cases where a Loop_Entry attribute is present. If the
11748 -- assertion pragma contains attribute Loop_Entry, ensure that
11749 -- the related pragma is within a loop.
11751 if Prag_Id
= Pragma_Loop_Invariant
11752 or else Prag_Id
= Pragma_Loop_Variant
11753 or else Contains_Loop_Entry
(Expr
)
11755 Check_Loop_Pragma_Placement
;
11757 -- Perform preanalysis to deal with embedded Loop_Entry
11760 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
11763 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11764 -- a corresponding Check pragma:
11766 -- pragma Check (name, condition [, msg]);
11768 -- Where name is the identifier matching the pragma name. So
11769 -- rewrite pragma in this manner, transfer the message argument
11770 -- if present, and analyze the result
11772 -- Note: When dealing with a semantically analyzed tree, the
11773 -- information that a Check node N corresponds to a source Assert,
11774 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11775 -- pragma kind of Original_Node(N).
11777 New_Args
:= New_List
(
11778 Make_Pragma_Argument_Association
(Loc
,
11779 Expression
=> Make_Identifier
(Loc
, Pname
)),
11780 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11781 Expression
=> Expr
));
11783 if Arg_Count
> 1 then
11784 Check_Optional_Identifier
(Arg2
, Name_Message
);
11786 -- Provide semantic annnotations for optional argument, for
11787 -- ASIS use, before rewriting.
11789 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11790 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
11793 -- Rewrite as Check pragma
11797 Chars
=> Name_Check
,
11798 Pragma_Argument_Associations
=> New_Args
));
11803 ----------------------
11804 -- Assertion_Policy --
11805 ----------------------
11807 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11809 -- The following form is Ada 2012 only, but we allow it in all modes
11811 -- Pragma Assertion_Policy (
11812 -- ASSERTION_KIND => POLICY_IDENTIFIER
11813 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11815 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11817 -- RM_ASSERTION_KIND ::= Assert |
11818 -- Static_Predicate |
11819 -- Dynamic_Predicate |
11824 -- Type_Invariant |
11825 -- Type_Invariant'Class
11827 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11829 -- Contract_Cases |
11831 -- Default_Initial_Condition |
11833 -- Initial_Condition |
11834 -- Loop_Invariant |
11840 -- Statement_Assertions
11842 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
11843 -- ID_ASSERTION_KIND list contains implementation-defined additions
11844 -- recognized by GNAT. The effect is to control the behavior of
11845 -- identically named aspects and pragmas, depending on the specified
11846 -- policy identifier:
11848 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
11850 -- Note: Check and Ignore are language-defined. Disable is a GNAT
11851 -- implementation-defined addition that results in totally ignoring
11852 -- the corresponding assertion. If Disable is specified, then the
11853 -- argument of the assertion is not even analyzed. This is useful
11854 -- when the aspect/pragma argument references entities in a with'ed
11855 -- package that is replaced by a dummy package in the final build.
11857 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
11858 -- and Type_Invariant'Class were recognized by the parser and
11859 -- transformed into references to the special internal identifiers
11860 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
11861 -- processing is required here.
11863 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
11864 procedure Resolve_Suppressible
(Policy
: Node_Id
);
11865 -- Converts the assertion policy 'Suppressible' to either Check or
11866 -- Ignore based on whether checks are suppressed via -gnatp.
11868 --------------------------
11869 -- Resolve_Suppressible --
11870 --------------------------
11872 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
11873 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
11877 -- Transform policy argument Suppressible into either Ignore or
11878 -- Check depending on whether checks are enabled or suppressed.
11880 if Chars
(Arg
) = Name_Suppressible
then
11881 if Suppress_Checks
then
11882 Nam
:= Name_Ignore
;
11887 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
11889 end Resolve_Suppressible
;
11901 -- This can always appear as a configuration pragma
11903 if Is_Configuration_Pragma
then
11906 -- It can also appear in a declarative part or package spec in Ada
11907 -- 2012 mode. We allow this in other modes, but in that case we
11908 -- consider that we have an Ada 2012 pragma on our hands.
11911 Check_Is_In_Decl_Part_Or_Package_Spec
;
11915 -- One argument case with no identifier (first form above)
11918 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
11919 or else Chars
(Arg1
) = No_Name
)
11921 Check_Arg_Is_One_Of
(Arg1
,
11922 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
11924 Resolve_Suppressible
(Arg1
);
11926 -- Treat one argument Assertion_Policy as equivalent to:
11928 -- pragma Check_Policy (Assertion, policy)
11930 -- So rewrite pragma in that manner and link on to the chain
11931 -- of Check_Policy pragmas, marking the pragma as analyzed.
11933 Policy
:= Get_Pragma_Arg
(Arg1
);
11937 Chars
=> Name_Check_Policy
,
11938 Pragma_Argument_Associations
=> New_List
(
11939 Make_Pragma_Argument_Association
(Loc
,
11940 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
11942 Make_Pragma_Argument_Association
(Loc
,
11944 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
11947 -- Here if we have two or more arguments
11950 Check_At_Least_N_Arguments
(1);
11953 -- Loop through arguments
11956 while Present
(Arg
) loop
11957 LocP
:= Sloc
(Arg
);
11959 -- Kind must be specified
11961 if Nkind
(Arg
) /= N_Pragma_Argument_Association
11962 or else Chars
(Arg
) = No_Name
11965 ("missing assertion kind for pragma%", Arg
);
11968 -- Check Kind and Policy have allowed forms
11970 Kind
:= Chars
(Arg
);
11971 Policy
:= Get_Pragma_Arg
(Arg
);
11973 if not Is_Valid_Assertion_Kind
(Kind
) then
11975 ("invalid assertion kind for pragma%", Arg
);
11978 Check_Arg_Is_One_Of
(Arg
,
11979 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
11981 Resolve_Suppressible
(Arg
);
11983 if Kind
= Name_Ghost
then
11985 -- The Ghost policy must be either Check or Ignore
11986 -- (SPARK RM 6.9(6)).
11988 if not Nam_In
(Chars
(Policy
), Name_Check
,
11992 ("argument of pragma % Ghost must be Check or "
11993 & "Ignore", Policy
);
11996 -- Pragma Assertion_Policy specifying a Ghost policy
11997 -- cannot occur within a Ghost subprogram or package
11998 -- (SPARK RM 6.9(14)).
12000 if Ghost_Mode
> None
then
12002 ("pragma % cannot appear within ghost subprogram or "
12007 -- Rewrite the Assertion_Policy pragma as a series of
12008 -- Check_Policy pragmas of the form:
12010 -- Check_Policy (Kind, Policy);
12012 -- Note: the insertion of the pragmas cannot be done with
12013 -- Insert_Action because in the configuration case, there
12014 -- are no scopes on the scope stack and the mechanism will
12017 Insert_Before_And_Analyze
(N
,
12019 Chars
=> Name_Check_Policy
,
12020 Pragma_Argument_Associations
=> New_List
(
12021 Make_Pragma_Argument_Association
(LocP
,
12022 Expression
=> Make_Identifier
(LocP
, Kind
)),
12023 Make_Pragma_Argument_Association
(LocP
,
12024 Expression
=> Policy
))));
12029 -- Rewrite the Assertion_Policy pragma as null since we have
12030 -- now inserted all the equivalent Check pragmas.
12032 Rewrite
(N
, Make_Null_Statement
(Loc
));
12035 end Assertion_Policy
;
12037 ------------------------------
12038 -- Assume_No_Invalid_Values --
12039 ------------------------------
12041 -- pragma Assume_No_Invalid_Values (On | Off);
12043 when Pragma_Assume_No_Invalid_Values
=>
12045 Check_Valid_Configuration_Pragma
;
12046 Check_Arg_Count
(1);
12047 Check_No_Identifiers
;
12048 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12050 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12051 Assume_No_Invalid_Values
:= True;
12053 Assume_No_Invalid_Values
:= False;
12056 --------------------------
12057 -- Attribute_Definition --
12058 --------------------------
12060 -- pragma Attribute_Definition
12061 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12062 -- [Entity =>] LOCAL_NAME,
12063 -- [Expression =>] EXPRESSION | NAME);
12065 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12066 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12071 Check_Arg_Count
(3);
12072 Check_Optional_Identifier
(Arg1
, "attribute");
12073 Check_Optional_Identifier
(Arg2
, "entity");
12074 Check_Optional_Identifier
(Arg3
, "expression");
12076 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12077 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12081 Check_Arg_Is_Local_Name
(Arg2
);
12083 -- If the attribute is not recognized, then issue a warning (not
12084 -- an error), and ignore the pragma.
12086 Aname
:= Chars
(Attribute_Designator
);
12088 if not Is_Attribute_Name
(Aname
) then
12089 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12093 -- Otherwise, rewrite the pragma as an attribute definition clause
12096 Make_Attribute_Definition_Clause
(Loc
,
12097 Name
=> Get_Pragma_Arg
(Arg2
),
12099 Expression
=> Get_Pragma_Arg
(Arg3
)));
12101 end Attribute_Definition
;
12103 ------------------------------------------------------------------
12104 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12105 ------------------------------------------------------------------
12107 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12108 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12109 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12110 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12112 when Pragma_Async_Readers
12113 | Pragma_Async_Writers
12114 | Pragma_Effective_Reads
12115 | Pragma_Effective_Writes
12117 Async_Effective
: declare
12118 Obj_Decl
: Node_Id
;
12119 Obj_Id
: Entity_Id
;
12123 Check_No_Identifiers
;
12124 Check_At_Most_N_Arguments
(1);
12126 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12128 -- Object declaration
12130 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12133 -- Otherwise the pragma is associated with an illegal construact
12140 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12142 -- Perform minimal verification to ensure that the argument is at
12143 -- least a variable. Subsequent finer grained checks will be done
12144 -- at the end of the declarative region the contains the pragma.
12146 if Ekind
(Obj_Id
) = E_Variable
then
12148 -- A pragma that applies to a Ghost entity becomes Ghost for
12149 -- the purposes of legality checks and removal of ignored Ghost
12152 Mark_Ghost_Pragma
(N
, Obj_Id
);
12154 -- Chain the pragma on the contract for further processing by
12155 -- Analyze_External_Property_In_Decl_Part.
12157 Add_Contract_Item
(N
, Obj_Id
);
12159 -- Analyze the Boolean expression (if any)
12161 if Present
(Arg1
) then
12162 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12165 -- Otherwise the external property applies to a constant
12168 Error_Pragma
("pragma % must apply to a volatile object");
12170 end Async_Effective
;
12176 -- pragma Asynchronous (LOCAL_NAME);
12178 when Pragma_Asynchronous
=> Asynchronous
: declare
12181 Formal
: Entity_Id
;
12186 procedure Process_Async_Pragma
;
12187 -- Common processing for procedure and access-to-procedure case
12189 --------------------------
12190 -- Process_Async_Pragma --
12191 --------------------------
12193 procedure Process_Async_Pragma
is
12196 Set_Is_Asynchronous
(Nm
);
12200 -- The formals should be of mode IN (RM E.4.1(6))
12203 while Present
(S
) loop
12204 Formal
:= Defining_Identifier
(S
);
12206 if Nkind
(Formal
) = N_Defining_Identifier
12207 and then Ekind
(Formal
) /= E_In_Parameter
12210 ("pragma% procedure can only have IN parameter",
12217 Set_Is_Asynchronous
(Nm
);
12218 end Process_Async_Pragma
;
12220 -- Start of processing for pragma Asynchronous
12223 Check_Ada_83_Warning
;
12224 Check_No_Identifiers
;
12225 Check_Arg_Count
(1);
12226 Check_Arg_Is_Local_Name
(Arg1
);
12228 if Debug_Flag_U
then
12232 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12233 Analyze
(Get_Pragma_Arg
(Arg1
));
12234 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12236 -- A pragma that applies to a Ghost entity becomes Ghost for the
12237 -- purposes of legality checks and removal of ignored Ghost code.
12239 Mark_Ghost_Pragma
(N
, Nm
);
12241 if not Is_Remote_Call_Interface
(C_Ent
)
12242 and then not Is_Remote_Types
(C_Ent
)
12244 -- This pragma should only appear in an RCI or Remote Types
12245 -- unit (RM E.4.1(4)).
12248 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12251 if Ekind
(Nm
) = E_Procedure
12252 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12254 if not Is_Remote_Call_Interface
(Nm
) then
12256 ("pragma% cannot be applied on non-remote procedure",
12260 L
:= Parameter_Specifications
(Parent
(Nm
));
12261 Process_Async_Pragma
;
12264 elsif Ekind
(Nm
) = E_Function
then
12266 ("pragma% cannot be applied to function", Arg1
);
12268 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12269 if Is_Record_Type
(Nm
) then
12271 -- A record type that is the Equivalent_Type for a remote
12272 -- access-to-subprogram type.
12274 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
12277 -- A non-expanded RAS type (distribution is not enabled)
12279 Decl
:= Declaration_Node
(Nm
);
12282 if Nkind
(Decl
) = N_Full_Type_Declaration
12283 and then Nkind
(Type_Definition
(Decl
)) =
12284 N_Access_Procedure_Definition
12286 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
12287 Process_Async_Pragma
;
12289 if Is_Asynchronous
(Nm
)
12290 and then Expander_Active
12291 and then Get_PCS_Name
/= Name_No_DSA
12293 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
12298 ("pragma% cannot reference access-to-function type",
12302 -- Only other possibility is Access-to-class-wide type
12304 elsif Is_Access_Type
(Nm
)
12305 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
12307 Check_First_Subtype
(Arg1
);
12308 Set_Is_Asynchronous
(Nm
);
12309 if Expander_Active
then
12310 RACW_Type_Is_Asynchronous
(Nm
);
12314 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12322 -- pragma Atomic (LOCAL_NAME);
12324 when Pragma_Atomic
=>
12325 Process_Atomic_Independent_Shared_Volatile
;
12327 -----------------------
12328 -- Atomic_Components --
12329 -----------------------
12331 -- pragma Atomic_Components (array_LOCAL_NAME);
12333 -- This processing is shared by Volatile_Components
12335 when Pragma_Atomic_Components
12336 | Pragma_Volatile_Components
12338 Atomic_Components
: declare
12345 Check_Ada_83_Warning
;
12346 Check_No_Identifiers
;
12347 Check_Arg_Count
(1);
12348 Check_Arg_Is_Local_Name
(Arg1
);
12349 E_Id
:= Get_Pragma_Arg
(Arg1
);
12351 if Etype
(E_Id
) = Any_Type
then
12355 E
:= Entity
(E_Id
);
12357 -- A pragma that applies to a Ghost entity becomes Ghost for the
12358 -- purposes of legality checks and removal of ignored Ghost code.
12360 Mark_Ghost_Pragma
(N
, E
);
12361 Check_Duplicate_Pragma
(E
);
12363 if Rep_Item_Too_Early
(E
, N
)
12365 Rep_Item_Too_Late
(E
, N
)
12370 D
:= Declaration_Node
(E
);
12373 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
12375 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
12376 and then Nkind
(D
) = N_Object_Declaration
12377 and then Nkind
(Object_Definition
(D
)) =
12378 N_Constrained_Array_Definition
)
12380 -- The flag is set on the object, or on the base type
12382 if Nkind
(D
) /= N_Object_Declaration
then
12383 E
:= Base_Type
(E
);
12386 -- Atomic implies both Independent and Volatile
12388 if Prag_Id
= Pragma_Atomic_Components
then
12389 Set_Has_Atomic_Components
(E
);
12390 Set_Has_Independent_Components
(E
);
12393 Set_Has_Volatile_Components
(E
);
12396 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
12398 end Atomic_Components
;
12400 --------------------
12401 -- Attach_Handler --
12402 --------------------
12404 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12406 when Pragma_Attach_Handler
=>
12407 Check_Ada_83_Warning
;
12408 Check_No_Identifiers
;
12409 Check_Arg_Count
(2);
12411 if No_Run_Time_Mode
then
12412 Error_Msg_CRT
("Attach_Handler pragma", N
);
12414 Check_Interrupt_Or_Attach_Handler
;
12416 -- The expression that designates the attribute may depend on a
12417 -- discriminant, and is therefore a per-object expression, to
12418 -- be expanded in the init proc. If expansion is enabled, then
12419 -- perform semantic checks on a copy only.
12424 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
12427 -- In Relaxed_RM_Semantics mode, we allow any static
12428 -- integer value, for compatibility with other compilers.
12430 if Relaxed_RM_Semantics
12431 and then Nkind
(Parg2
) = N_Integer_Literal
12433 Typ
:= Standard_Integer
;
12435 Typ
:= RTE
(RE_Interrupt_ID
);
12438 if Expander_Active
then
12439 Temp
:= New_Copy_Tree
(Parg2
);
12440 Set_Parent
(Temp
, N
);
12441 Preanalyze_And_Resolve
(Temp
, Typ
);
12444 Resolve
(Parg2
, Typ
);
12448 Process_Interrupt_Or_Attach_Handler
;
12451 --------------------
12452 -- C_Pass_By_Copy --
12453 --------------------
12455 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12457 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
12463 Check_Valid_Configuration_Pragma
;
12464 Check_Arg_Count
(1);
12465 Check_Optional_Identifier
(Arg1
, "max_size");
12467 Arg
:= Get_Pragma_Arg
(Arg1
);
12468 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
12470 Val
:= Expr_Value
(Arg
);
12474 ("maximum size for pragma% must be positive", Arg1
);
12476 elsif UI_Is_In_Int_Range
(Val
) then
12477 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
12479 -- If a giant value is given, Int'Last will do well enough.
12480 -- If sometime someone complains that a record larger than
12481 -- two gigabytes is not copied, we will worry about it then.
12484 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
12486 end C_Pass_By_Copy
;
12492 -- pragma Check ([Name =>] CHECK_KIND,
12493 -- [Check =>] Boolean_EXPRESSION
12494 -- [,[Message =>] String_EXPRESSION]);
12496 -- CHECK_KIND ::= IDENTIFIER |
12499 -- Invariant'Class |
12500 -- Type_Invariant'Class
12502 -- The identifiers Assertions and Statement_Assertions are not
12503 -- allowed, since they have special meaning for Check_Policy.
12505 -- WARNING: The code below manages Ghost regions. Return statements
12506 -- must be replaced by gotos which jump to the end of the code and
12507 -- restore the Ghost mode.
12509 when Pragma_Check
=> Check
: declare
12513 Mode
: Ghost_Mode_Type
;
12517 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12518 -- the mode now to ensure that any nodes generated during analysis
12519 -- and expansion are marked as Ghost.
12521 Set_Ghost_Mode
(N
, Mode
);
12524 Check_At_Least_N_Arguments
(2);
12525 Check_At_Most_N_Arguments
(3);
12526 Check_Optional_Identifier
(Arg1
, Name_Name
);
12527 Check_Optional_Identifier
(Arg2
, Name_Check
);
12529 if Arg_Count
= 3 then
12530 Check_Optional_Identifier
(Arg3
, Name_Message
);
12531 Str
:= Get_Pragma_Arg
(Arg3
);
12534 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
12535 Check_Arg_Is_Identifier
(Arg1
);
12536 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
12538 -- Check forbidden name Assertions or Statement_Assertions
12541 when Name_Assertions
=>
12543 ("""Assertions"" is not allowed as a check kind for "
12544 & "pragma%", Arg1
);
12546 when Name_Statement_Assertions
=>
12548 ("""Statement_Assertions"" is not allowed as a check kind "
12549 & "for pragma%", Arg1
);
12555 -- Check applicable policy. We skip this if Checked/Ignored status
12556 -- is already set (e.g. in the case of a pragma from an aspect).
12558 if Is_Checked
(N
) or else Is_Ignored
(N
) then
12561 -- For a non-source pragma that is a rewriting of another pragma,
12562 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12564 elsif Is_Rewrite_Substitution
(N
)
12565 and then Nkind
(Original_Node
(N
)) = N_Pragma
12566 and then Original_Node
(N
) /= N
12568 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12569 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12571 -- Otherwise query the applicable policy at this point
12574 case Check_Kind
(Cname
) is
12575 when Name_Ignore
=>
12576 Set_Is_Ignored
(N
, True);
12577 Set_Is_Checked
(N
, False);
12580 Set_Is_Ignored
(N
, False);
12581 Set_Is_Checked
(N
, True);
12583 -- For disable, rewrite pragma as null statement and skip
12584 -- rest of the analysis of the pragma.
12586 when Name_Disable
=>
12587 Rewrite
(N
, Make_Null_Statement
(Loc
));
12591 -- No other possibilities
12594 raise Program_Error
;
12598 -- If check kind was not Disable, then continue pragma analysis
12600 Expr
:= Get_Pragma_Arg
(Arg2
);
12602 -- Deal with SCO generation
12606 -- Nothing to do for predicates as the checks occur in the
12607 -- client units. The SCO for the aspect in the declaration
12608 -- unit is conservatively always enabled.
12610 when Name_Predicate
=>
12613 -- Otherwise mark aspect/pragma SCO as enabled
12616 if Is_Checked
(N
) and then not Split_PPC
(N
) then
12617 Set_SCO_Pragma_Enabled
(Loc
);
12621 -- Deal with analyzing the string argument
12623 if Arg_Count
= 3 then
12625 -- If checks are not on we don't want any expansion (since
12626 -- such expansion would not get properly deleted) but
12627 -- we do want to analyze (to get proper references).
12628 -- The Preanalyze_And_Resolve routine does just what we want
12630 if Is_Ignored
(N
) then
12631 Preanalyze_And_Resolve
(Str
, Standard_String
);
12633 -- Otherwise we need a proper analysis and expansion
12636 Analyze_And_Resolve
(Str
, Standard_String
);
12640 -- Now you might think we could just do the same with the Boolean
12641 -- expression if checks are off (and expansion is on) and then
12642 -- rewrite the check as a null statement. This would work but we
12643 -- would lose the useful warnings about an assertion being bound
12644 -- to fail even if assertions are turned off.
12646 -- So instead we wrap the boolean expression in an if statement
12647 -- that looks like:
12649 -- if False and then condition then
12653 -- The reason we do this rewriting during semantic analysis rather
12654 -- than as part of normal expansion is that we cannot analyze and
12655 -- expand the code for the boolean expression directly, or it may
12656 -- cause insertion of actions that would escape the attempt to
12657 -- suppress the check code.
12659 -- Note that the Sloc for the if statement corresponds to the
12660 -- argument condition, not the pragma itself. The reason for
12661 -- this is that we may generate a warning if the condition is
12662 -- False at compile time, and we do not want to delete this
12663 -- warning when we delete the if statement.
12665 if Expander_Active
and Is_Ignored
(N
) then
12666 Eloc
:= Sloc
(Expr
);
12669 Make_If_Statement
(Eloc
,
12671 Make_And_Then
(Eloc
,
12672 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
12673 Right_Opnd
=> Expr
),
12674 Then_Statements
=> New_List
(
12675 Make_Null_Statement
(Eloc
))));
12677 -- Now go ahead and analyze the if statement
12679 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12681 -- One rather special treatment. If we are now in Eliminated
12682 -- overflow mode, then suppress overflow checking since we do
12683 -- not want to drag in the bignum stuff if we are in Ignore
12684 -- mode anyway. This is particularly important if we are using
12685 -- a configurable run time that does not support bignum ops.
12687 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
12689 Svo
: constant Boolean :=
12690 Scope_Suppress
.Suppress
(Overflow_Check
);
12692 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
12693 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
12695 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
12696 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
12699 -- Not that special case
12705 -- All done with this check
12707 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12709 -- Check is active or expansion not active. In these cases we can
12710 -- just go ahead and analyze the boolean with no worries.
12713 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12714 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12715 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12718 Restore_Ghost_Mode
(Mode
);
12721 --------------------------
12722 -- Check_Float_Overflow --
12723 --------------------------
12725 -- pragma Check_Float_Overflow;
12727 when Pragma_Check_Float_Overflow
=>
12729 Check_Valid_Configuration_Pragma
;
12730 Check_Arg_Count
(0);
12731 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
12737 -- pragma Check_Name (check_IDENTIFIER);
12739 when Pragma_Check_Name
=>
12741 Check_No_Identifiers
;
12742 Check_Valid_Configuration_Pragma
;
12743 Check_Arg_Count
(1);
12744 Check_Arg_Is_Identifier
(Arg1
);
12747 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12750 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12751 if Check_Names
.Table
(J
) = Nam
then
12756 Check_Names
.Append
(Nam
);
12763 -- This is the old style syntax, which is still allowed in all modes:
12765 -- pragma Check_Policy ([Name =>] CHECK_KIND
12766 -- [Policy =>] POLICY_IDENTIFIER);
12768 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12770 -- CHECK_KIND ::= IDENTIFIER |
12773 -- Type_Invariant'Class |
12776 -- This is the new style syntax, compatible with Assertion_Policy
12777 -- and also allowed in all modes.
12779 -- Pragma Check_Policy (
12780 -- CHECK_KIND => POLICY_IDENTIFIER
12781 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12783 -- Note: the identifiers Name and Policy are not allowed as
12784 -- Check_Kind values. This avoids ambiguities between the old and
12785 -- new form syntax.
12787 when Pragma_Check_Policy
=> Check_Policy
: declare
12792 Check_At_Least_N_Arguments
(1);
12794 -- A Check_Policy pragma can appear either as a configuration
12795 -- pragma, or in a declarative part or a package spec (see RM
12796 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12797 -- followed for Check_Policy).
12799 if not Is_Configuration_Pragma
then
12800 Check_Is_In_Decl_Part_Or_Package_Spec
;
12803 -- Figure out if we have the old or new syntax. We have the
12804 -- old syntax if the first argument has no identifier, or the
12805 -- identifier is Name.
12807 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12808 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12812 Check_Arg_Count
(2);
12813 Check_Optional_Identifier
(Arg1
, Name_Name
);
12814 Kind
:= Get_Pragma_Arg
(Arg1
);
12815 Rewrite_Assertion_Kind
(Kind
,
12816 From_Policy
=> Comes_From_Source
(N
));
12817 Check_Arg_Is_Identifier
(Arg1
);
12819 -- Check forbidden check kind
12821 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12822 Error_Msg_Name_2
:= Chars
(Kind
);
12824 ("pragma% does not allow% as check name", Arg1
);
12829 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12830 Check_Arg_Is_One_Of
12832 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12834 -- And chain pragma on the Check_Policy_List for search
12836 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12837 Opt
.Check_Policy_List
:= N
;
12839 -- For the new syntax, what we do is to convert each argument to
12840 -- an old syntax equivalent. We do that because we want to chain
12841 -- old style Check_Policy pragmas for the search (we don't want
12842 -- to have to deal with multiple arguments in the search).
12853 while Present
(Arg
) loop
12854 LocP
:= Sloc
(Arg
);
12855 Argx
:= Get_Pragma_Arg
(Arg
);
12857 -- Kind must be specified
12859 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12860 or else Chars
(Arg
) = No_Name
12863 ("missing assertion kind for pragma%", Arg
);
12866 -- Construct equivalent old form syntax Check_Policy
12867 -- pragma and insert it to get remaining checks.
12871 Chars
=> Name_Check_Policy
,
12872 Pragma_Argument_Associations
=> New_List
(
12873 Make_Pragma_Argument_Association
(LocP
,
12875 Make_Identifier
(LocP
, Chars
(Arg
))),
12876 Make_Pragma_Argument_Association
(Sloc
(Argx
),
12877 Expression
=> Argx
)));
12881 -- For a configuration pragma, insert old form in
12882 -- the corresponding file.
12884 if Is_Configuration_Pragma
then
12885 Insert_After
(N
, New_P
);
12889 Insert_Action
(N
, New_P
);
12893 -- Rewrite original Check_Policy pragma to null, since we
12894 -- have converted it into a series of old syntax pragmas.
12896 Rewrite
(N
, Make_Null_Statement
(Loc
));
12906 -- pragma Comment (static_string_EXPRESSION)
12908 -- Processing for pragma Comment shares the circuitry for pragma
12909 -- Ident. The only differences are that Ident enforces a limit of 31
12910 -- characters on its argument, and also enforces limitations on
12911 -- placement for DEC compatibility. Pragma Comment shares neither of
12912 -- these restrictions.
12914 -------------------
12915 -- Common_Object --
12916 -------------------
12918 -- pragma Common_Object (
12919 -- [Internal =>] LOCAL_NAME
12920 -- [, [External =>] EXTERNAL_SYMBOL]
12921 -- [, [Size =>] EXTERNAL_SYMBOL]);
12923 -- Processing for this pragma is shared with Psect_Object
12925 ------------------------
12926 -- Compile_Time_Error --
12927 ------------------------
12929 -- pragma Compile_Time_Error
12930 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12932 when Pragma_Compile_Time_Error
=>
12934 Process_Compile_Time_Warning_Or_Error
;
12936 --------------------------
12937 -- Compile_Time_Warning --
12938 --------------------------
12940 -- pragma Compile_Time_Warning
12941 -- (boolean_EXPRESSION, static_string_EXPRESSION);
12943 when Pragma_Compile_Time_Warning
=>
12945 Process_Compile_Time_Warning_Or_Error
;
12947 ---------------------------
12948 -- Compiler_Unit_Warning --
12949 ---------------------------
12951 -- pragma Compiler_Unit_Warning;
12955 -- Originally, we had only pragma Compiler_Unit, and it resulted in
12956 -- errors not warnings. This means that we had introduced a big extra
12957 -- inertia to compiler changes, since even if we implemented a new
12958 -- feature, and even if all versions to be used for bootstrapping
12959 -- implemented this new feature, we could not use it, since old
12960 -- compilers would give errors for using this feature in units
12961 -- having Compiler_Unit pragmas.
12963 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
12964 -- problem. We no longer have any units mentioning Compiler_Unit,
12965 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
12966 -- and thus generates a warning which can be ignored. So that deals
12967 -- with the problem of old compilers not implementing the newer form
12970 -- Newer compilers recognize the new pragma, but generate warning
12971 -- messages instead of errors, which again can be ignored in the
12972 -- case of an old compiler which implements a wanted new feature
12973 -- but at the time felt like warning about it for older compilers.
12975 -- We retain Compiler_Unit so that new compilers can be used to build
12976 -- older run-times that use this pragma. That's an unusual case, but
12977 -- it's easy enough to handle, so why not?
12979 when Pragma_Compiler_Unit
12980 | Pragma_Compiler_Unit_Warning
12983 Check_Arg_Count
(0);
12985 -- Only recognized in main unit
12987 if Current_Sem_Unit
= Main_Unit
then
12988 Compiler_Unit
:= True;
12991 -----------------------------
12992 -- Complete_Representation --
12993 -----------------------------
12995 -- pragma Complete_Representation;
12997 when Pragma_Complete_Representation
=>
12999 Check_Arg_Count
(0);
13001 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13003 ("pragma & must appear within record representation clause");
13006 ----------------------------
13007 -- Complex_Representation --
13008 ----------------------------
13010 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13012 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13019 Check_Arg_Count
(1);
13020 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13021 Check_Arg_Is_Local_Name
(Arg1
);
13022 E_Id
:= Get_Pragma_Arg
(Arg1
);
13024 if Etype
(E_Id
) = Any_Type
then
13028 E
:= Entity
(E_Id
);
13030 if not Is_Record_Type
(E
) then
13032 ("argument for pragma% must be record type", Arg1
);
13035 Ent
:= First_Entity
(E
);
13038 or else No
(Next_Entity
(Ent
))
13039 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13040 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13041 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13044 ("record for pragma% must have two fields of the same "
13045 & "floating-point type", Arg1
);
13048 Set_Has_Complex_Representation
(Base_Type
(E
));
13050 -- We need to treat the type has having a non-standard
13051 -- representation, for back-end purposes, even though in
13052 -- general a complex will have the default representation
13053 -- of a record with two real components.
13055 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13057 end Complex_Representation
;
13059 -------------------------
13060 -- Component_Alignment --
13061 -------------------------
13063 -- pragma Component_Alignment (
13064 -- [Form =>] ALIGNMENT_CHOICE
13065 -- [, [Name =>] type_LOCAL_NAME]);
13067 -- ALIGNMENT_CHOICE ::=
13069 -- | Component_Size_4
13073 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13074 Args
: Args_List
(1 .. 2);
13075 Names
: constant Name_List
(1 .. 2) := (
13079 Form
: Node_Id
renames Args
(1);
13080 Name
: Node_Id
renames Args
(2);
13082 Atype
: Component_Alignment_Kind
;
13087 Gather_Associations
(Names
, Args
);
13090 Error_Pragma
("missing Form argument for pragma%");
13093 Check_Arg_Is_Identifier
(Form
);
13095 -- Get proper alignment, note that Default = Component_Size on all
13096 -- machines we have so far, and we want to set this value rather
13097 -- than the default value to indicate that it has been explicitly
13098 -- set (and thus will not get overridden by the default component
13099 -- alignment for the current scope)
13101 if Chars
(Form
) = Name_Component_Size
then
13102 Atype
:= Calign_Component_Size
;
13104 elsif Chars
(Form
) = Name_Component_Size_4
then
13105 Atype
:= Calign_Component_Size_4
;
13107 elsif Chars
(Form
) = Name_Default
then
13108 Atype
:= Calign_Component_Size
;
13110 elsif Chars
(Form
) = Name_Storage_Unit
then
13111 Atype
:= Calign_Storage_Unit
;
13115 ("invalid Form parameter for pragma%", Form
);
13118 -- The pragma appears in a configuration file
13120 if No
(Parent
(N
)) then
13121 Check_Valid_Configuration_Pragma
;
13123 -- Capture the component alignment in a global variable when
13124 -- the pragma appears in a configuration file. Note that the
13125 -- scope stack is empty at this point and cannot be used to
13126 -- store the alignment value.
13128 Configuration_Component_Alignment
:= Atype
;
13130 -- Case with no name, supplied, affects scope table entry
13132 elsif No
(Name
) then
13134 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13136 -- Case of name supplied
13139 Check_Arg_Is_Local_Name
(Name
);
13141 Typ
:= Entity
(Name
);
13144 or else Rep_Item_Too_Early
(Typ
, N
)
13148 Typ
:= Underlying_Type
(Typ
);
13151 if not Is_Record_Type
(Typ
)
13152 and then not Is_Array_Type
(Typ
)
13155 ("Name parameter of pragma% must identify record or "
13156 & "array type", Name
);
13159 -- An explicit Component_Alignment pragma overrides an
13160 -- implicit pragma Pack, but not an explicit one.
13162 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13163 Set_Is_Packed
(Base_Type
(Typ
), False);
13164 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13167 end Component_AlignmentP
;
13169 --------------------------------
13170 -- Constant_After_Elaboration --
13171 --------------------------------
13173 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13175 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13177 Obj_Decl
: Node_Id
;
13178 Obj_Id
: Entity_Id
;
13182 Check_No_Identifiers
;
13183 Check_At_Most_N_Arguments
(1);
13185 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13187 -- Object declaration
13189 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
13192 -- Otherwise the pragma is associated with an illegal construct
13199 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13201 -- The object declaration must be a library-level variable which
13202 -- is either explicitly initialized or obtains a value during the
13203 -- elaboration of a package body (SPARK RM 3.3.1).
13205 if Ekind
(Obj_Id
) = E_Variable
then
13206 if not Is_Library_Level_Entity
(Obj_Id
) then
13208 ("pragma % must apply to a library level variable");
13212 -- Otherwise the pragma applies to a constant, which is illegal
13215 Error_Pragma
("pragma % must apply to a variable declaration");
13219 -- A pragma that applies to a Ghost entity becomes Ghost for the
13220 -- purposes of legality checks and removal of ignored Ghost code.
13222 Mark_Ghost_Pragma
(N
, Obj_Id
);
13224 -- Chain the pragma on the contract for completeness
13226 Add_Contract_Item
(N
, Obj_Id
);
13228 -- Analyze the Boolean expression (if any)
13230 if Present
(Arg1
) then
13231 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13233 end Constant_After_Elaboration
;
13235 --------------------
13236 -- Contract_Cases --
13237 --------------------
13239 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13241 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13243 -- CASE_GUARD ::= boolean_EXPRESSION | others
13245 -- CONSEQUENCE ::= boolean_EXPRESSION
13247 -- Characteristics:
13249 -- * Analysis - The annotation undergoes initial checks to verify
13250 -- the legal placement and context. Secondary checks preanalyze the
13253 -- Analyze_Contract_Cases_In_Decl_Part
13255 -- * Expansion - The annotation is expanded during the expansion of
13256 -- the related subprogram [body] contract as performed in:
13258 -- Expand_Subprogram_Contract
13260 -- * Template - The annotation utilizes the generic template of the
13261 -- related subprogram [body] when it is:
13263 -- aspect on subprogram declaration
13264 -- aspect on stand alone subprogram body
13265 -- pragma on stand alone subprogram body
13267 -- The annotation must prepare its own template when it is:
13269 -- pragma on subprogram declaration
13271 -- * Globals - Capture of global references must occur after full
13274 -- * Instance - The annotation is instantiated automatically when
13275 -- the related generic subprogram [body] is instantiated except for
13276 -- the "pragma on subprogram declaration" case. In that scenario
13277 -- the annotation must instantiate itself.
13279 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13280 Spec_Id
: Entity_Id
;
13281 Subp_Decl
: Node_Id
;
13285 Check_No_Identifiers
;
13286 Check_Arg_Count
(1);
13288 -- Ensure the proper placement of the pragma. Contract_Cases must
13289 -- be associated with a subprogram declaration or a body that acts
13293 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13297 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13300 -- Generic subprogram
13302 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13305 -- Body acts as spec
13307 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13308 and then No
(Corresponding_Spec
(Subp_Decl
))
13312 -- Body stub acts as spec
13314 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13315 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13321 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13329 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13331 -- A pragma that applies to a Ghost entity becomes Ghost for the
13332 -- purposes of legality checks and removal of ignored Ghost code.
13334 Mark_Ghost_Pragma
(N
, Spec_Id
);
13335 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13337 -- Chain the pragma on the contract for further processing by
13338 -- Analyze_Contract_Cases_In_Decl_Part.
13340 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13342 -- Fully analyze the pragma when it appears inside an entry
13343 -- or subprogram body because it cannot benefit from forward
13346 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13348 N_Subprogram_Body_Stub
)
13350 -- The legality checks of pragma Contract_Cases are affected by
13351 -- the SPARK mode in effect and the volatility of the context.
13352 -- Analyze all pragmas in a specific order.
13354 Analyze_If_Present
(Pragma_SPARK_Mode
);
13355 Analyze_If_Present
(Pragma_Volatile_Function
);
13356 Analyze_Contract_Cases_In_Decl_Part
(N
);
13358 end Contract_Cases
;
13364 -- pragma Controlled (first_subtype_LOCAL_NAME);
13366 when Pragma_Controlled
=> Controlled
: declare
13370 Check_No_Identifiers
;
13371 Check_Arg_Count
(1);
13372 Check_Arg_Is_Local_Name
(Arg1
);
13373 Arg
:= Get_Pragma_Arg
(Arg1
);
13375 if not Is_Entity_Name
(Arg
)
13376 or else not Is_Access_Type
(Entity
(Arg
))
13378 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
13380 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
13388 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13389 -- [Entity =>] LOCAL_NAME);
13391 when Pragma_Convention
=> Convention
: declare
13394 pragma Warnings
(Off
, C
);
13395 pragma Warnings
(Off
, E
);
13398 Check_Arg_Order
((Name_Convention
, Name_Entity
));
13399 Check_Ada_83_Warning
;
13400 Check_Arg_Count
(2);
13401 Process_Convention
(C
, E
);
13403 -- A pragma that applies to a Ghost entity becomes Ghost for the
13404 -- purposes of legality checks and removal of ignored Ghost code.
13406 Mark_Ghost_Pragma
(N
, E
);
13409 ---------------------------
13410 -- Convention_Identifier --
13411 ---------------------------
13413 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13414 -- [Convention =>] convention_IDENTIFIER);
13416 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
13422 Check_Arg_Order
((Name_Name
, Name_Convention
));
13423 Check_Arg_Count
(2);
13424 Check_Optional_Identifier
(Arg1
, Name_Name
);
13425 Check_Optional_Identifier
(Arg2
, Name_Convention
);
13426 Check_Arg_Is_Identifier
(Arg1
);
13427 Check_Arg_Is_Identifier
(Arg2
);
13428 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
13429 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
13431 if Is_Convention_Name
(Cname
) then
13432 Record_Convention_Identifier
13433 (Idnam
, Get_Convention_Id
(Cname
));
13436 ("second arg for % pragma must be convention", Arg2
);
13438 end Convention_Identifier
;
13444 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13446 when Pragma_CPP_Class
=>
13449 if Warn_On_Obsolescent_Feature
then
13451 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13452 & "effect; replace it by pragma import?j?", N
);
13455 Check_Arg_Count
(1);
13459 Chars
=> Name_Import
,
13460 Pragma_Argument_Associations
=> New_List
(
13461 Make_Pragma_Argument_Association
(Loc
,
13462 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
13463 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
13466 ---------------------
13467 -- CPP_Constructor --
13468 ---------------------
13470 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13471 -- [, [External_Name =>] static_string_EXPRESSION ]
13472 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13474 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
13477 Def_Id
: Entity_Id
;
13478 Tag_Typ
: Entity_Id
;
13482 Check_At_Least_N_Arguments
(1);
13483 Check_At_Most_N_Arguments
(3);
13484 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13485 Check_Arg_Is_Local_Name
(Arg1
);
13487 Id
:= Get_Pragma_Arg
(Arg1
);
13488 Find_Program_Unit_Name
(Id
);
13490 -- If we did not find the name, we are done
13492 if Etype
(Id
) = Any_Type
then
13496 Def_Id
:= Entity
(Id
);
13498 -- Check if already defined as constructor
13500 if Is_Constructor
(Def_Id
) then
13502 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
13506 if Ekind
(Def_Id
) = E_Function
13507 and then (Is_CPP_Class
(Etype
(Def_Id
))
13508 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
13510 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
13512 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
13514 ("'C'P'P constructor must be defined in the scope of "
13515 & "its returned type", Arg1
);
13518 if Arg_Count
>= 2 then
13519 Set_Imported
(Def_Id
);
13520 Set_Is_Public
(Def_Id
);
13521 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
13524 Set_Has_Completion
(Def_Id
);
13525 Set_Is_Constructor
(Def_Id
);
13526 Set_Convention
(Def_Id
, Convention_CPP
);
13528 -- Imported C++ constructors are not dispatching primitives
13529 -- because in C++ they don't have a dispatch table slot.
13530 -- However, in Ada the constructor has the profile of a
13531 -- function that returns a tagged type and therefore it has
13532 -- been treated as a primitive operation during semantic
13533 -- analysis. We now remove it from the list of primitive
13534 -- operations of the type.
13536 if Is_Tagged_Type
(Etype
(Def_Id
))
13537 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
13538 and then Is_Dispatching_Operation
(Def_Id
)
13540 Tag_Typ
:= Etype
(Def_Id
);
13542 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
13543 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
13547 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
13548 Set_Is_Dispatching_Operation
(Def_Id
, False);
13551 -- For backward compatibility, if the constructor returns a
13552 -- class wide type, and we internally change the return type to
13553 -- the corresponding root type.
13555 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
13556 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
13560 ("pragma% requires function returning a 'C'P'P_Class type",
13563 end CPP_Constructor
;
13569 when Pragma_CPP_Virtual
=>
13572 if Warn_On_Obsolescent_Feature
then
13574 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13582 when Pragma_CPP_Vtable
=>
13585 if Warn_On_Obsolescent_Feature
then
13587 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13595 -- pragma CPU (EXPRESSION);
13597 when Pragma_CPU
=> CPU
: declare
13598 P
: constant Node_Id
:= Parent
(N
);
13604 Check_No_Identifiers
;
13605 Check_Arg_Count
(1);
13609 if Nkind
(P
) = N_Subprogram_Body
then
13610 Check_In_Main_Program
;
13612 Arg
:= Get_Pragma_Arg
(Arg1
);
13613 Analyze_And_Resolve
(Arg
, Any_Integer
);
13615 Ent
:= Defining_Unit_Name
(Specification
(P
));
13617 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
13618 Ent
:= Defining_Identifier
(Ent
);
13623 if not Is_OK_Static_Expression
(Arg
) then
13624 Flag_Non_Static_Expr
13625 ("main subprogram affinity is not static!", Arg
);
13628 -- If constraint error, then we already signalled an error
13630 elsif Raises_Constraint_Error
(Arg
) then
13633 -- Otherwise check in range
13637 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
13638 -- This is the entity System.Multiprocessors.CPU_Range;
13640 Val
: constant Uint
:= Expr_Value
(Arg
);
13643 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
13645 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
13648 ("main subprogram CPU is out of range", Arg1
);
13654 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
13658 elsif Nkind
(P
) = N_Task_Definition
then
13659 Arg
:= Get_Pragma_Arg
(Arg1
);
13660 Ent
:= Defining_Identifier
(Parent
(P
));
13662 -- The expression must be analyzed in the special manner
13663 -- described in "Handling of Default and Per-Object
13664 -- Expressions" in sem.ads.
13666 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
13668 -- Anything else is incorrect
13674 -- Check duplicate pragma before we chain the pragma in the Rep
13675 -- Item chain of Ent.
13677 Check_Duplicate_Pragma
(Ent
);
13678 Record_Rep_Item
(Ent
, N
);
13685 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13687 when Pragma_Debug
=> Debug
: declare
13694 -- The condition for executing the call is that the expander
13695 -- is active and that we are not ignoring this debug pragma.
13700 (Expander_Active
and then not Is_Ignored
(N
)),
13703 if not Is_Ignored
(N
) then
13704 Set_SCO_Pragma_Enabled
(Loc
);
13707 if Arg_Count
= 2 then
13709 Make_And_Then
(Loc
,
13710 Left_Opnd
=> Relocate_Node
(Cond
),
13711 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
13712 Call
:= Get_Pragma_Arg
(Arg2
);
13714 Call
:= Get_Pragma_Arg
(Arg1
);
13718 N_Indexed_Component
,
13722 N_Selected_Component
)
13724 -- If this pragma Debug comes from source, its argument was
13725 -- parsed as a name form (which is syntactically identical).
13726 -- In a generic context a parameterless call will be left as
13727 -- an expanded name (if global) or selected_component if local.
13728 -- Change it to a procedure call statement now.
13730 Change_Name_To_Procedure_Call_Statement
(Call
);
13732 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
13734 -- Already in the form of a procedure call statement: nothing
13735 -- to do (could happen in case of an internally generated
13741 -- All other cases: diagnose error
13744 ("argument of pragma ""Debug"" is not procedure call",
13749 -- Rewrite into a conditional with an appropriate condition. We
13750 -- wrap the procedure call in a block so that overhead from e.g.
13751 -- use of the secondary stack does not generate execution overhead
13752 -- for suppressed conditions.
13754 -- Normally the analysis that follows will freeze the subprogram
13755 -- being called. However, if the call is to a null procedure,
13756 -- we want to freeze it before creating the block, because the
13757 -- analysis that follows may be done with expansion disabled, in
13758 -- which case the body will not be generated, leading to spurious
13761 if Nkind
(Call
) = N_Procedure_Call_Statement
13762 and then Is_Entity_Name
(Name
(Call
))
13764 Analyze
(Name
(Call
));
13765 Freeze_Before
(N
, Entity
(Name
(Call
)));
13769 Make_Implicit_If_Statement
(N
,
13771 Then_Statements
=> New_List
(
13772 Make_Block_Statement
(Loc
,
13773 Handled_Statement_Sequence
=>
13774 Make_Handled_Sequence_Of_Statements
(Loc
,
13775 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13778 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13779 -- after analysis of the normally rewritten node, to capture all
13780 -- references to entities, which avoids issuing wrong warnings
13781 -- about unused entities.
13783 if GNATprove_Mode
then
13784 Rewrite
(N
, Make_Null_Statement
(Loc
));
13792 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13794 when Pragma_Debug_Policy
=>
13796 Check_Arg_Count
(1);
13797 Check_No_Identifiers
;
13798 Check_Arg_Is_Identifier
(Arg1
);
13800 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13801 -- rewrite it that way, and let the rest of the checking come
13802 -- from analyzing the rewritten pragma.
13806 Chars
=> Name_Check_Policy
,
13807 Pragma_Argument_Associations
=> New_List
(
13808 Make_Pragma_Argument_Association
(Loc
,
13809 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
13811 Make_Pragma_Argument_Association
(Loc
,
13812 Expression
=> Get_Pragma_Arg
(Arg1
)))));
13815 -------------------------------
13816 -- Default_Initial_Condition --
13817 -------------------------------
13819 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
13821 when Pragma_Default_Initial_Condition
=> DIC
: declare
13828 Check_No_Identifiers
;
13829 Check_At_Most_N_Arguments
(1);
13832 while Present
(Stmt
) loop
13834 -- Skip prior pragmas, but check for duplicates
13836 if Nkind
(Stmt
) = N_Pragma
then
13837 if Pragma_Name
(Stmt
) = Pname
then
13838 Error_Msg_Name_1
:= Pname
;
13839 Error_Msg_Sloc
:= Sloc
(Stmt
);
13840 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
13843 -- Skip internally generated code. Note that derived type
13844 -- declarations of untagged types with discriminants are
13845 -- rewritten as private type declarations.
13847 elsif not Comes_From_Source
(Stmt
)
13848 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
13852 -- The associated private type [extension] has been found, stop
13855 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
13856 N_Private_Type_Declaration
)
13858 Typ
:= Defining_Entity
(Stmt
);
13861 -- The pragma does not apply to a legal construct, issue an
13862 -- error and stop the analysis.
13869 Stmt
:= Prev
(Stmt
);
13872 -- A pragma that applies to a Ghost entity becomes Ghost for the
13873 -- purposes of legality checks and removal of ignored Ghost code.
13875 Mark_Ghost_Pragma
(N
, Typ
);
13877 -- The pragma signals that the type defines its own DIC assertion
13880 Set_Has_Own_DIC
(Typ
);
13882 -- Chain the pragma on the rep item chain for further processing
13884 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13886 -- Create the declaration of the procedure which verifies the
13887 -- assertion expression of pragma DIC at runtime.
13889 Build_DIC_Procedure_Declaration
(Typ
);
13892 ----------------------------------
13893 -- Default_Scalar_Storage_Order --
13894 ----------------------------------
13896 -- pragma Default_Scalar_Storage_Order
13897 -- (High_Order_First | Low_Order_First);
13899 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
13900 Default
: Character;
13904 Check_Arg_Count
(1);
13906 -- Default_Scalar_Storage_Order can appear as a configuration
13907 -- pragma, or in a declarative part of a package spec.
13909 if not Is_Configuration_Pragma
then
13910 Check_Is_In_Decl_Part_Or_Package_Spec
;
13913 Check_No_Identifiers
;
13914 Check_Arg_Is_One_Of
13915 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
13916 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13917 Default
:= Fold_Upper
(Name_Buffer
(1));
13919 if not Support_Nondefault_SSO_On_Target
13920 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
13922 if Warn_On_Unrecognized_Pragma
then
13924 ("non-default Scalar_Storage_Order not supported "
13925 & "on target?g?", N
);
13927 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
13930 -- Here set the specified default
13933 Opt
.Default_SSO
:= Default
;
13937 --------------------------
13938 -- Default_Storage_Pool --
13939 --------------------------
13941 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13943 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
13948 Check_Arg_Count
(1);
13950 -- Default_Storage_Pool can appear as a configuration pragma, or
13951 -- in a declarative part of a package spec.
13953 if not Is_Configuration_Pragma
then
13954 Check_Is_In_Decl_Part_Or_Package_Spec
;
13957 if From_Aspect_Specification
(N
) then
13959 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
13961 if not In_Open_Scopes
(E
) then
13963 ("aspect must apply to package or subprogram", N
);
13968 if Present
(Arg1
) then
13969 Pool
:= Get_Pragma_Arg
(Arg1
);
13971 -- Case of Default_Storage_Pool (null);
13973 if Nkind
(Pool
) = N_Null
then
13976 -- This is an odd case, this is not really an expression,
13977 -- so we don't have a type for it. So just set the type to
13980 Set_Etype
(Pool
, Empty
);
13982 -- Case of Default_Storage_Pool (storage_pool_NAME);
13985 -- If it's a configuration pragma, then the only allowed
13986 -- argument is "null".
13988 if Is_Configuration_Pragma
then
13989 Error_Pragma_Arg
("NULL expected", Arg1
);
13992 -- The expected type for a non-"null" argument is
13993 -- Root_Storage_Pool'Class, and the pool must be a variable.
13995 Analyze_And_Resolve
13996 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13998 if Is_Variable
(Pool
) then
14000 -- A pragma that applies to a Ghost entity becomes Ghost
14001 -- for the purposes of legality checks and removal of
14002 -- ignored Ghost code.
14004 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14008 ("default storage pool must be a variable", Arg1
);
14012 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14013 -- access type will use this information to set the appropriate
14014 -- attributes of the access type.
14016 Default_Pool
:= Pool
;
14018 end Default_Storage_Pool
;
14024 -- pragma Depends (DEPENDENCY_RELATION);
14026 -- DEPENDENCY_RELATION ::=
14028 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14030 -- DEPENDENCY_CLAUSE ::=
14031 -- OUTPUT_LIST =>[+] INPUT_LIST
14032 -- | NULL_DEPENDENCY_CLAUSE
14034 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14036 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14038 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14040 -- OUTPUT ::= NAME | FUNCTION_RESULT
14043 -- where FUNCTION_RESULT is a function Result attribute_reference
14045 -- Characteristics:
14047 -- * Analysis - The annotation undergoes initial checks to verify
14048 -- the legal placement and context. Secondary checks fully analyze
14049 -- the dependency clauses in:
14051 -- Analyze_Depends_In_Decl_Part
14053 -- * Expansion - None.
14055 -- * Template - The annotation utilizes the generic template of the
14056 -- related subprogram [body] when it is:
14058 -- aspect on subprogram declaration
14059 -- aspect on stand alone subprogram body
14060 -- pragma on stand alone subprogram body
14062 -- The annotation must prepare its own template when it is:
14064 -- pragma on subprogram declaration
14066 -- * Globals - Capture of global references must occur after full
14069 -- * Instance - The annotation is instantiated automatically when
14070 -- the related generic subprogram [body] is instantiated except for
14071 -- the "pragma on subprogram declaration" case. In that scenario
14072 -- the annotation must instantiate itself.
14074 when Pragma_Depends
=> Depends
: declare
14076 Spec_Id
: Entity_Id
;
14077 Subp_Decl
: Node_Id
;
14080 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14084 -- Chain the pragma on the contract for further processing by
14085 -- Analyze_Depends_In_Decl_Part.
14087 Add_Contract_Item
(N
, Spec_Id
);
14089 -- Fully analyze the pragma when it appears inside an entry
14090 -- or subprogram body because it cannot benefit from forward
14093 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14095 N_Subprogram_Body_Stub
)
14097 -- The legality checks of pragmas Depends and Global are
14098 -- affected by the SPARK mode in effect and the volatility
14099 -- of the context. In addition these two pragmas are subject
14100 -- to an inherent order:
14105 -- Analyze all these pragmas in the order outlined above
14107 Analyze_If_Present
(Pragma_SPARK_Mode
);
14108 Analyze_If_Present
(Pragma_Volatile_Function
);
14109 Analyze_If_Present
(Pragma_Global
);
14110 Analyze_Depends_In_Decl_Part
(N
);
14115 ---------------------
14116 -- Detect_Blocking --
14117 ---------------------
14119 -- pragma Detect_Blocking;
14121 when Pragma_Detect_Blocking
=>
14123 Check_Arg_Count
(0);
14124 Check_Valid_Configuration_Pragma
;
14125 Detect_Blocking
:= True;
14127 ------------------------------------
14128 -- Disable_Atomic_Synchronization --
14129 ------------------------------------
14131 -- pragma Disable_Atomic_Synchronization [(Entity)];
14133 when Pragma_Disable_Atomic_Synchronization
=>
14135 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14137 -------------------
14138 -- Discard_Names --
14139 -------------------
14141 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14143 when Pragma_Discard_Names
=> Discard_Names
: declare
14148 Check_Ada_83_Warning
;
14150 -- Deal with configuration pragma case
14152 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14153 Global_Discard_Names
:= True;
14156 -- Otherwise, check correct appropriate context
14159 Check_Is_In_Decl_Part_Or_Package_Spec
;
14161 if Arg_Count
= 0 then
14163 -- If there is no parameter, then from now on this pragma
14164 -- applies to any enumeration, exception or tagged type
14165 -- defined in the current declarative part, and recursively
14166 -- to any nested scope.
14168 Set_Discard_Names
(Current_Scope
);
14172 Check_Arg_Count
(1);
14173 Check_Optional_Identifier
(Arg1
, Name_On
);
14174 Check_Arg_Is_Local_Name
(Arg1
);
14176 E_Id
:= Get_Pragma_Arg
(Arg1
);
14178 if Etype
(E_Id
) = Any_Type
then
14181 E
:= Entity
(E_Id
);
14184 -- A pragma that applies to a Ghost entity becomes Ghost for
14185 -- the purposes of legality checks and removal of ignored
14188 Mark_Ghost_Pragma
(N
, E
);
14190 if (Is_First_Subtype
(E
)
14192 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14193 or else Ekind
(E
) = E_Exception
14195 Set_Discard_Names
(E
);
14196 Record_Rep_Item
(E
, N
);
14200 ("inappropriate entity for pragma%", Arg1
);
14206 ------------------------
14207 -- Dispatching_Domain --
14208 ------------------------
14210 -- pragma Dispatching_Domain (EXPRESSION);
14212 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14213 P
: constant Node_Id
:= Parent
(N
);
14219 Check_No_Identifiers
;
14220 Check_Arg_Count
(1);
14222 -- This pragma is born obsolete, but not the aspect
14224 if not From_Aspect_Specification
(N
) then
14226 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14229 if Nkind
(P
) = N_Task_Definition
then
14230 Arg
:= Get_Pragma_Arg
(Arg1
);
14231 Ent
:= Defining_Identifier
(Parent
(P
));
14233 -- A pragma that applies to a Ghost entity becomes Ghost for
14234 -- the purposes of legality checks and removal of ignored Ghost
14237 Mark_Ghost_Pragma
(N
, Ent
);
14239 -- The expression must be analyzed in the special manner
14240 -- described in "Handling of Default and Per-Object
14241 -- Expressions" in sem.ads.
14243 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14245 -- Check duplicate pragma before we chain the pragma in the Rep
14246 -- Item chain of Ent.
14248 Check_Duplicate_Pragma
(Ent
);
14249 Record_Rep_Item
(Ent
, N
);
14251 -- Anything else is incorrect
14256 end Dispatching_Domain
;
14262 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14264 when Pragma_Elaborate
=> Elaborate
: declare
14269 -- Pragma must be in context items list of a compilation unit
14271 if not Is_In_Context_Clause
then
14275 -- Must be at least one argument
14277 if Arg_Count
= 0 then
14278 Error_Pragma
("pragma% requires at least one argument");
14281 -- In Ada 83 mode, there can be no items following it in the
14282 -- context list except other pragmas and implicit with clauses
14283 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14284 -- placement rule does not apply.
14286 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14288 while Present
(Citem
) loop
14289 if Nkind
(Citem
) = N_Pragma
14290 or else (Nkind
(Citem
) = N_With_Clause
14291 and then Implicit_With
(Citem
))
14296 ("(Ada 83) pragma% must be at end of context clause");
14303 -- Finally, the arguments must all be units mentioned in a with
14304 -- clause in the same context clause. Note we already checked (in
14305 -- Par.Prag) that the arguments are all identifiers or selected
14309 Outer
: while Present
(Arg
) loop
14310 Citem
:= First
(List_Containing
(N
));
14311 Inner
: while Citem
/= N
loop
14312 if Nkind
(Citem
) = N_With_Clause
14313 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14315 Set_Elaborate_Present
(Citem
, True);
14316 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14318 -- With the pragma present, elaboration calls on
14319 -- subprograms from the named unit need no further
14320 -- checks, as long as the pragma appears in the current
14321 -- compilation unit. If the pragma appears in some unit
14322 -- in the context, there might still be a need for an
14323 -- Elaborate_All_Desirable from the current compilation
14324 -- to the named unit, so we keep the check enabled.
14326 if In_Extended_Main_Source_Unit
(N
) then
14328 -- This does not apply in SPARK mode, where we allow
14329 -- pragma Elaborate, but we don't trust it to be right
14330 -- so we will still insist on the Elaborate_All.
14332 if SPARK_Mode
/= On
then
14333 Set_Suppress_Elaboration_Warnings
14334 (Entity
(Name
(Citem
)));
14346 ("argument of pragma% is not withed unit", Arg
);
14352 -- Give a warning if operating in static mode with one of the
14353 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14356 and not Dynamic_Elaboration_Checks
14358 -- pragma Elaborate not allowed in SPARK mode anyway. We
14359 -- already complained about it, no point in generating any
14360 -- further complaint.
14362 and SPARK_Mode
/= On
14365 ("?l?use of pragma Elaborate may not be safe", N
);
14367 ("?l?use pragma Elaborate_All instead if possible", N
);
14371 -------------------
14372 -- Elaborate_All --
14373 -------------------
14375 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14377 when Pragma_Elaborate_All
=> Elaborate_All
: declare
14382 Check_Ada_83_Warning
;
14384 -- Pragma must be in context items list of a compilation unit
14386 if not Is_In_Context_Clause
then
14390 -- Must be at least one argument
14392 if Arg_Count
= 0 then
14393 Error_Pragma
("pragma% requires at least one argument");
14396 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14397 -- have to appear at the end of the context clause, but may
14398 -- appear mixed in with other items, even in Ada 83 mode.
14400 -- Final check: the arguments must all be units mentioned in
14401 -- a with clause in the same context clause. Note that we
14402 -- already checked (in Par.Prag) that all the arguments are
14403 -- either identifiers or selected components.
14406 Outr
: while Present
(Arg
) loop
14407 Citem
:= First
(List_Containing
(N
));
14408 Innr
: while Citem
/= N
loop
14409 if Nkind
(Citem
) = N_With_Clause
14410 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14412 Set_Elaborate_All_Present
(Citem
, True);
14413 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14415 -- Suppress warnings and elaboration checks on the named
14416 -- unit if the pragma is in the current compilation, as
14417 -- for pragma Elaborate.
14419 if In_Extended_Main_Source_Unit
(N
) then
14420 Set_Suppress_Elaboration_Warnings
14421 (Entity
(Name
(Citem
)));
14430 Set_Error_Posted
(N
);
14432 ("argument of pragma% is not withed unit", Arg
);
14439 --------------------
14440 -- Elaborate_Body --
14441 --------------------
14443 -- pragma Elaborate_Body [( library_unit_NAME )];
14445 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
14446 Cunit_Node
: Node_Id
;
14447 Cunit_Ent
: Entity_Id
;
14450 Check_Ada_83_Warning
;
14451 Check_Valid_Library_Unit_Pragma
;
14453 if Nkind
(N
) = N_Null_Statement
then
14457 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
14458 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14460 -- A pragma that applies to a Ghost entity becomes Ghost for the
14461 -- purposes of legality checks and removal of ignored Ghost code.
14463 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
14465 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
14468 Error_Pragma
("pragma% must refer to a spec, not a body");
14470 Set_Body_Required
(Cunit_Node
, True);
14471 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
14473 -- If we are in dynamic elaboration mode, then we suppress
14474 -- elaboration warnings for the unit, since it is definitely
14475 -- fine NOT to do dynamic checks at the first level (and such
14476 -- checks will be suppressed because no elaboration boolean
14477 -- is created for Elaborate_Body packages).
14479 -- But in the static model of elaboration, Elaborate_Body is
14480 -- definitely NOT good enough to ensure elaboration safety on
14481 -- its own, since the body may WITH other units that are not
14482 -- safe from an elaboration point of view, so a client must
14483 -- still do an Elaborate_All on such units.
14485 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14486 -- Elaborate_Body always suppressed elab warnings.
14488 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
14489 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
14492 end Elaborate_Body
;
14494 ------------------------
14495 -- Elaboration_Checks --
14496 ------------------------
14498 -- pragma Elaboration_Checks (Static | Dynamic);
14500 when Pragma_Elaboration_Checks
=>
14502 Check_Arg_Count
(1);
14503 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
14505 -- Set flag accordingly (ignore attempt at dynamic elaboration
14506 -- checks in SPARK mode).
14508 Dynamic_Elaboration_Checks
:=
14509 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
14515 -- pragma Eliminate (
14516 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14517 -- [,[Entity =>] IDENTIFIER |
14518 -- SELECTED_COMPONENT |
14520 -- [, OVERLOADING_RESOLUTION]);
14522 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14525 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14526 -- FUNCTION_PROFILE
14528 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14530 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14531 -- Result_Type => result_SUBTYPE_NAME]
14533 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14534 -- SUBTYPE_NAME ::= STRING_LITERAL
14536 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14537 -- SOURCE_TRACE ::= STRING_LITERAL
14539 when Pragma_Eliminate
=> Eliminate
: declare
14540 Args
: Args_List
(1 .. 5);
14541 Names
: constant Name_List
(1 .. 5) := (
14544 Name_Parameter_Types
,
14546 Name_Source_Location
);
14548 Unit_Name
: Node_Id
renames Args
(1);
14549 Entity
: Node_Id
renames Args
(2);
14550 Parameter_Types
: Node_Id
renames Args
(3);
14551 Result_Type
: Node_Id
renames Args
(4);
14552 Source_Location
: Node_Id
renames Args
(5);
14556 Check_Valid_Configuration_Pragma
;
14557 Gather_Associations
(Names
, Args
);
14559 if No
(Unit_Name
) then
14560 Error_Pragma
("missing Unit_Name argument for pragma%");
14564 and then (Present
(Parameter_Types
)
14566 Present
(Result_Type
)
14568 Present
(Source_Location
))
14570 Error_Pragma
("missing Entity argument for pragma%");
14573 if (Present
(Parameter_Types
)
14575 Present
(Result_Type
))
14577 Present
(Source_Location
)
14580 ("parameter profile and source location cannot be used "
14581 & "together in pragma%");
14584 Process_Eliminate_Pragma
14593 -----------------------------------
14594 -- Enable_Atomic_Synchronization --
14595 -----------------------------------
14597 -- pragma Enable_Atomic_Synchronization [(Entity)];
14599 when Pragma_Enable_Atomic_Synchronization
=>
14601 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
14608 -- [ Convention =>] convention_IDENTIFIER,
14609 -- [ Entity =>] LOCAL_NAME
14610 -- [, [External_Name =>] static_string_EXPRESSION ]
14611 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14613 when Pragma_Export
=> Export
: declare
14615 Def_Id
: Entity_Id
;
14617 pragma Warnings
(Off
, C
);
14620 Check_Ada_83_Warning
;
14624 Name_External_Name
,
14627 Check_At_Least_N_Arguments
(2);
14628 Check_At_Most_N_Arguments
(4);
14630 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14631 -- pragma Export (Entity, "external name");
14633 if Relaxed_RM_Semantics
14634 and then Arg_Count
= 2
14635 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
14638 Def_Id
:= Get_Pragma_Arg
(Arg1
);
14641 if not Is_Entity_Name
(Def_Id
) then
14642 Error_Pragma_Arg
("entity name required", Arg1
);
14645 Def_Id
:= Entity
(Def_Id
);
14646 Set_Exported
(Def_Id
, Arg1
);
14649 Process_Convention
(C
, Def_Id
);
14651 -- A pragma that applies to a Ghost entity becomes Ghost for
14652 -- the purposes of legality checks and removal of ignored Ghost
14655 Mark_Ghost_Pragma
(N
, Def_Id
);
14657 if Ekind
(Def_Id
) /= E_Constant
then
14658 Note_Possible_Modification
14659 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14662 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14663 Set_Exported
(Def_Id
, Arg2
);
14666 -- If the entity is a deferred constant, propagate the information
14667 -- to the full view, because gigi elaborates the full view only.
14669 if Ekind
(Def_Id
) = E_Constant
14670 and then Present
(Full_View
(Def_Id
))
14673 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
14675 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
14676 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
14677 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
14682 ---------------------
14683 -- Export_Function --
14684 ---------------------
14686 -- pragma Export_Function (
14687 -- [Internal =>] LOCAL_NAME
14688 -- [, [External =>] EXTERNAL_SYMBOL]
14689 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14690 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14691 -- [, [Mechanism =>] MECHANISM]
14692 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14694 -- EXTERNAL_SYMBOL ::=
14696 -- | static_string_EXPRESSION
14698 -- PARAMETER_TYPES ::=
14700 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14702 -- TYPE_DESIGNATOR ::=
14704 -- | subtype_Name ' Access
14708 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14710 -- MECHANISM_ASSOCIATION ::=
14711 -- [formal_parameter_NAME =>] MECHANISM_NAME
14713 -- MECHANISM_NAME ::=
14717 when Pragma_Export_Function
=> Export_Function
: declare
14718 Args
: Args_List
(1 .. 6);
14719 Names
: constant Name_List
(1 .. 6) := (
14722 Name_Parameter_Types
,
14725 Name_Result_Mechanism
);
14727 Internal
: Node_Id
renames Args
(1);
14728 External
: Node_Id
renames Args
(2);
14729 Parameter_Types
: Node_Id
renames Args
(3);
14730 Result_Type
: Node_Id
renames Args
(4);
14731 Mechanism
: Node_Id
renames Args
(5);
14732 Result_Mechanism
: Node_Id
renames Args
(6);
14736 Gather_Associations
(Names
, Args
);
14737 Process_Extended_Import_Export_Subprogram_Pragma
(
14738 Arg_Internal
=> Internal
,
14739 Arg_External
=> External
,
14740 Arg_Parameter_Types
=> Parameter_Types
,
14741 Arg_Result_Type
=> Result_Type
,
14742 Arg_Mechanism
=> Mechanism
,
14743 Arg_Result_Mechanism
=> Result_Mechanism
);
14744 end Export_Function
;
14746 -------------------
14747 -- Export_Object --
14748 -------------------
14750 -- pragma Export_Object (
14751 -- [Internal =>] LOCAL_NAME
14752 -- [, [External =>] EXTERNAL_SYMBOL]
14753 -- [, [Size =>] EXTERNAL_SYMBOL]);
14755 -- EXTERNAL_SYMBOL ::=
14757 -- | static_string_EXPRESSION
14759 -- PARAMETER_TYPES ::=
14761 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14763 -- TYPE_DESIGNATOR ::=
14765 -- | subtype_Name ' Access
14769 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14771 -- MECHANISM_ASSOCIATION ::=
14772 -- [formal_parameter_NAME =>] MECHANISM_NAME
14774 -- MECHANISM_NAME ::=
14778 when Pragma_Export_Object
=> Export_Object
: declare
14779 Args
: Args_List
(1 .. 3);
14780 Names
: constant Name_List
(1 .. 3) := (
14785 Internal
: Node_Id
renames Args
(1);
14786 External
: Node_Id
renames Args
(2);
14787 Size
: Node_Id
renames Args
(3);
14791 Gather_Associations
(Names
, Args
);
14792 Process_Extended_Import_Export_Object_Pragma
(
14793 Arg_Internal
=> Internal
,
14794 Arg_External
=> External
,
14798 ----------------------
14799 -- Export_Procedure --
14800 ----------------------
14802 -- pragma Export_Procedure (
14803 -- [Internal =>] LOCAL_NAME
14804 -- [, [External =>] EXTERNAL_SYMBOL]
14805 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14806 -- [, [Mechanism =>] MECHANISM]);
14808 -- EXTERNAL_SYMBOL ::=
14810 -- | static_string_EXPRESSION
14812 -- PARAMETER_TYPES ::=
14814 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14816 -- TYPE_DESIGNATOR ::=
14818 -- | subtype_Name ' Access
14822 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14824 -- MECHANISM_ASSOCIATION ::=
14825 -- [formal_parameter_NAME =>] MECHANISM_NAME
14827 -- MECHANISM_NAME ::=
14831 when Pragma_Export_Procedure
=> Export_Procedure
: declare
14832 Args
: Args_List
(1 .. 4);
14833 Names
: constant Name_List
(1 .. 4) := (
14836 Name_Parameter_Types
,
14839 Internal
: Node_Id
renames Args
(1);
14840 External
: Node_Id
renames Args
(2);
14841 Parameter_Types
: Node_Id
renames Args
(3);
14842 Mechanism
: Node_Id
renames Args
(4);
14846 Gather_Associations
(Names
, Args
);
14847 Process_Extended_Import_Export_Subprogram_Pragma
(
14848 Arg_Internal
=> Internal
,
14849 Arg_External
=> External
,
14850 Arg_Parameter_Types
=> Parameter_Types
,
14851 Arg_Mechanism
=> Mechanism
);
14852 end Export_Procedure
;
14858 -- pragma Export_Value (
14859 -- [Value =>] static_integer_EXPRESSION,
14860 -- [Link_Name =>] static_string_EXPRESSION);
14862 when Pragma_Export_Value
=>
14864 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
14865 Check_Arg_Count
(2);
14867 Check_Optional_Identifier
(Arg1
, Name_Value
);
14868 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
14870 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
14871 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
14873 -----------------------------
14874 -- Export_Valued_Procedure --
14875 -----------------------------
14877 -- pragma Export_Valued_Procedure (
14878 -- [Internal =>] LOCAL_NAME
14879 -- [, [External =>] EXTERNAL_SYMBOL,]
14880 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14881 -- [, [Mechanism =>] MECHANISM]);
14883 -- EXTERNAL_SYMBOL ::=
14885 -- | static_string_EXPRESSION
14887 -- PARAMETER_TYPES ::=
14889 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14891 -- TYPE_DESIGNATOR ::=
14893 -- | subtype_Name ' Access
14897 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14899 -- MECHANISM_ASSOCIATION ::=
14900 -- [formal_parameter_NAME =>] MECHANISM_NAME
14902 -- MECHANISM_NAME ::=
14906 when Pragma_Export_Valued_Procedure
=>
14907 Export_Valued_Procedure
: declare
14908 Args
: Args_List
(1 .. 4);
14909 Names
: constant Name_List
(1 .. 4) := (
14912 Name_Parameter_Types
,
14915 Internal
: Node_Id
renames Args
(1);
14916 External
: Node_Id
renames Args
(2);
14917 Parameter_Types
: Node_Id
renames Args
(3);
14918 Mechanism
: Node_Id
renames Args
(4);
14922 Gather_Associations
(Names
, Args
);
14923 Process_Extended_Import_Export_Subprogram_Pragma
(
14924 Arg_Internal
=> Internal
,
14925 Arg_External
=> External
,
14926 Arg_Parameter_Types
=> Parameter_Types
,
14927 Arg_Mechanism
=> Mechanism
);
14928 end Export_Valued_Procedure
;
14930 -------------------
14931 -- Extend_System --
14932 -------------------
14934 -- pragma Extend_System ([Name =>] Identifier);
14936 when Pragma_Extend_System
=>
14938 Check_Valid_Configuration_Pragma
;
14939 Check_Arg_Count
(1);
14940 Check_Optional_Identifier
(Arg1
, Name_Name
);
14941 Check_Arg_Is_Identifier
(Arg1
);
14943 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14946 and then Name_Buffer
(1 .. 4) = "aux_"
14948 if Present
(System_Extend_Pragma_Arg
) then
14949 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14950 Chars
(Expression
(System_Extend_Pragma_Arg
))
14954 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14955 Error_Pragma
("pragma% conflicts with that #");
14959 System_Extend_Pragma_Arg
:= Arg1
;
14961 if not GNAT_Mode
then
14962 System_Extend_Unit
:= Arg1
;
14966 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14969 ------------------------
14970 -- Extensions_Allowed --
14971 ------------------------
14973 -- pragma Extensions_Allowed (ON | OFF);
14975 when Pragma_Extensions_Allowed
=>
14977 Check_Arg_Count
(1);
14978 Check_No_Identifiers
;
14979 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14981 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14982 Extensions_Allowed
:= True;
14983 Ada_Version
:= Ada_Version_Type
'Last;
14986 Extensions_Allowed
:= False;
14987 Ada_Version
:= Ada_Version_Explicit
;
14988 Ada_Version_Pragma
:= Empty
;
14991 ------------------------
14992 -- Extensions_Visible --
14993 ------------------------
14995 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14997 -- Characteristics:
14999 -- * Analysis - The annotation is fully analyzed immediately upon
15000 -- elaboration as its expression must be static.
15002 -- * Expansion - None.
15004 -- * Template - The annotation utilizes the generic template of the
15005 -- related subprogram [body] when it is:
15007 -- aspect on subprogram declaration
15008 -- aspect on stand alone subprogram body
15009 -- pragma on stand alone subprogram body
15011 -- The annotation must prepare its own template when it is:
15013 -- pragma on subprogram declaration
15015 -- * Globals - Capture of global references must occur after full
15018 -- * Instance - The annotation is instantiated automatically when
15019 -- the related generic subprogram [body] is instantiated except for
15020 -- the "pragma on subprogram declaration" case. In that scenario
15021 -- the annotation must instantiate itself.
15023 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15024 Formal
: Entity_Id
;
15025 Has_OK_Formal
: Boolean := False;
15026 Spec_Id
: Entity_Id
;
15027 Subp_Decl
: Node_Id
;
15031 Check_No_Identifiers
;
15032 Check_At_Most_N_Arguments
(1);
15035 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15037 -- Abstract subprogram declaration
15039 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15042 -- Generic subprogram declaration
15044 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15047 -- Body acts as spec
15049 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15050 and then No
(Corresponding_Spec
(Subp_Decl
))
15054 -- Body stub acts as spec
15056 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15057 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15061 -- Subprogram declaration
15063 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15066 -- Otherwise the pragma is associated with an illegal construct
15069 Error_Pragma
("pragma % must apply to a subprogram");
15073 -- Mark the pragma as Ghost if the related subprogram is also
15074 -- Ghost. This also ensures that any expansion performed further
15075 -- below will produce Ghost nodes.
15077 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15078 Mark_Ghost_Pragma
(N
, Spec_Id
);
15080 -- Chain the pragma on the contract for completeness
15082 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15084 -- The legality checks of pragma Extension_Visible are affected
15085 -- by the SPARK mode in effect. Analyze all pragmas in specific
15088 Analyze_If_Present
(Pragma_SPARK_Mode
);
15090 -- Examine the formals of the related subprogram
15092 Formal
:= First_Formal
(Spec_Id
);
15093 while Present
(Formal
) loop
15095 -- At least one of the formals is of a specific tagged type,
15096 -- the pragma is legal.
15098 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15099 Has_OK_Formal
:= True;
15102 -- A generic subprogram with at least one formal of a private
15103 -- type ensures the legality of the pragma because the actual
15104 -- may be specifically tagged. Note that this is verified by
15105 -- the check above at instantiation time.
15107 elsif Is_Private_Type
(Etype
(Formal
))
15108 and then Is_Generic_Type
(Etype
(Formal
))
15110 Has_OK_Formal
:= True;
15114 Next_Formal
(Formal
);
15117 if not Has_OK_Formal
then
15118 Error_Msg_Name_1
:= Pname
;
15119 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15121 ("\subprogram & lacks parameter of specific tagged or "
15122 & "generic private type", N
, Spec_Id
);
15127 -- Analyze the Boolean expression (if any)
15129 if Present
(Arg1
) then
15130 Check_Static_Boolean_Expression
15131 (Expression
(Get_Argument
(N
, Spec_Id
)));
15133 end Extensions_Visible
;
15139 -- pragma External (
15140 -- [ Convention =>] convention_IDENTIFIER,
15141 -- [ Entity =>] LOCAL_NAME
15142 -- [, [External_Name =>] static_string_EXPRESSION ]
15143 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15145 when Pragma_External
=> External
: declare
15148 pragma Warnings
(Off
, C
);
15155 Name_External_Name
,
15157 Check_At_Least_N_Arguments
(2);
15158 Check_At_Most_N_Arguments
(4);
15159 Process_Convention
(C
, E
);
15161 -- A pragma that applies to a Ghost entity becomes Ghost for the
15162 -- purposes of legality checks and removal of ignored Ghost code.
15164 Mark_Ghost_Pragma
(N
, E
);
15166 Note_Possible_Modification
15167 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15168 Process_Interface_Name
(E
, Arg3
, Arg4
);
15169 Set_Exported
(E
, Arg2
);
15172 --------------------------
15173 -- External_Name_Casing --
15174 --------------------------
15176 -- pragma External_Name_Casing (
15177 -- UPPERCASE | LOWERCASE
15178 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15180 when Pragma_External_Name_Casing
=>
15182 Check_No_Identifiers
;
15184 if Arg_Count
= 2 then
15185 Check_Arg_Is_One_Of
15186 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15188 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15190 Opt
.External_Name_Exp_Casing
:= As_Is
;
15192 when Name_Uppercase
=>
15193 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15195 when Name_Lowercase
=>
15196 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15203 Check_Arg_Count
(1);
15206 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15208 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15209 when Name_Uppercase
=>
15210 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15212 when Name_Lowercase
=>
15213 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15223 -- pragma Fast_Math;
15225 when Pragma_Fast_Math
=>
15227 Check_No_Identifiers
;
15228 Check_Valid_Configuration_Pragma
;
15231 --------------------------
15232 -- Favor_Top_Level --
15233 --------------------------
15235 -- pragma Favor_Top_Level (type_NAME);
15237 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15242 Check_No_Identifiers
;
15243 Check_Arg_Count
(1);
15244 Check_Arg_Is_Local_Name
(Arg1
);
15245 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15247 -- A pragma that applies to a Ghost entity becomes Ghost for the
15248 -- purposes of legality checks and removal of ignored Ghost code.
15250 Mark_Ghost_Pragma
(N
, Typ
);
15252 -- If it's an access-to-subprogram type (in particular, not a
15253 -- subtype), set the flag on that type.
15255 if Is_Access_Subprogram_Type
(Typ
) then
15256 Set_Can_Use_Internal_Rep
(Typ
, False);
15258 -- Otherwise it's an error (name denotes the wrong sort of entity)
15262 ("access-to-subprogram type expected",
15263 Get_Pragma_Arg
(Arg1
));
15265 end Favor_Top_Level
;
15267 ---------------------------
15268 -- Finalize_Storage_Only --
15269 ---------------------------
15271 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15273 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15274 Assoc
: constant Node_Id
:= Arg1
;
15275 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15280 Check_No_Identifiers
;
15281 Check_Arg_Count
(1);
15282 Check_Arg_Is_Local_Name
(Arg1
);
15284 Find_Type
(Type_Id
);
15285 Typ
:= Entity
(Type_Id
);
15288 or else Rep_Item_Too_Early
(Typ
, N
)
15292 Typ
:= Underlying_Type
(Typ
);
15295 if not Is_Controlled
(Typ
) then
15296 Error_Pragma
("pragma% must specify controlled type");
15299 Check_First_Subtype
(Arg1
);
15301 if Finalize_Storage_Only
(Typ
) then
15302 Error_Pragma
("duplicate pragma%, only one allowed");
15304 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15305 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15307 end Finalize_Storage
;
15313 -- pragma Ghost [ (boolean_EXPRESSION) ];
15315 when Pragma_Ghost
=> Ghost
: declare
15319 Orig_Stmt
: Node_Id
;
15320 Prev_Id
: Entity_Id
;
15325 Check_No_Identifiers
;
15326 Check_At_Most_N_Arguments
(1);
15330 while Present
(Stmt
) loop
15332 -- Skip prior pragmas, but check for duplicates
15334 if Nkind
(Stmt
) = N_Pragma
then
15335 if Pragma_Name
(Stmt
) = Pname
then
15336 Error_Msg_Name_1
:= Pname
;
15337 Error_Msg_Sloc
:= Sloc
(Stmt
);
15338 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
15341 -- Task unit declared without a definition cannot be subject to
15342 -- pragma Ghost (SPARK RM 6.9(19)).
15344 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15345 N_Task_Type_Declaration
)
15347 Error_Pragma
("pragma % cannot apply to a task type");
15350 -- Skip internally generated code
15352 elsif not Comes_From_Source
(Stmt
) then
15353 Orig_Stmt
:= Original_Node
(Stmt
);
15355 -- When pragma Ghost applies to an untagged derivation, the
15356 -- derivation is transformed into a [sub]type declaration.
15358 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15359 N_Subtype_Declaration
)
15360 and then Comes_From_Source
(Orig_Stmt
)
15361 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15362 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15363 N_Derived_Type_Definition
15365 Id
:= Defining_Entity
(Stmt
);
15368 -- When pragma Ghost applies to an object declaration which
15369 -- is initialized by means of a function call that returns
15370 -- on the secondary stack, the object declaration becomes a
15373 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
15374 and then Comes_From_Source
(Orig_Stmt
)
15375 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
15377 Id
:= Defining_Entity
(Stmt
);
15380 -- When pragma Ghost applies to an expression function, the
15381 -- expression function is transformed into a subprogram.
15383 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
15384 and then Comes_From_Source
(Orig_Stmt
)
15385 and then Nkind
(Orig_Stmt
) = N_Expression_Function
15387 Id
:= Defining_Entity
(Stmt
);
15391 -- The pragma applies to a legal construct, stop the traversal
15393 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
15394 N_Full_Type_Declaration
,
15395 N_Generic_Subprogram_Declaration
,
15396 N_Object_Declaration
,
15397 N_Private_Extension_Declaration
,
15398 N_Private_Type_Declaration
,
15399 N_Subprogram_Declaration
,
15400 N_Subtype_Declaration
)
15402 Id
:= Defining_Entity
(Stmt
);
15405 -- The pragma does not apply to a legal construct, issue an
15406 -- error and stop the analysis.
15410 ("pragma % must apply to an object, package, subprogram "
15415 Stmt
:= Prev
(Stmt
);
15418 Context
:= Parent
(N
);
15420 -- Handle compilation units
15422 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
15423 Context
:= Unit
(Parent
(Context
));
15426 -- Protected and task types cannot be subject to pragma Ghost
15427 -- (SPARK RM 6.9(19)).
15429 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
15431 Error_Pragma
("pragma % cannot apply to a protected type");
15434 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
15435 Error_Pragma
("pragma % cannot apply to a task type");
15441 -- When pragma Ghost is associated with a [generic] package, it
15442 -- appears in the visible declarations.
15444 if Nkind
(Context
) = N_Package_Specification
15445 and then Present
(Visible_Declarations
(Context
))
15446 and then List_Containing
(N
) = Visible_Declarations
(Context
)
15448 Id
:= Defining_Entity
(Context
);
15450 -- Pragma Ghost applies to a stand alone subprogram body
15452 elsif Nkind
(Context
) = N_Subprogram_Body
15453 and then No
(Corresponding_Spec
(Context
))
15455 Id
:= Defining_Entity
(Context
);
15457 -- Pragma Ghost applies to a subprogram declaration that acts
15458 -- as a compilation unit.
15460 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
15461 Id
:= Defining_Entity
(Context
);
15467 ("pragma % must apply to an object, package, subprogram or "
15472 -- Handle completions of types and constants that are subject to
15475 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
15476 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
15478 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
15479 Error_Msg_Name_1
:= Pname
;
15481 -- The full declaration of a deferred constant cannot be
15482 -- subject to pragma Ghost unless the deferred declaration
15483 -- is also Ghost (SPARK RM 6.9(9)).
15485 if Ekind
(Prev_Id
) = E_Constant
then
15486 Error_Msg_Name_1
:= Pname
;
15487 Error_Msg_NE
(Fix_Error
15488 ("pragma % must apply to declaration of deferred "
15489 & "constant &"), N
, Id
);
15492 -- Pragma Ghost may appear on the full view of an incomplete
15493 -- type because the incomplete declaration lacks aspects and
15494 -- cannot be subject to pragma Ghost.
15496 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
15499 -- The full declaration of a type cannot be subject to
15500 -- pragma Ghost unless the partial view is also Ghost
15501 -- (SPARK RM 6.9(9)).
15504 Error_Msg_NE
(Fix_Error
15505 ("pragma % must apply to partial view of type &"),
15511 -- A synchronized object cannot be subject to pragma Ghost
15512 -- (SPARK RM 6.9(19)).
15514 elsif Ekind
(Id
) = E_Variable
then
15515 if Is_Protected_Type
(Etype
(Id
)) then
15516 Error_Pragma
("pragma % cannot apply to a protected object");
15519 elsif Is_Task_Type
(Etype
(Id
)) then
15520 Error_Pragma
("pragma % cannot apply to a task object");
15525 -- Analyze the Boolean expression (if any)
15527 if Present
(Arg1
) then
15528 Expr
:= Get_Pragma_Arg
(Arg1
);
15530 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
15532 if Is_OK_Static_Expression
(Expr
) then
15534 -- "Ghostness" cannot be turned off once enabled within a
15535 -- region (SPARK RM 6.9(6)).
15537 if Is_False
(Expr_Value
(Expr
))
15538 and then Ghost_Mode
> None
15541 ("pragma % with value False cannot appear in enabled "
15546 -- Otherwie the expression is not static
15550 ("expression of pragma % must be static", Expr
);
15555 Set_Is_Ghost_Entity
(Id
);
15562 -- pragma Global (GLOBAL_SPECIFICATION);
15564 -- GLOBAL_SPECIFICATION ::=
15567 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15569 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15571 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15572 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15573 -- GLOBAL_ITEM ::= NAME
15575 -- Characteristics:
15577 -- * Analysis - The annotation undergoes initial checks to verify
15578 -- the legal placement and context. Secondary checks fully analyze
15579 -- the dependency clauses in:
15581 -- Analyze_Global_In_Decl_Part
15583 -- * Expansion - None.
15585 -- * Template - The annotation utilizes the generic template of the
15586 -- related subprogram [body] when it is:
15588 -- aspect on subprogram declaration
15589 -- aspect on stand alone subprogram body
15590 -- pragma on stand alone subprogram body
15592 -- The annotation must prepare its own template when it is:
15594 -- pragma on subprogram declaration
15596 -- * Globals - Capture of global references must occur after full
15599 -- * Instance - The annotation is instantiated automatically when
15600 -- the related generic subprogram [body] is instantiated except for
15601 -- the "pragma on subprogram declaration" case. In that scenario
15602 -- the annotation must instantiate itself.
15604 when Pragma_Global
=> Global
: declare
15606 Spec_Id
: Entity_Id
;
15607 Subp_Decl
: Node_Id
;
15610 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15614 -- Chain the pragma on the contract for further processing by
15615 -- Analyze_Global_In_Decl_Part.
15617 Add_Contract_Item
(N
, Spec_Id
);
15619 -- Fully analyze the pragma when it appears inside an entry
15620 -- or subprogram body because it cannot benefit from forward
15623 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15625 N_Subprogram_Body_Stub
)
15627 -- The legality checks of pragmas Depends and Global are
15628 -- affected by the SPARK mode in effect and the volatility
15629 -- of the context. In addition these two pragmas are subject
15630 -- to an inherent order:
15635 -- Analyze all these pragmas in the order outlined above
15637 Analyze_If_Present
(Pragma_SPARK_Mode
);
15638 Analyze_If_Present
(Pragma_Volatile_Function
);
15639 Analyze_Global_In_Decl_Part
(N
);
15640 Analyze_If_Present
(Pragma_Depends
);
15649 -- pragma Ident (static_string_EXPRESSION)
15651 -- Note: pragma Comment shares this processing. Pragma Ident is
15652 -- identical in effect to pragma Commment.
15654 when Pragma_Comment
15662 Check_Arg_Count
(1);
15663 Check_No_Identifiers
;
15664 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15667 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
15674 GP
:= Parent
(Parent
(N
));
15676 if Nkind_In
(GP
, N_Package_Declaration
,
15677 N_Generic_Package_Declaration
)
15682 -- If we have a compilation unit, then record the ident value,
15683 -- checking for improper duplication.
15685 if Nkind
(GP
) = N_Compilation_Unit
then
15686 CS
:= Ident_String
(Current_Sem_Unit
);
15688 if Present
(CS
) then
15690 -- If we have multiple instances, concatenate them, but
15691 -- not in ASIS, where we want the original tree.
15693 if not ASIS_Mode
then
15694 Start_String
(Strval
(CS
));
15695 Store_String_Char
(' ');
15696 Store_String_Chars
(Strval
(Str
));
15697 Set_Strval
(CS
, End_String
);
15701 Set_Ident_String
(Current_Sem_Unit
, Str
);
15704 -- For subunits, we just ignore the Ident, since in GNAT these
15705 -- are not separate object files, and hence not separate units
15706 -- in the unit table.
15708 elsif Nkind
(GP
) = N_Subunit
then
15714 -------------------
15715 -- Ignore_Pragma --
15716 -------------------
15718 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15720 -- Entirely handled in the parser, nothing to do here
15722 when Pragma_Ignore_Pragma
=>
15725 ----------------------------
15726 -- Implementation_Defined --
15727 ----------------------------
15729 -- pragma Implementation_Defined (LOCAL_NAME);
15731 -- Marks previously declared entity as implementation defined. For
15732 -- an overloaded entity, applies to the most recent homonym.
15734 -- pragma Implementation_Defined;
15736 -- The form with no arguments appears anywhere within a scope, most
15737 -- typically a package spec, and indicates that all entities that are
15738 -- defined within the package spec are Implementation_Defined.
15740 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15745 Check_No_Identifiers
;
15747 -- Form with no arguments
15749 if Arg_Count
= 0 then
15750 Set_Is_Implementation_Defined
(Current_Scope
);
15752 -- Form with one argument
15755 Check_Arg_Count
(1);
15756 Check_Arg_Is_Local_Name
(Arg1
);
15757 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15758 Set_Is_Implementation_Defined
(Ent
);
15760 end Implementation_Defined
;
15766 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15768 -- IMPLEMENTATION_KIND ::=
15769 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15771 -- "By_Any" and "Optional" are treated as synonyms in order to
15772 -- support Ada 2012 aspect Synchronization.
15774 when Pragma_Implemented
=> Implemented
: declare
15775 Proc_Id
: Entity_Id
;
15780 Check_Arg_Count
(2);
15781 Check_No_Identifiers
;
15782 Check_Arg_Is_Identifier
(Arg1
);
15783 Check_Arg_Is_Local_Name
(Arg1
);
15784 Check_Arg_Is_One_Of
(Arg2
,
15787 Name_By_Protected_Procedure
,
15790 -- Extract the name of the local procedure
15792 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15794 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15795 -- primitive procedure of a synchronized tagged type.
15797 if Ekind
(Proc_Id
) = E_Procedure
15798 and then Is_Primitive
(Proc_Id
)
15799 and then Present
(First_Formal
(Proc_Id
))
15801 Typ
:= Etype
(First_Formal
(Proc_Id
));
15803 if Is_Tagged_Type
(Typ
)
15806 -- Check for a protected, a synchronized or a task interface
15808 ((Is_Interface
(Typ
)
15809 and then Is_Synchronized_Interface
(Typ
))
15811 -- Check for a protected type or a task type that implements
15815 (Is_Concurrent_Record_Type
(Typ
)
15816 and then Present
(Interfaces
(Typ
)))
15818 -- In analysis-only mode, examine original protected type
15821 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
15822 and then Present
(Interface_List
(Parent
(Typ
))))
15824 -- Check for a private record extension with keyword
15828 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
15829 E_Record_Subtype_With_Private
)
15830 and then Synchronized_Present
(Parent
(Typ
))))
15835 ("controlling formal must be of synchronized tagged type",
15840 -- Procedures declared inside a protected type must be accepted
15842 elsif Ekind
(Proc_Id
) = E_Procedure
15843 and then Is_Protected_Type
(Scope
(Proc_Id
))
15847 -- The first argument is not a primitive procedure
15851 ("pragma % must be applied to a primitive procedure", Arg1
);
15855 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15856 -- By_Protected_Procedure to the primitive procedure of a task
15859 if Chars
(Arg2
) = Name_By_Protected_Procedure
15860 and then Is_Interface
(Typ
)
15861 and then Is_Task_Interface
(Typ
)
15864 ("implementation kind By_Protected_Procedure cannot be "
15865 & "applied to a task interface primitive", Arg2
);
15869 Record_Rep_Item
(Proc_Id
, N
);
15872 ----------------------
15873 -- Implicit_Packing --
15874 ----------------------
15876 -- pragma Implicit_Packing;
15878 when Pragma_Implicit_Packing
=>
15880 Check_Arg_Count
(0);
15881 Implicit_Packing
:= True;
15888 -- [Convention =>] convention_IDENTIFIER,
15889 -- [Entity =>] LOCAL_NAME
15890 -- [, [External_Name =>] static_string_EXPRESSION ]
15891 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15893 when Pragma_Import
=>
15894 Check_Ada_83_Warning
;
15898 Name_External_Name
,
15901 Check_At_Least_N_Arguments
(2);
15902 Check_At_Most_N_Arguments
(4);
15903 Process_Import_Or_Interface
;
15905 ---------------------
15906 -- Import_Function --
15907 ---------------------
15909 -- pragma Import_Function (
15910 -- [Internal =>] LOCAL_NAME,
15911 -- [, [External =>] EXTERNAL_SYMBOL]
15912 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15913 -- [, [Result_Type =>] SUBTYPE_MARK]
15914 -- [, [Mechanism =>] MECHANISM]
15915 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15917 -- EXTERNAL_SYMBOL ::=
15919 -- | static_string_EXPRESSION
15921 -- PARAMETER_TYPES ::=
15923 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15925 -- TYPE_DESIGNATOR ::=
15927 -- | subtype_Name ' Access
15931 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15933 -- MECHANISM_ASSOCIATION ::=
15934 -- [formal_parameter_NAME =>] MECHANISM_NAME
15936 -- MECHANISM_NAME ::=
15940 when Pragma_Import_Function
=> Import_Function
: declare
15941 Args
: Args_List
(1 .. 6);
15942 Names
: constant Name_List
(1 .. 6) := (
15945 Name_Parameter_Types
,
15948 Name_Result_Mechanism
);
15950 Internal
: Node_Id
renames Args
(1);
15951 External
: Node_Id
renames Args
(2);
15952 Parameter_Types
: Node_Id
renames Args
(3);
15953 Result_Type
: Node_Id
renames Args
(4);
15954 Mechanism
: Node_Id
renames Args
(5);
15955 Result_Mechanism
: Node_Id
renames Args
(6);
15959 Gather_Associations
(Names
, Args
);
15960 Process_Extended_Import_Export_Subprogram_Pragma
(
15961 Arg_Internal
=> Internal
,
15962 Arg_External
=> External
,
15963 Arg_Parameter_Types
=> Parameter_Types
,
15964 Arg_Result_Type
=> Result_Type
,
15965 Arg_Mechanism
=> Mechanism
,
15966 Arg_Result_Mechanism
=> Result_Mechanism
);
15967 end Import_Function
;
15969 -------------------
15970 -- Import_Object --
15971 -------------------
15973 -- pragma Import_Object (
15974 -- [Internal =>] LOCAL_NAME
15975 -- [, [External =>] EXTERNAL_SYMBOL]
15976 -- [, [Size =>] EXTERNAL_SYMBOL]);
15978 -- EXTERNAL_SYMBOL ::=
15980 -- | static_string_EXPRESSION
15982 when Pragma_Import_Object
=> Import_Object
: declare
15983 Args
: Args_List
(1 .. 3);
15984 Names
: constant Name_List
(1 .. 3) := (
15989 Internal
: Node_Id
renames Args
(1);
15990 External
: Node_Id
renames Args
(2);
15991 Size
: Node_Id
renames Args
(3);
15995 Gather_Associations
(Names
, Args
);
15996 Process_Extended_Import_Export_Object_Pragma
(
15997 Arg_Internal
=> Internal
,
15998 Arg_External
=> External
,
16002 ----------------------
16003 -- Import_Procedure --
16004 ----------------------
16006 -- pragma Import_Procedure (
16007 -- [Internal =>] LOCAL_NAME
16008 -- [, [External =>] EXTERNAL_SYMBOL]
16009 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16010 -- [, [Mechanism =>] MECHANISM]);
16012 -- EXTERNAL_SYMBOL ::=
16014 -- | static_string_EXPRESSION
16016 -- PARAMETER_TYPES ::=
16018 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16020 -- TYPE_DESIGNATOR ::=
16022 -- | subtype_Name ' Access
16026 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16028 -- MECHANISM_ASSOCIATION ::=
16029 -- [formal_parameter_NAME =>] MECHANISM_NAME
16031 -- MECHANISM_NAME ::=
16035 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16036 Args
: Args_List
(1 .. 4);
16037 Names
: constant Name_List
(1 .. 4) := (
16040 Name_Parameter_Types
,
16043 Internal
: Node_Id
renames Args
(1);
16044 External
: Node_Id
renames Args
(2);
16045 Parameter_Types
: Node_Id
renames Args
(3);
16046 Mechanism
: Node_Id
renames Args
(4);
16050 Gather_Associations
(Names
, Args
);
16051 Process_Extended_Import_Export_Subprogram_Pragma
(
16052 Arg_Internal
=> Internal
,
16053 Arg_External
=> External
,
16054 Arg_Parameter_Types
=> Parameter_Types
,
16055 Arg_Mechanism
=> Mechanism
);
16056 end Import_Procedure
;
16058 -----------------------------
16059 -- Import_Valued_Procedure --
16060 -----------------------------
16062 -- pragma Import_Valued_Procedure (
16063 -- [Internal =>] LOCAL_NAME
16064 -- [, [External =>] EXTERNAL_SYMBOL]
16065 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16066 -- [, [Mechanism =>] MECHANISM]);
16068 -- EXTERNAL_SYMBOL ::=
16070 -- | static_string_EXPRESSION
16072 -- PARAMETER_TYPES ::=
16074 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16076 -- TYPE_DESIGNATOR ::=
16078 -- | subtype_Name ' Access
16082 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16084 -- MECHANISM_ASSOCIATION ::=
16085 -- [formal_parameter_NAME =>] MECHANISM_NAME
16087 -- MECHANISM_NAME ::=
16091 when Pragma_Import_Valued_Procedure
=>
16092 Import_Valued_Procedure
: declare
16093 Args
: Args_List
(1 .. 4);
16094 Names
: constant Name_List
(1 .. 4) := (
16097 Name_Parameter_Types
,
16100 Internal
: Node_Id
renames Args
(1);
16101 External
: Node_Id
renames Args
(2);
16102 Parameter_Types
: Node_Id
renames Args
(3);
16103 Mechanism
: Node_Id
renames Args
(4);
16107 Gather_Associations
(Names
, Args
);
16108 Process_Extended_Import_Export_Subprogram_Pragma
(
16109 Arg_Internal
=> Internal
,
16110 Arg_External
=> External
,
16111 Arg_Parameter_Types
=> Parameter_Types
,
16112 Arg_Mechanism
=> Mechanism
);
16113 end Import_Valued_Procedure
;
16119 -- pragma Independent (LOCAL_NAME);
16121 when Pragma_Independent
=>
16122 Process_Atomic_Independent_Shared_Volatile
;
16124 ----------------------------
16125 -- Independent_Components --
16126 ----------------------------
16128 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16130 when Pragma_Independent_Components
=> Independent_Components
: declare
16138 Check_Ada_83_Warning
;
16140 Check_No_Identifiers
;
16141 Check_Arg_Count
(1);
16142 Check_Arg_Is_Local_Name
(Arg1
);
16143 E_Id
:= Get_Pragma_Arg
(Arg1
);
16145 if Etype
(E_Id
) = Any_Type
then
16149 E
:= Entity
(E_Id
);
16151 -- A pragma that applies to a Ghost entity becomes Ghost for the
16152 -- purposes of legality checks and removal of ignored Ghost code.
16154 Mark_Ghost_Pragma
(N
, E
);
16156 -- Check duplicate before we chain ourselves
16158 Check_Duplicate_Pragma
(E
);
16160 -- Check appropriate entity
16162 if Rep_Item_Too_Early
(E
, N
)
16164 Rep_Item_Too_Late
(E
, N
)
16169 D
:= Declaration_Node
(E
);
16172 -- The flag is set on the base type, or on the object
16174 if K
= N_Full_Type_Declaration
16175 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16177 Set_Has_Independent_Components
(Base_Type
(E
));
16178 Record_Independence_Check
(N
, Base_Type
(E
));
16180 -- For record type, set all components independent
16182 if Is_Record_Type
(E
) then
16183 C
:= First_Component
(E
);
16184 while Present
(C
) loop
16185 Set_Is_Independent
(C
);
16186 Next_Component
(C
);
16190 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16191 and then Nkind
(D
) = N_Object_Declaration
16192 and then Nkind
(Object_Definition
(D
)) =
16193 N_Constrained_Array_Definition
16195 Set_Has_Independent_Components
(E
);
16196 Record_Independence_Check
(N
, E
);
16199 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16201 end Independent_Components
;
16203 -----------------------
16204 -- Initial_Condition --
16205 -----------------------
16207 -- pragma Initial_Condition (boolean_EXPRESSION);
16209 -- Characteristics:
16211 -- * Analysis - The annotation undergoes initial checks to verify
16212 -- the legal placement and context. Secondary checks preanalyze the
16215 -- Analyze_Initial_Condition_In_Decl_Part
16217 -- * Expansion - The annotation is expanded during the expansion of
16218 -- the package body whose declaration is subject to the annotation
16221 -- Expand_Pragma_Initial_Condition
16223 -- * Template - The annotation utilizes the generic template of the
16224 -- related package declaration.
16226 -- * Globals - Capture of global references must occur after full
16229 -- * Instance - The annotation is instantiated automatically when
16230 -- the related generic package is instantiated.
16232 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16233 Pack_Decl
: Node_Id
;
16234 Pack_Id
: Entity_Id
;
16238 Check_No_Identifiers
;
16239 Check_Arg_Count
(1);
16241 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16243 -- Ensure the proper placement of the pragma. Initial_Condition
16244 -- must be associated with a package declaration.
16246 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16247 N_Package_Declaration
)
16251 -- Otherwise the pragma is associated with an illegal context
16258 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16260 -- A pragma that applies to a Ghost entity becomes Ghost for the
16261 -- purposes of legality checks and removal of ignored Ghost code.
16263 Mark_Ghost_Pragma
(N
, Pack_Id
);
16265 -- Chain the pragma on the contract for further processing by
16266 -- Analyze_Initial_Condition_In_Decl_Part.
16268 Add_Contract_Item
(N
, Pack_Id
);
16270 -- The legality checks of pragmas Abstract_State, Initializes, and
16271 -- Initial_Condition are affected by the SPARK mode in effect. In
16272 -- addition, these three pragmas are subject to an inherent order:
16274 -- 1) Abstract_State
16276 -- 3) Initial_Condition
16278 -- Analyze all these pragmas in the order outlined above
16280 Analyze_If_Present
(Pragma_SPARK_Mode
);
16281 Analyze_If_Present
(Pragma_Abstract_State
);
16282 Analyze_If_Present
(Pragma_Initializes
);
16283 end Initial_Condition
;
16285 ------------------------
16286 -- Initialize_Scalars --
16287 ------------------------
16289 -- pragma Initialize_Scalars;
16291 when Pragma_Initialize_Scalars
=>
16293 Check_Arg_Count
(0);
16294 Check_Valid_Configuration_Pragma
;
16295 Check_Restriction
(No_Initialize_Scalars
, N
);
16297 -- Initialize_Scalars creates false positives in CodePeer, and
16298 -- incorrect negative results in GNATprove mode, so ignore this
16299 -- pragma in these modes.
16301 if not Restriction_Active
(No_Initialize_Scalars
)
16302 and then not (CodePeer_Mode
or GNATprove_Mode
)
16304 Init_Or_Norm_Scalars
:= True;
16305 Initialize_Scalars
:= True;
16312 -- pragma Initializes (INITIALIZATION_LIST);
16314 -- INITIALIZATION_LIST ::=
16316 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16318 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16323 -- | (INPUT {, INPUT})
16327 -- Characteristics:
16329 -- * Analysis - The annotation undergoes initial checks to verify
16330 -- the legal placement and context. Secondary checks preanalyze the
16333 -- Analyze_Initializes_In_Decl_Part
16335 -- * Expansion - None.
16337 -- * Template - The annotation utilizes the generic template of the
16338 -- related package declaration.
16340 -- * Globals - Capture of global references must occur after full
16343 -- * Instance - The annotation is instantiated automatically when
16344 -- the related generic package is instantiated.
16346 when Pragma_Initializes
=> Initializes
: declare
16347 Pack_Decl
: Node_Id
;
16348 Pack_Id
: Entity_Id
;
16352 Check_No_Identifiers
;
16353 Check_Arg_Count
(1);
16355 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16357 -- Ensure the proper placement of the pragma. Initializes must be
16358 -- associated with a package declaration.
16360 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16361 N_Package_Declaration
)
16365 -- Otherwise the pragma is associated with an illegal construc
16372 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16374 -- A pragma that applies to a Ghost entity becomes Ghost for the
16375 -- purposes of legality checks and removal of ignored Ghost code.
16377 Mark_Ghost_Pragma
(N
, Pack_Id
);
16378 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
16380 -- Chain the pragma on the contract for further processing by
16381 -- Analyze_Initializes_In_Decl_Part.
16383 Add_Contract_Item
(N
, Pack_Id
);
16385 -- The legality checks of pragmas Abstract_State, Initializes, and
16386 -- Initial_Condition are affected by the SPARK mode in effect. In
16387 -- addition, these three pragmas are subject to an inherent order:
16389 -- 1) Abstract_State
16391 -- 3) Initial_Condition
16393 -- Analyze all these pragmas in the order outlined above
16395 Analyze_If_Present
(Pragma_SPARK_Mode
);
16396 Analyze_If_Present
(Pragma_Abstract_State
);
16397 Analyze_If_Present
(Pragma_Initial_Condition
);
16404 -- pragma Inline ( NAME {, NAME} );
16406 when Pragma_Inline
=>
16408 -- Pragma always active unless in GNATprove mode. It is disabled
16409 -- in GNATprove mode because frontend inlining is applied
16410 -- independently of pragmas Inline and Inline_Always for
16411 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16414 if not GNATprove_Mode
then
16416 -- Inline status is Enabled if option -gnatn is specified.
16417 -- However this status determines only the value of the
16418 -- Is_Inlined flag on the subprogram and does not prevent
16419 -- the pragma itself from being recorded for later use,
16420 -- in particular for a later modification of Is_Inlined
16421 -- independently of the -gnatn option.
16423 -- In other words, if -gnatn is specified for a unit, then
16424 -- all Inline pragmas processed for the compilation of this
16425 -- unit, including those in the spec of other units, are
16426 -- activated, so subprograms will be inlined across units.
16428 -- If -gnatn is not specified, no Inline pragma is activated
16429 -- here, which means that subprograms will not be inlined
16430 -- across units. The Is_Inlined flag will nevertheless be
16431 -- set later when bodies are analyzed, so subprograms will
16432 -- be inlined within the unit.
16434 if Inline_Active
then
16435 Process_Inline
(Enabled
);
16437 Process_Inline
(Disabled
);
16441 -------------------
16442 -- Inline_Always --
16443 -------------------
16445 -- pragma Inline_Always ( NAME {, NAME} );
16447 when Pragma_Inline_Always
=>
16450 -- Pragma always active unless in CodePeer mode or GNATprove
16451 -- mode. It is disabled in CodePeer mode because inlining is
16452 -- not helpful, and enabling it caused walk order issues. It
16453 -- is disabled in GNATprove mode because frontend inlining is
16454 -- applied independently of pragmas Inline and Inline_Always for
16455 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16458 if not CodePeer_Mode
and not GNATprove_Mode
then
16459 Process_Inline
(Enabled
);
16462 --------------------
16463 -- Inline_Generic --
16464 --------------------
16466 -- pragma Inline_Generic (NAME {, NAME});
16468 when Pragma_Inline_Generic
=>
16470 Process_Generic_List
;
16472 ----------------------
16473 -- Inspection_Point --
16474 ----------------------
16476 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16478 when Pragma_Inspection_Point
=> Inspection_Point
: declare
16485 if Arg_Count
> 0 then
16488 Exp
:= Get_Pragma_Arg
(Arg
);
16491 if not Is_Entity_Name
(Exp
)
16492 or else not Is_Object
(Entity
(Exp
))
16494 Error_Pragma_Arg
("object name required", Arg
);
16498 exit when No
(Arg
);
16501 end Inspection_Point
;
16507 -- pragma Interface (
16508 -- [ Convention =>] convention_IDENTIFIER,
16509 -- [ Entity =>] LOCAL_NAME
16510 -- [, [External_Name =>] static_string_EXPRESSION ]
16511 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16513 when Pragma_Interface
=>
16518 Name_External_Name
,
16520 Check_At_Least_N_Arguments
(2);
16521 Check_At_Most_N_Arguments
(4);
16522 Process_Import_Or_Interface
;
16524 -- In Ada 2005, the permission to use Interface (a reserved word)
16525 -- as a pragma name is considered an obsolescent feature, and this
16526 -- pragma was already obsolescent in Ada 95.
16528 if Ada_Version
>= Ada_95
then
16530 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16532 if Warn_On_Obsolescent_Feature
then
16534 ("pragma Interface is an obsolescent feature?j?", N
);
16536 ("|use pragma Import instead?j?", N
);
16540 --------------------
16541 -- Interface_Name --
16542 --------------------
16544 -- pragma Interface_Name (
16545 -- [ Entity =>] LOCAL_NAME
16546 -- [,[External_Name =>] static_string_EXPRESSION ]
16547 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16549 when Pragma_Interface_Name
=> Interface_Name
: declare
16551 Def_Id
: Entity_Id
;
16552 Hom_Id
: Entity_Id
;
16558 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
16559 Check_At_Least_N_Arguments
(2);
16560 Check_At_Most_N_Arguments
(3);
16561 Id
:= Get_Pragma_Arg
(Arg1
);
16564 -- This is obsolete from Ada 95 on, but it is an implementation
16565 -- defined pragma, so we do not consider that it violates the
16566 -- restriction (No_Obsolescent_Features).
16568 if Ada_Version
>= Ada_95
then
16569 if Warn_On_Obsolescent_Feature
then
16571 ("pragma Interface_Name is an obsolescent feature?j?", N
);
16573 ("|use pragma Import instead?j?", N
);
16577 if not Is_Entity_Name
(Id
) then
16579 ("first argument for pragma% must be entity name", Arg1
);
16580 elsif Etype
(Id
) = Any_Type
then
16583 Def_Id
:= Entity
(Id
);
16586 -- Special DEC-compatible processing for the object case, forces
16587 -- object to be imported.
16589 if Ekind
(Def_Id
) = E_Variable
then
16590 Kill_Size_Check_Code
(Def_Id
);
16591 Note_Possible_Modification
(Id
, Sure
=> False);
16593 -- Initialization is not allowed for imported variable
16595 if Present
(Expression
(Parent
(Def_Id
)))
16596 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
16598 Error_Msg_Sloc
:= Sloc
(Def_Id
);
16600 ("no initialization allowed for declaration of& #",
16604 -- For compatibility, support VADS usage of providing both
16605 -- pragmas Interface and Interface_Name to obtain the effect
16606 -- of a single Import pragma.
16608 if Is_Imported
(Def_Id
)
16609 and then Present
(First_Rep_Item
(Def_Id
))
16610 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
16611 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
16616 Set_Imported
(Def_Id
);
16619 Set_Is_Public
(Def_Id
);
16620 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16623 -- Otherwise must be subprogram
16625 elsif not Is_Subprogram
(Def_Id
) then
16627 ("argument of pragma% is not subprogram", Arg1
);
16630 Check_At_Most_N_Arguments
(3);
16634 -- Loop through homonyms
16637 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
16639 if Is_Imported
(Def_Id
) then
16640 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16644 exit when From_Aspect_Specification
(N
);
16645 Hom_Id
:= Homonym
(Hom_Id
);
16647 exit when No
(Hom_Id
)
16648 or else Scope
(Hom_Id
) /= Current_Scope
;
16653 ("argument of pragma% is not imported subprogram",
16657 end Interface_Name
;
16659 -----------------------
16660 -- Interrupt_Handler --
16661 -----------------------
16663 -- pragma Interrupt_Handler (handler_NAME);
16665 when Pragma_Interrupt_Handler
=>
16666 Check_Ada_83_Warning
;
16667 Check_Arg_Count
(1);
16668 Check_No_Identifiers
;
16670 if No_Run_Time_Mode
then
16671 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
16673 Check_Interrupt_Or_Attach_Handler
;
16674 Process_Interrupt_Or_Attach_Handler
;
16677 ------------------------
16678 -- Interrupt_Priority --
16679 ------------------------
16681 -- pragma Interrupt_Priority [(EXPRESSION)];
16683 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
16684 P
: constant Node_Id
:= Parent
(N
);
16689 Check_Ada_83_Warning
;
16691 if Arg_Count
/= 0 then
16692 Arg
:= Get_Pragma_Arg
(Arg1
);
16693 Check_Arg_Count
(1);
16694 Check_No_Identifiers
;
16696 -- The expression must be analyzed in the special manner
16697 -- described in "Handling of Default and Per-Object
16698 -- Expressions" in sem.ads.
16700 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
16703 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
16708 Ent
:= Defining_Identifier
(Parent
(P
));
16710 -- Check duplicate pragma before we chain the pragma in the Rep
16711 -- Item chain of Ent.
16713 Check_Duplicate_Pragma
(Ent
);
16714 Record_Rep_Item
(Ent
, N
);
16716 -- Check the No_Task_At_Interrupt_Priority restriction
16718 if Nkind
(P
) = N_Task_Definition
then
16719 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16722 end Interrupt_Priority
;
16724 ---------------------
16725 -- Interrupt_State --
16726 ---------------------
16728 -- pragma Interrupt_State (
16729 -- [Name =>] INTERRUPT_ID,
16730 -- [State =>] INTERRUPT_STATE);
16732 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16733 -- INTERRUPT_STATE => System | Runtime | User
16735 -- Note: if the interrupt id is given as an identifier, then it must
16736 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16737 -- given as a static integer expression which must be in the range of
16738 -- Ada.Interrupts.Interrupt_ID.
16740 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16741 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16742 -- This is the entity Ada.Interrupts.Interrupt_ID;
16744 State_Type
: Character;
16745 -- Set to 's'/'r'/'u' for System/Runtime/User
16748 -- Index to entry in Interrupt_States table
16751 -- Value of interrupt
16753 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16754 -- The first argument to the pragma
16756 Int_Ent
: Entity_Id
;
16757 -- Interrupt entity in Ada.Interrupts.Names
16761 Check_Arg_Order
((Name_Name
, Name_State
));
16762 Check_Arg_Count
(2);
16764 Check_Optional_Identifier
(Arg1
, Name_Name
);
16765 Check_Optional_Identifier
(Arg2
, Name_State
);
16766 Check_Arg_Is_Identifier
(Arg2
);
16768 -- First argument is identifier
16770 if Nkind
(Arg1X
) = N_Identifier
then
16772 -- Search list of names in Ada.Interrupts.Names
16774 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16776 if No
(Int_Ent
) then
16777 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16779 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16780 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16784 Next_Entity
(Int_Ent
);
16787 -- First argument is not an identifier, so it must be a static
16788 -- expression of type Ada.Interrupts.Interrupt_ID.
16791 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16792 Int_Val
:= Expr_Value
(Arg1X
);
16794 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16796 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
16799 ("value not in range of type "
16800 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
16806 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16807 when Name_Runtime
=> State_Type
:= 'r';
16808 when Name_System
=> State_Type
:= 's';
16809 when Name_User
=> State_Type
:= 'u';
16812 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
16815 -- Check if entry is already stored
16817 IST_Num
:= Interrupt_States
.First
;
16819 -- If entry not found, add it
16821 if IST_Num
> Interrupt_States
.Last
then
16822 Interrupt_States
.Append
16823 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
16824 Interrupt_State
=> State_Type
,
16825 Pragma_Loc
=> Loc
));
16828 -- Case of entry for the same entry
16830 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
16833 -- If state matches, done, no need to make redundant entry
16836 State_Type
= Interrupt_States
.Table
(IST_Num
).
16839 -- Otherwise if state does not match, error
16842 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
16844 ("state conflicts with that given #", Arg2
);
16848 IST_Num
:= IST_Num
+ 1;
16850 end Interrupt_State
;
16856 -- pragma Invariant
16857 -- ([Entity =>] type_LOCAL_NAME,
16858 -- [Check =>] EXPRESSION
16859 -- [,[Message =>] String_Expression]);
16861 when Pragma_Invariant
=> Invariant
: declare
16868 Check_At_Least_N_Arguments
(2);
16869 Check_At_Most_N_Arguments
(3);
16870 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16871 Check_Optional_Identifier
(Arg2
, Name_Check
);
16873 if Arg_Count
= 3 then
16874 Check_Optional_Identifier
(Arg3
, Name_Message
);
16875 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
16878 Check_Arg_Is_Local_Name
(Arg1
);
16880 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
16881 Find_Type
(Typ_Arg
);
16882 Typ
:= Entity
(Typ_Arg
);
16884 -- Nothing to do of the related type is erroneous in some way
16886 if Typ
= Any_Type
then
16889 -- AI12-0041: Invariants are allowed in interface types
16891 elsif Is_Interface
(Typ
) then
16894 -- An invariant must apply to a private type, or appear in the
16895 -- private part of a package spec and apply to a completion.
16896 -- a class-wide invariant can only appear on a private declaration
16897 -- or private extension, not a completion.
16899 -- A [class-wide] invariant may be associated a [limited] private
16900 -- type or a private extension.
16902 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
16904 E_Record_Type_With_Private
)
16908 -- A non-class-wide invariant may be associated with the full view
16909 -- of a [limited] private type or a private extension.
16911 elsif Has_Private_Declaration
(Typ
)
16912 and then not Class_Present
(N
)
16916 -- A class-wide invariant may appear on the partial view only
16918 elsif Class_Present
(N
) then
16920 ("pragma % only allowed for private type", Arg1
);
16923 -- A regular invariant may appear on both views
16927 ("pragma % only allowed for private type or corresponding "
16928 & "full view", Arg1
);
16932 -- An invariant associated with an abstract type (this includes
16933 -- interfaces) must be class-wide.
16935 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
16937 ("pragma % not allowed for abstract type", Arg1
);
16941 -- A pragma that applies to a Ghost entity becomes Ghost for the
16942 -- purposes of legality checks and removal of ignored Ghost code.
16944 Mark_Ghost_Pragma
(N
, Typ
);
16946 -- The pragma defines a type-specific invariant, the type is said
16947 -- to have invariants of its "own".
16949 Set_Has_Own_Invariants
(Typ
);
16951 -- If the invariant is class-wide, then it can be inherited by
16952 -- derived or interface implementing types. The type is said to
16953 -- have "inheritable" invariants.
16955 if Class_Present
(N
) then
16956 Set_Has_Inheritable_Invariants
(Typ
);
16959 -- Chain the pragma on to the rep item chain, for processing when
16960 -- the type is frozen.
16962 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16964 -- Create the declaration of the invariant procedure which will
16965 -- verify the invariant at run-time. Note that interfaces do not
16966 -- carry such a declaration.
16968 Build_Invariant_Procedure_Declaration
(Typ
);
16975 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16977 when Pragma_Keep_Names
=> Keep_Names
: declare
16982 Check_Arg_Count
(1);
16983 Check_Optional_Identifier
(Arg1
, Name_On
);
16984 Check_Arg_Is_Local_Name
(Arg1
);
16986 Arg
:= Get_Pragma_Arg
(Arg1
);
16989 if Etype
(Arg
) = Any_Type
then
16993 if not Is_Entity_Name
(Arg
)
16994 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16997 ("pragma% requires a local enumeration type", Arg1
);
17000 Set_Discard_Names
(Entity
(Arg
), False);
17007 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17009 when Pragma_License
=>
17012 -- Do not analyze pragma any further in CodePeer mode, to avoid
17013 -- extraneous errors in this implementation-dependent pragma,
17014 -- which has a different profile on other compilers.
17016 if CodePeer_Mode
then
17020 Check_Arg_Count
(1);
17021 Check_No_Identifiers
;
17022 Check_Valid_Configuration_Pragma
;
17023 Check_Arg_Is_Identifier
(Arg1
);
17026 Sind
: constant Source_File_Index
:=
17027 Source_Index
(Current_Sem_Unit
);
17030 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17032 Set_License
(Sind
, GPL
);
17034 when Name_Modified_GPL
=>
17035 Set_License
(Sind
, Modified_GPL
);
17037 when Name_Restricted
=>
17038 Set_License
(Sind
, Restricted
);
17040 when Name_Unrestricted
=>
17041 Set_License
(Sind
, Unrestricted
);
17044 Error_Pragma_Arg
("invalid license name", Arg1
);
17052 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17054 when Pragma_Link_With
=> Link_With
: declare
17060 if Operating_Mode
= Generate_Code
17061 and then In_Extended_Main_Source_Unit
(N
)
17063 Check_At_Least_N_Arguments
(1);
17064 Check_No_Identifiers
;
17065 Check_Is_In_Decl_Part_Or_Package_Spec
;
17066 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17070 while Present
(Arg
) loop
17071 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17073 -- Store argument, converting sequences of spaces to a
17074 -- single null character (this is one of the differences
17075 -- in processing between Link_With and Linker_Options).
17077 Arg_Store
: declare
17078 C
: constant Char_Code
:= Get_Char_Code
(' ');
17079 S
: constant String_Id
:=
17080 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17081 L
: constant Nat
:= String_Length
(S
);
17084 procedure Skip_Spaces
;
17085 -- Advance F past any spaces
17091 procedure Skip_Spaces
is
17093 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17098 -- Start of processing for Arg_Store
17101 Skip_Spaces
; -- skip leading spaces
17103 -- Loop through characters, changing any embedded
17104 -- sequence of spaces to a single null character (this
17105 -- is how Link_With/Linker_Options differ)
17108 if Get_String_Char
(S
, F
) = C
then
17111 Store_String_Char
(ASCII
.NUL
);
17114 Store_String_Char
(Get_String_Char
(S
, F
));
17122 if Present
(Arg
) then
17123 Store_String_Char
(ASCII
.NUL
);
17127 Store_Linker_Option_String
(End_String
);
17135 -- pragma Linker_Alias (
17136 -- [Entity =>] LOCAL_NAME
17137 -- [Target =>] static_string_EXPRESSION);
17139 when Pragma_Linker_Alias
=>
17141 Check_Arg_Order
((Name_Entity
, Name_Target
));
17142 Check_Arg_Count
(2);
17143 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17144 Check_Optional_Identifier
(Arg2
, Name_Target
);
17145 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17146 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17148 -- The only processing required is to link this item on to the
17149 -- list of rep items for the given entity. This is accomplished
17150 -- by the call to Rep_Item_Too_Late (when no error is detected
17151 -- and False is returned).
17153 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17156 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17159 ------------------------
17160 -- Linker_Constructor --
17161 ------------------------
17163 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17165 -- Code is shared with Linker_Destructor
17167 -----------------------
17168 -- Linker_Destructor --
17169 -----------------------
17171 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17173 when Pragma_Linker_Constructor
17174 | Pragma_Linker_Destructor
17176 Linker_Constructor
: declare
17182 Check_Arg_Count
(1);
17183 Check_No_Identifiers
;
17184 Check_Arg_Is_Local_Name
(Arg1
);
17185 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17187 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17189 if not Is_Library_Level_Entity
(Proc
) then
17191 ("argument for pragma% must be library level entity", Arg1
);
17194 -- The only processing required is to link this item on to the
17195 -- list of rep items for the given entity. This is accomplished
17196 -- by the call to Rep_Item_Too_Late (when no error is detected
17197 -- and False is returned).
17199 if Rep_Item_Too_Late
(Proc
, N
) then
17202 Set_Has_Gigi_Rep_Item
(Proc
);
17204 end Linker_Constructor
;
17206 --------------------
17207 -- Linker_Options --
17208 --------------------
17210 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17212 when Pragma_Linker_Options
=> Linker_Options
: declare
17216 Check_Ada_83_Warning
;
17217 Check_No_Identifiers
;
17218 Check_Arg_Count
(1);
17219 Check_Is_In_Decl_Part_Or_Package_Spec
;
17220 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17221 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17224 while Present
(Arg
) loop
17225 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17226 Store_String_Char
(ASCII
.NUL
);
17228 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17232 if Operating_Mode
= Generate_Code
17233 and then In_Extended_Main_Source_Unit
(N
)
17235 Store_Linker_Option_String
(End_String
);
17237 end Linker_Options
;
17239 --------------------
17240 -- Linker_Section --
17241 --------------------
17243 -- pragma Linker_Section (
17244 -- [Entity =>] LOCAL_NAME
17245 -- [Section =>] static_string_EXPRESSION);
17247 when Pragma_Linker_Section
=> Linker_Section
: declare
17252 Ghost_Error_Posted
: Boolean := False;
17253 -- Flag set when an error concerning the illegal mix of Ghost and
17254 -- non-Ghost subprograms is emitted.
17256 Ghost_Id
: Entity_Id
:= Empty
;
17257 -- The entity of the first Ghost subprogram encountered while
17258 -- processing the arguments of the pragma.
17262 Check_Arg_Order
((Name_Entity
, Name_Section
));
17263 Check_Arg_Count
(2);
17264 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17265 Check_Optional_Identifier
(Arg2
, Name_Section
);
17266 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17267 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17269 -- Check kind of entity
17271 Arg
:= Get_Pragma_Arg
(Arg1
);
17272 Ent
:= Entity
(Arg
);
17274 case Ekind
(Ent
) is
17276 -- Objects (constants and variables) and types. For these cases
17277 -- all we need to do is to set the Linker_Section_pragma field,
17278 -- checking that we do not have a duplicate.
17284 LPE
:= Linker_Section_Pragma
(Ent
);
17286 if Present
(LPE
) then
17287 Error_Msg_Sloc
:= Sloc
(LPE
);
17289 ("Linker_Section already specified for &#", Arg1
, Ent
);
17292 Set_Linker_Section_Pragma
(Ent
, N
);
17294 -- A pragma that applies to a Ghost entity becomes Ghost for
17295 -- the purposes of legality checks and removal of ignored
17298 Mark_Ghost_Pragma
(N
, Ent
);
17302 when Subprogram_Kind
=>
17304 -- Aspect case, entity already set
17306 if From_Aspect_Specification
(N
) then
17307 Set_Linker_Section_Pragma
17308 (Entity
(Corresponding_Aspect
(N
)), N
);
17310 -- Pragma case, we must climb the homonym chain, but skip
17311 -- any for which the linker section is already set.
17315 if No
(Linker_Section_Pragma
(Ent
)) then
17316 Set_Linker_Section_Pragma
(Ent
, N
);
17318 -- A pragma that applies to a Ghost entity becomes
17319 -- Ghost for the purposes of legality checks and
17320 -- removal of ignored Ghost code.
17322 Mark_Ghost_Pragma
(N
, Ent
);
17324 -- Capture the entity of the first Ghost subprogram
17325 -- being processed for error detection purposes.
17327 if Is_Ghost_Entity
(Ent
) then
17328 if No
(Ghost_Id
) then
17332 -- Otherwise the subprogram is non-Ghost. It is
17333 -- illegal to mix references to Ghost and non-Ghost
17334 -- entities (SPARK RM 6.9).
17336 elsif Present
(Ghost_Id
)
17337 and then not Ghost_Error_Posted
17339 Ghost_Error_Posted
:= True;
17341 Error_Msg_Name_1
:= Pname
;
17343 ("pragma % cannot mention ghost and "
17344 & "non-ghost subprograms", N
);
17346 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17348 ("\& # declared as ghost", N
, Ghost_Id
);
17350 Error_Msg_Sloc
:= Sloc
(Ent
);
17352 ("\& # declared as non-ghost", N
, Ent
);
17356 Ent
:= Homonym
(Ent
);
17358 or else Scope
(Ent
) /= Current_Scope
;
17362 -- All other cases are illegal
17366 ("pragma% applies only to objects, subprograms, and types",
17369 end Linker_Section
;
17375 -- pragma List (On | Off)
17377 -- There is nothing to do here, since we did all the processing for
17378 -- this pragma in Par.Prag (so that it works properly even in syntax
17381 when Pragma_List
=>
17388 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17390 when Pragma_Lock_Free
=> Lock_Free
: declare
17391 P
: constant Node_Id
:= Parent
(N
);
17397 Check_No_Identifiers
;
17398 Check_At_Most_N_Arguments
(1);
17400 -- Protected definition case
17402 if Nkind
(P
) = N_Protected_Definition
then
17403 Ent
:= Defining_Identifier
(Parent
(P
));
17407 if Arg_Count
= 1 then
17408 Arg
:= Get_Pragma_Arg
(Arg1
);
17409 Val
:= Is_True
(Static_Boolean
(Arg
));
17411 -- No arguments (expression is considered to be True)
17417 -- Check duplicate pragma before we chain the pragma in the Rep
17418 -- Item chain of Ent.
17420 Check_Duplicate_Pragma
(Ent
);
17421 Record_Rep_Item
(Ent
, N
);
17422 Set_Uses_Lock_Free
(Ent
, Val
);
17424 -- Anything else is incorrect placement
17431 --------------------
17432 -- Locking_Policy --
17433 --------------------
17435 -- pragma Locking_Policy (policy_IDENTIFIER);
17437 when Pragma_Locking_Policy
=> declare
17438 subtype LP_Range
is Name_Id
17439 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
17444 Check_Ada_83_Warning
;
17445 Check_Arg_Count
(1);
17446 Check_No_Identifiers
;
17447 Check_Arg_Is_Locking_Policy
(Arg1
);
17448 Check_Valid_Configuration_Pragma
;
17449 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17452 when Name_Ceiling_Locking
=> LP
:= 'C';
17453 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
17454 when Name_Inheritance_Locking
=> LP
:= 'I';
17457 if Locking_Policy
/= ' '
17458 and then Locking_Policy
/= LP
17460 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17461 Error_Pragma
("locking policy incompatible with policy#");
17463 -- Set new policy, but always preserve System_Location since we
17464 -- like the error message with the run time name.
17467 Locking_Policy
:= LP
;
17469 if Locking_Policy_Sloc
/= System_Location
then
17470 Locking_Policy_Sloc
:= Loc
;
17475 -------------------
17476 -- Loop_Optimize --
17477 -------------------
17479 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17481 -- OPTIMIZATION_HINT ::=
17482 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17484 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
17489 Check_At_Least_N_Arguments
(1);
17490 Check_No_Identifiers
;
17492 Hint
:= First
(Pragma_Argument_Associations
(N
));
17493 while Present
(Hint
) loop
17494 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
17502 Check_Loop_Pragma_Placement
;
17509 -- pragma Loop_Variant
17510 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17512 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17514 -- CHANGE_DIRECTION ::= Increases | Decreases
17516 when Pragma_Loop_Variant
=> Loop_Variant
: declare
17521 Check_At_Least_N_Arguments
(1);
17522 Check_Loop_Pragma_Placement
;
17524 -- Process all increasing / decreasing expressions
17526 Variant
:= First
(Pragma_Argument_Associations
(N
));
17527 while Present
(Variant
) loop
17528 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
17531 Error_Pragma_Arg
("wrong change modifier", Variant
);
17534 Preanalyze_Assert_Expression
17535 (Expression
(Variant
), Any_Discrete
);
17541 -----------------------
17542 -- Machine_Attribute --
17543 -----------------------
17545 -- pragma Machine_Attribute (
17546 -- [Entity =>] LOCAL_NAME,
17547 -- [Attribute_Name =>] static_string_EXPRESSION
17548 -- [, [Info =>] static_EXPRESSION] );
17550 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
17551 Def_Id
: Entity_Id
;
17555 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
17557 if Arg_Count
= 3 then
17558 Check_Optional_Identifier
(Arg3
, Name_Info
);
17559 Check_Arg_Is_OK_Static_Expression
(Arg3
);
17561 Check_Arg_Count
(2);
17564 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17565 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
17566 Check_Arg_Is_Local_Name
(Arg1
);
17567 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17568 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17570 if Is_Access_Type
(Def_Id
) then
17571 Def_Id
:= Designated_Type
(Def_Id
);
17574 if Rep_Item_Too_Early
(Def_Id
, N
) then
17578 Def_Id
:= Underlying_Type
(Def_Id
);
17580 -- The only processing required is to link this item on to the
17581 -- list of rep items for the given entity. This is accomplished
17582 -- by the call to Rep_Item_Too_Late (when no error is detected
17583 -- and False is returned).
17585 if Rep_Item_Too_Late
(Def_Id
, N
) then
17588 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17590 end Machine_Attribute
;
17597 -- (MAIN_OPTION [, MAIN_OPTION]);
17600 -- [STACK_SIZE =>] static_integer_EXPRESSION
17601 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17602 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17604 when Pragma_Main
=> Main
: declare
17605 Args
: Args_List
(1 .. 3);
17606 Names
: constant Name_List
(1 .. 3) := (
17608 Name_Task_Stack_Size_Default
,
17609 Name_Time_Slicing_Enabled
);
17615 Gather_Associations
(Names
, Args
);
17617 for J
in 1 .. 2 loop
17618 if Present
(Args
(J
)) then
17619 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17623 if Present
(Args
(3)) then
17624 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
17628 while Present
(Nod
) loop
17629 if Nkind
(Nod
) = N_Pragma
17630 and then Pragma_Name
(Nod
) = Name_Main
17632 Error_Msg_Name_1
:= Pname
;
17633 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17644 -- pragma Main_Storage
17645 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17647 -- MAIN_STORAGE_OPTION ::=
17648 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17649 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17651 when Pragma_Main_Storage
=> Main_Storage
: declare
17652 Args
: Args_List
(1 .. 2);
17653 Names
: constant Name_List
(1 .. 2) := (
17654 Name_Working_Storage
,
17661 Gather_Associations
(Names
, Args
);
17663 for J
in 1 .. 2 loop
17664 if Present
(Args
(J
)) then
17665 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17669 Check_In_Main_Program
;
17672 while Present
(Nod
) loop
17673 if Nkind
(Nod
) = N_Pragma
17674 and then Pragma_Name
(Nod
) = Name_Main_Storage
17676 Error_Msg_Name_1
:= Pname
;
17677 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17684 ----------------------
17685 -- Max_Queue_Length --
17686 ----------------------
17688 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
17690 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
17692 Entry_Decl
: Node_Id
;
17693 Entry_Id
: Entity_Id
;
17698 Check_Arg_Count
(1);
17701 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
17703 -- Entry declaration
17705 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
17707 -- Entry illegally within a task
17709 if Nkind
(Parent
(N
)) = N_Task_Definition
then
17710 Error_Pragma
("pragma % cannot apply to task entries");
17714 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
17716 -- Otherwise the pragma is associated with an illegal construct
17719 Error_Pragma
("pragma % must apply to a protected entry");
17723 -- Mark the pragma as Ghost if the related subprogram is also
17724 -- Ghost. This also ensures that any expansion performed further
17725 -- below will produce Ghost nodes.
17727 Mark_Ghost_Pragma
(N
, Entry_Id
);
17729 -- Analyze the Integer expression
17731 Arg
:= Get_Pragma_Arg
(Arg1
);
17732 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
17734 Val
:= Expr_Value
(Arg
);
17738 ("argument for pragma% must be positive", Arg1
);
17740 elsif not UI_Is_In_Int_Range
(Val
) then
17742 ("argument for pragma% out of range of Integer", Arg1
);
17746 -- Manually substitute the expression value of the pragma argument
17747 -- if it's not an integer literal because this is not taken care
17748 -- of automatically elsewhere.
17750 if Nkind
(Arg
) /= N_Integer_Literal
then
17751 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
17754 Record_Rep_Item
(Entry_Id
, N
);
17755 end Max_Queue_Length
;
17761 -- pragma Memory_Size (NUMERIC_LITERAL)
17763 when Pragma_Memory_Size
=>
17766 -- Memory size is simply ignored
17768 Check_No_Identifiers
;
17769 Check_Arg_Count
(1);
17770 Check_Arg_Is_Integer_Literal
(Arg1
);
17778 -- The only correct use of this pragma is on its own in a file, in
17779 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17780 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17781 -- check for a file containing nothing but a No_Body pragma). If we
17782 -- attempt to process it during normal semantics processing, it means
17783 -- it was misplaced.
17785 when Pragma_No_Body
=>
17789 -----------------------------
17790 -- No_Elaboration_Code_All --
17791 -----------------------------
17793 -- pragma No_Elaboration_Code_All;
17795 when Pragma_No_Elaboration_Code_All
=>
17797 Check_Valid_Library_Unit_Pragma
;
17799 if Nkind
(N
) = N_Null_Statement
then
17803 -- Must appear for a spec or generic spec
17805 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
17806 N_Generic_Package_Declaration
,
17807 N_Generic_Subprogram_Declaration
,
17808 N_Package_Declaration
,
17809 N_Subprogram_Declaration
)
17813 ("pragma% can only occur for package "
17814 & "or subprogram spec"));
17817 -- Set flag in unit table
17819 Set_No_Elab_Code_All
(Current_Sem_Unit
);
17821 -- Set restriction No_Elaboration_Code if this is the main unit
17823 if Current_Sem_Unit
= Main_Unit
then
17824 Set_Restriction
(No_Elaboration_Code
, N
);
17827 -- If we are in the main unit or in an extended main source unit,
17828 -- then we also add it to the configuration restrictions so that
17829 -- it will apply to all units in the extended main source.
17831 if Current_Sem_Unit
= Main_Unit
17832 or else In_Extended_Main_Source_Unit
(N
)
17834 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
17837 -- If in main extended unit, activate transitive with test
17839 if In_Extended_Main_Source_Unit
(N
) then
17840 Opt
.No_Elab_Code_All_Pragma
:= N
;
17847 -- pragma No_Inline ( NAME {, NAME} );
17849 when Pragma_No_Inline
=>
17851 Process_Inline
(Suppressed
);
17857 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17859 when Pragma_No_Return
=> No_Return
: declare
17865 Ghost_Error_Posted
: Boolean := False;
17866 -- Flag set when an error concerning the illegal mix of Ghost and
17867 -- non-Ghost subprograms is emitted.
17869 Ghost_Id
: Entity_Id
:= Empty
;
17870 -- The entity of the first Ghost procedure encountered while
17871 -- processing the arguments of the pragma.
17875 Check_At_Least_N_Arguments
(1);
17877 -- Loop through arguments of pragma
17880 while Present
(Arg
) loop
17881 Check_Arg_Is_Local_Name
(Arg
);
17882 Id
:= Get_Pragma_Arg
(Arg
);
17885 if not Is_Entity_Name
(Id
) then
17886 Error_Pragma_Arg
("entity name required", Arg
);
17889 if Etype
(Id
) = Any_Type
then
17893 -- Loop to find matching procedures
17899 and then Scope
(E
) = Current_Scope
17901 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
17904 -- A pragma that applies to a Ghost entity becomes Ghost
17905 -- for the purposes of legality checks and removal of
17906 -- ignored Ghost code.
17908 Mark_Ghost_Pragma
(N
, E
);
17910 -- Capture the entity of the first Ghost procedure being
17911 -- processed for error detection purposes.
17913 if Is_Ghost_Entity
(E
) then
17914 if No
(Ghost_Id
) then
17918 -- Otherwise the subprogram is non-Ghost. It is illegal
17919 -- to mix references to Ghost and non-Ghost entities
17922 elsif Present
(Ghost_Id
)
17923 and then not Ghost_Error_Posted
17925 Ghost_Error_Posted
:= True;
17927 Error_Msg_Name_1
:= Pname
;
17929 ("pragma % cannot mention ghost and non-ghost "
17930 & "procedures", N
);
17932 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17933 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
17935 Error_Msg_Sloc
:= Sloc
(E
);
17936 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
17939 -- Set flag on any alias as well
17941 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
17942 Set_No_Return
(Alias
(E
));
17948 exit when From_Aspect_Specification
(N
);
17952 -- If entity in not in current scope it may be the enclosing
17953 -- suprogram body to which the aspect applies.
17956 if Entity
(Id
) = Current_Scope
17957 and then From_Aspect_Specification
(N
)
17959 Set_No_Return
(Entity
(Id
));
17961 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
17973 -- pragma No_Run_Time;
17975 -- Note: this pragma is retained for backwards compatibility. See
17976 -- body of Rtsfind for full details on its handling.
17978 when Pragma_No_Run_Time
=>
17980 Check_Valid_Configuration_Pragma
;
17981 Check_Arg_Count
(0);
17983 -- Remove backward compatibility if Build_Type is FSF or GPL and
17984 -- generate a warning.
17987 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
17990 Error_Pragma
("pragma% is ignored, has no effect??");
17992 No_Run_Time_Mode
:= True;
17993 Configurable_Run_Time_Mode
:= True;
17995 -- Set Duration to 32 bits if word size is 32
17997 if Ttypes
.System_Word_Size
= 32 then
17998 Duration_32_Bits_On_Target
:= True;
18001 -- Set appropriate restrictions
18003 Set_Restriction
(No_Finalization
, N
);
18004 Set_Restriction
(No_Exception_Handlers
, N
);
18005 Set_Restriction
(Max_Tasks
, N
, 0);
18006 Set_Restriction
(No_Tasking
, N
);
18010 -----------------------
18011 -- No_Tagged_Streams --
18012 -----------------------
18014 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18016 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
18022 Check_At_Most_N_Arguments
(1);
18024 -- One argument case
18026 if Arg_Count
= 1 then
18027 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18028 Check_Arg_Is_Local_Name
(Arg1
);
18029 E_Id
:= Get_Pragma_Arg
(Arg1
);
18031 if Etype
(E_Id
) = Any_Type
then
18035 E
:= Entity
(E_Id
);
18037 Check_Duplicate_Pragma
(E
);
18039 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
18041 ("argument for pragma% must be root tagged type", Arg1
);
18044 if Rep_Item_Too_Early
(E
, N
)
18046 Rep_Item_Too_Late
(E
, N
)
18050 Set_No_Tagged_Streams_Pragma
(E
, N
);
18053 -- Zero argument case
18056 Check_Is_In_Decl_Part_Or_Package_Spec
;
18057 No_Tagged_Streams
:= N
;
18059 end No_Tagged_Strms
;
18061 ------------------------
18062 -- No_Strict_Aliasing --
18063 ------------------------
18065 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18067 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
18072 Check_At_Most_N_Arguments
(1);
18074 if Arg_Count
= 0 then
18075 Check_Valid_Configuration_Pragma
;
18076 Opt
.No_Strict_Aliasing
:= True;
18079 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18080 Check_Arg_Is_Local_Name
(Arg1
);
18081 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18083 if E_Id
= Any_Type
then
18085 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
18086 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
18089 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
18091 end No_Strict_Aliasing
;
18093 -----------------------
18094 -- Normalize_Scalars --
18095 -----------------------
18097 -- pragma Normalize_Scalars;
18099 when Pragma_Normalize_Scalars
=>
18100 Check_Ada_83_Warning
;
18101 Check_Arg_Count
(0);
18102 Check_Valid_Configuration_Pragma
;
18104 -- Normalize_Scalars creates false positives in CodePeer, and
18105 -- incorrect negative results in GNATprove mode, so ignore this
18106 -- pragma in these modes.
18108 if not (CodePeer_Mode
or GNATprove_Mode
) then
18109 Normalize_Scalars
:= True;
18110 Init_Or_Norm_Scalars
:= True;
18117 -- pragma Obsolescent;
18119 -- pragma Obsolescent (
18120 -- [Message =>] static_string_EXPRESSION
18121 -- [,[Version =>] Ada_05]]);
18123 -- pragma Obsolescent (
18124 -- [Entity =>] NAME
18125 -- [,[Message =>] static_string_EXPRESSION
18126 -- [,[Version =>] Ada_05]] );
18128 when Pragma_Obsolescent
=> Obsolescent
: declare
18132 procedure Set_Obsolescent
(E
: Entity_Id
);
18133 -- Given an entity Ent, mark it as obsolescent if appropriate
18135 ---------------------
18136 -- Set_Obsolescent --
18137 ---------------------
18139 procedure Set_Obsolescent
(E
: Entity_Id
) is
18148 -- A pragma that applies to a Ghost entity becomes Ghost for
18149 -- the purposes of legality checks and removal of ignored Ghost
18152 Mark_Ghost_Pragma
(N
, E
);
18154 -- Entity name was given
18156 if Present
(Ename
) then
18158 -- If entity name matches, we are fine. Save entity in
18159 -- pragma argument, for ASIS use.
18161 if Chars
(Ename
) = Chars
(Ent
) then
18162 Set_Entity
(Ename
, Ent
);
18163 Generate_Reference
(Ent
, Ename
);
18165 -- If entity name does not match, only possibility is an
18166 -- enumeration literal from an enumeration type declaration.
18168 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
18170 ("pragma % entity name does not match declaration");
18173 Ent
:= First_Literal
(E
);
18177 ("pragma % entity name does not match any "
18178 & "enumeration literal");
18180 elsif Chars
(Ent
) = Chars
(Ename
) then
18181 Set_Entity
(Ename
, Ent
);
18182 Generate_Reference
(Ent
, Ename
);
18186 Ent
:= Next_Literal
(Ent
);
18192 -- Ent points to entity to be marked
18194 if Arg_Count
>= 1 then
18196 -- Deal with static string argument
18198 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18199 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
18201 for J
in 1 .. String_Length
(S
) loop
18202 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
18204 ("pragma% argument does not allow wide characters",
18209 Obsolescent_Warnings
.Append
18210 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
18212 -- Check for Ada_05 parameter
18214 if Arg_Count
/= 1 then
18215 Check_Arg_Count
(2);
18218 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
18221 Check_Arg_Is_Identifier
(Argx
);
18223 if Chars
(Argx
) /= Name_Ada_05
then
18224 Error_Msg_Name_2
:= Name_Ada_05
;
18226 ("only allowed argument for pragma% is %", Argx
);
18229 if Ada_Version_Explicit
< Ada_2005
18230 or else not Warn_On_Ada_2005_Compatibility
18238 -- Set flag if pragma active
18241 Set_Is_Obsolescent
(Ent
);
18245 end Set_Obsolescent
;
18247 -- Start of processing for pragma Obsolescent
18252 Check_At_Most_N_Arguments
(3);
18254 -- See if first argument specifies an entity name
18258 (Chars
(Arg1
) = Name_Entity
18260 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
18262 N_Operator_Symbol
))
18264 Ename
:= Get_Pragma_Arg
(Arg1
);
18266 -- Eliminate first argument, so we can share processing
18270 Arg_Count
:= Arg_Count
- 1;
18272 -- No Entity name argument given
18278 if Arg_Count
>= 1 then
18279 Check_Optional_Identifier
(Arg1
, Name_Message
);
18281 if Arg_Count
= 2 then
18282 Check_Optional_Identifier
(Arg2
, Name_Version
);
18286 -- Get immediately preceding declaration
18289 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
18293 -- Cases where we do not follow anything other than another pragma
18297 -- First case: library level compilation unit declaration with
18298 -- the pragma immediately following the declaration.
18300 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
18302 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
18305 -- Case 2: library unit placement for package
18309 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
18311 if Is_Package_Or_Generic_Package
(Ent
) then
18312 Set_Obsolescent
(Ent
);
18318 -- Cases where we must follow a declaration, including an
18319 -- abstract subprogram declaration, which is not in the
18320 -- other node subtypes.
18323 if Nkind
(Decl
) not in N_Declaration
18324 and then Nkind
(Decl
) not in N_Later_Decl_Item
18325 and then Nkind
(Decl
) not in N_Generic_Declaration
18326 and then Nkind
(Decl
) not in N_Renaming_Declaration
18327 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
18330 ("pragma% misplaced, "
18331 & "must immediately follow a declaration");
18334 Set_Obsolescent
(Defining_Entity
(Decl
));
18344 -- pragma Optimize (Time | Space | Off);
18346 -- The actual check for optimize is done in Gigi. Note that this
18347 -- pragma does not actually change the optimization setting, it
18348 -- simply checks that it is consistent with the pragma.
18350 when Pragma_Optimize
=>
18351 Check_No_Identifiers
;
18352 Check_Arg_Count
(1);
18353 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
18355 ------------------------
18356 -- Optimize_Alignment --
18357 ------------------------
18359 -- pragma Optimize_Alignment (Time | Space | Off);
18361 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
18363 Check_No_Identifiers
;
18364 Check_Arg_Count
(1);
18365 Check_Valid_Configuration_Pragma
;
18368 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
18371 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
18372 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
18373 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
18376 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
18380 -- Set indication that mode is set locally. If we are in fact in a
18381 -- configuration pragma file, this setting is harmless since the
18382 -- switch will get reset anyway at the start of each unit.
18384 Optimize_Alignment_Local
:= True;
18385 end Optimize_Alignment
;
18391 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18393 when Pragma_Ordered
=> Ordered
: declare
18394 Assoc
: constant Node_Id
:= Arg1
;
18400 Check_No_Identifiers
;
18401 Check_Arg_Count
(1);
18402 Check_Arg_Is_Local_Name
(Arg1
);
18404 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18405 Find_Type
(Type_Id
);
18406 Typ
:= Entity
(Type_Id
);
18408 if Typ
= Any_Type
then
18411 Typ
:= Underlying_Type
(Typ
);
18414 if not Is_Enumeration_Type
(Typ
) then
18415 Error_Pragma
("pragma% must specify enumeration type");
18418 Check_First_Subtype
(Arg1
);
18419 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
18422 -------------------
18423 -- Overflow_Mode --
18424 -------------------
18426 -- pragma Overflow_Mode
18427 -- ([General => ] MODE [, [Assertions => ] MODE]);
18429 -- MODE := STRICT | MINIMIZED | ELIMINATED
18431 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18432 -- since System.Bignums makes this assumption. This is true of nearly
18433 -- all (all?) targets.
18435 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
18436 function Get_Overflow_Mode
18438 Arg
: Node_Id
) return Overflow_Mode_Type
;
18439 -- Function to process one pragma argument, Arg. If an identifier
18440 -- is present, it must be Name. Mode type is returned if a valid
18441 -- argument exists, otherwise an error is signalled.
18443 -----------------------
18444 -- Get_Overflow_Mode --
18445 -----------------------
18447 function Get_Overflow_Mode
18449 Arg
: Node_Id
) return Overflow_Mode_Type
18451 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
18454 Check_Optional_Identifier
(Arg
, Name
);
18455 Check_Arg_Is_Identifier
(Argx
);
18457 if Chars
(Argx
) = Name_Strict
then
18460 elsif Chars
(Argx
) = Name_Minimized
then
18463 elsif Chars
(Argx
) = Name_Eliminated
then
18464 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
18466 ("Eliminated not implemented on this target", Argx
);
18472 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
18474 end Get_Overflow_Mode
;
18476 -- Start of processing for Overflow_Mode
18480 Check_At_Least_N_Arguments
(1);
18481 Check_At_Most_N_Arguments
(2);
18483 -- Process first argument
18485 Scope_Suppress
.Overflow_Mode_General
:=
18486 Get_Overflow_Mode
(Name_General
, Arg1
);
18488 -- Case of only one argument
18490 if Arg_Count
= 1 then
18491 Scope_Suppress
.Overflow_Mode_Assertions
:=
18492 Scope_Suppress
.Overflow_Mode_General
;
18494 -- Case of two arguments present
18497 Scope_Suppress
.Overflow_Mode_Assertions
:=
18498 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
18502 --------------------------
18503 -- Overriding Renamings --
18504 --------------------------
18506 -- pragma Overriding_Renamings;
18508 when Pragma_Overriding_Renamings
=>
18510 Check_Arg_Count
(0);
18511 Check_Valid_Configuration_Pragma
;
18512 Overriding_Renamings
:= True;
18518 -- pragma Pack (first_subtype_LOCAL_NAME);
18520 when Pragma_Pack
=> Pack
: declare
18521 Assoc
: constant Node_Id
:= Arg1
;
18523 Ignore
: Boolean := False;
18528 Check_No_Identifiers
;
18529 Check_Arg_Count
(1);
18530 Check_Arg_Is_Local_Name
(Arg1
);
18531 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18533 if not Is_Entity_Name
(Type_Id
)
18534 or else not Is_Type
(Entity
(Type_Id
))
18537 ("argument for pragma% must be type or subtype", Arg1
);
18540 Find_Type
(Type_Id
);
18541 Typ
:= Entity
(Type_Id
);
18544 or else Rep_Item_Too_Early
(Typ
, N
)
18548 Typ
:= Underlying_Type
(Typ
);
18551 -- A pragma that applies to a Ghost entity becomes Ghost for the
18552 -- purposes of legality checks and removal of ignored Ghost code.
18554 Mark_Ghost_Pragma
(N
, Typ
);
18556 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
18557 Error_Pragma
("pragma% must specify array or record type");
18560 Check_First_Subtype
(Arg1
);
18561 Check_Duplicate_Pragma
(Typ
);
18565 if Is_Array_Type
(Typ
) then
18566 Ctyp
:= Component_Type
(Typ
);
18568 -- Ignore pack that does nothing
18570 if Known_Static_Esize
(Ctyp
)
18571 and then Known_Static_RM_Size
(Ctyp
)
18572 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
18573 and then Addressable
(Esize
(Ctyp
))
18578 -- Process OK pragma Pack. Note that if there is a separate
18579 -- component clause present, the Pack will be cancelled. This
18580 -- processing is in Freeze.
18582 if not Rep_Item_Too_Late
(Typ
, N
) then
18584 -- In CodePeer mode, we do not need complex front-end
18585 -- expansions related to pragma Pack, so disable handling
18588 if CodePeer_Mode
then
18591 -- Normal case where we do the pack action
18595 Set_Is_Packed
(Base_Type
(Typ
));
18596 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18599 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18603 -- For record types, the pack is always effective
18605 else pragma Assert
(Is_Record_Type
(Typ
));
18606 if not Rep_Item_Too_Late
(Typ
, N
) then
18607 Set_Is_Packed
(Base_Type
(Typ
));
18608 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18609 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18620 -- There is nothing to do here, since we did all the processing for
18621 -- this pragma in Par.Prag (so that it works properly even in syntax
18624 when Pragma_Page
=>
18631 -- pragma Part_Of (ABSTRACT_STATE);
18633 -- ABSTRACT_STATE ::= NAME
18635 when Pragma_Part_Of
=> Part_Of
: declare
18636 procedure Propagate_Part_Of
18637 (Pack_Id
: Entity_Id
;
18638 State_Id
: Entity_Id
;
18639 Instance
: Node_Id
);
18640 -- Propagate the Part_Of indicator to all abstract states and
18641 -- objects declared in the visible state space of a package
18642 -- denoted by Pack_Id. State_Id is the encapsulating state.
18643 -- Instance is the package instantiation node.
18645 -----------------------
18646 -- Propagate_Part_Of --
18647 -----------------------
18649 procedure Propagate_Part_Of
18650 (Pack_Id
: Entity_Id
;
18651 State_Id
: Entity_Id
;
18652 Instance
: Node_Id
)
18654 Has_Item
: Boolean := False;
18655 -- Flag set when the visible state space contains at least one
18656 -- abstract state or variable.
18658 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
18659 -- Propagate the Part_Of indicator to all abstract states and
18660 -- objects declared in the visible state space of a package
18661 -- denoted by Pack_Id.
18663 -----------------------
18664 -- Propagate_Part_Of --
18665 -----------------------
18667 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
18668 Constits
: Elist_Id
;
18669 Item_Id
: Entity_Id
;
18672 -- Traverse the entity chain of the package and set relevant
18673 -- attributes of abstract states and objects declared in the
18674 -- visible state space of the package.
18676 Item_Id
:= First_Entity
(Pack_Id
);
18677 while Present
(Item_Id
)
18678 and then not In_Private_Part
(Item_Id
)
18680 -- Do not consider internally generated items
18682 if not Comes_From_Source
(Item_Id
) then
18685 -- The Part_Of indicator turns an abstract state or an
18686 -- object into a constituent of the encapsulating state.
18688 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
18693 Constits
:= Part_Of_Constituents
(State_Id
);
18695 if No
(Constits
) then
18696 Constits
:= New_Elmt_List
;
18697 Set_Part_Of_Constituents
(State_Id
, Constits
);
18700 Append_Elmt
(Item_Id
, Constits
);
18701 Set_Encapsulating_State
(Item_Id
, State_Id
);
18703 -- Recursively handle nested packages and instantiations
18705 elsif Ekind
(Item_Id
) = E_Package
then
18706 Propagate_Part_Of
(Item_Id
);
18709 Next_Entity
(Item_Id
);
18711 end Propagate_Part_Of
;
18713 -- Start of processing for Propagate_Part_Of
18716 Propagate_Part_Of
(Pack_Id
);
18718 -- Detect a package instantiation that is subject to a Part_Of
18719 -- indicator, but has no visible state.
18721 if not Has_Item
then
18723 ("package instantiation & has Part_Of indicator but "
18724 & "lacks visible state", Instance
, Pack_Id
);
18726 end Propagate_Part_Of
;
18730 Constits
: Elist_Id
;
18732 Encap_Id
: Entity_Id
;
18733 Item_Id
: Entity_Id
;
18737 -- Start of processing for Part_Of
18741 Check_No_Identifiers
;
18742 Check_Arg_Count
(1);
18744 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
18746 -- Object declaration
18748 if Nkind
(Stmt
) = N_Object_Declaration
then
18751 -- Package instantiation
18753 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
18756 -- Single concurrent type declaration
18758 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
18761 -- Otherwise the pragma is associated with an illegal construct
18768 -- Extract the entity of the related object declaration or package
18769 -- instantiation. In the case of the instantiation, use the entity
18770 -- of the instance spec.
18772 if Nkind
(Stmt
) = N_Package_Instantiation
then
18773 Stmt
:= Instance_Spec
(Stmt
);
18776 Item_Id
:= Defining_Entity
(Stmt
);
18778 -- A pragma that applies to a Ghost entity becomes Ghost for the
18779 -- purposes of legality checks and removal of ignored Ghost code.
18781 Mark_Ghost_Pragma
(N
, Item_Id
);
18783 -- Chain the pragma on the contract for further processing by
18784 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18786 Add_Contract_Item
(N
, Item_Id
);
18788 -- A variable may act as constituent of a single concurrent type
18789 -- which in turn could be declared after the variable. Due to this
18790 -- discrepancy, the full analysis of indicator Part_Of is delayed
18791 -- until the end of the enclosing declarative region (see routine
18792 -- Analyze_Part_Of_In_Decl_Part).
18794 if Ekind
(Item_Id
) = E_Variable
then
18797 -- Otherwise indicator Part_Of applies to a constant or a package
18801 Encap
:= Get_Pragma_Arg
(Arg1
);
18803 -- Detect any discrepancies between the placement of the
18804 -- constant or package instantiation with respect to state
18805 -- space and the encapsulating state.
18809 Item_Id
=> Item_Id
,
18811 Encap_Id
=> Encap_Id
,
18815 pragma Assert
(Present
(Encap_Id
));
18817 if Ekind
(Item_Id
) = E_Constant
then
18818 Constits
:= Part_Of_Constituents
(Encap_Id
);
18820 if No
(Constits
) then
18821 Constits
:= New_Elmt_List
;
18822 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
18825 Append_Elmt
(Item_Id
, Constits
);
18826 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
18828 -- Propagate the Part_Of indicator to the visible state
18829 -- space of the package instantiation.
18833 (Pack_Id
=> Item_Id
,
18834 State_Id
=> Encap_Id
,
18841 ----------------------------------
18842 -- Partition_Elaboration_Policy --
18843 ----------------------------------
18845 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18847 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
18848 subtype PEP_Range
is Name_Id
18849 range First_Partition_Elaboration_Policy_Name
18850 .. Last_Partition_Elaboration_Policy_Name
;
18851 PEP_Val
: PEP_Range
;
18856 Check_Arg_Count
(1);
18857 Check_No_Identifiers
;
18858 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
18859 Check_Valid_Configuration_Pragma
;
18860 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18863 when Name_Concurrent
=> PEP
:= 'C';
18864 when Name_Sequential
=> PEP
:= 'S';
18867 if Partition_Elaboration_Policy
/= ' '
18868 and then Partition_Elaboration_Policy
/= PEP
18870 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
18872 ("partition elaboration policy incompatible with policy#");
18874 -- Set new policy, but always preserve System_Location since we
18875 -- like the error message with the run time name.
18878 Partition_Elaboration_Policy
:= PEP
;
18880 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
18881 Partition_Elaboration_Policy_Sloc
:= Loc
;
18890 -- pragma Passive [(PASSIVE_FORM)];
18892 -- PASSIVE_FORM ::= Semaphore | No
18894 when Pragma_Passive
=>
18897 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
18898 Error_Pragma
("pragma% must be within task definition");
18901 if Arg_Count
/= 0 then
18902 Check_Arg_Count
(1);
18903 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
18906 ----------------------------------
18907 -- Preelaborable_Initialization --
18908 ----------------------------------
18910 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18912 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
18917 Check_Arg_Count
(1);
18918 Check_No_Identifiers
;
18919 Check_Arg_Is_Identifier
(Arg1
);
18920 Check_Arg_Is_Local_Name
(Arg1
);
18921 Check_First_Subtype
(Arg1
);
18922 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18924 -- A pragma that applies to a Ghost entity becomes Ghost for the
18925 -- purposes of legality checks and removal of ignored Ghost code.
18927 Mark_Ghost_Pragma
(N
, Ent
);
18929 -- The pragma may come from an aspect on a private declaration,
18930 -- even if the freeze point at which this is analyzed in the
18931 -- private part after the full view.
18933 if Has_Private_Declaration
(Ent
)
18934 and then From_Aspect_Specification
(N
)
18938 -- Check appropriate type argument
18940 elsif Is_Private_Type
(Ent
)
18941 or else Is_Protected_Type
(Ent
)
18942 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
18944 -- AI05-0028: The pragma applies to all composite types. Note
18945 -- that we apply this binding interpretation to earlier versions
18946 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18947 -- choice since there are other compilers that do the same.
18949 or else Is_Composite_Type
(Ent
)
18955 ("pragma % can only be applied to private, formal derived, "
18956 & "protected, or composite type", Arg1
);
18959 -- Give an error if the pragma is applied to a protected type that
18960 -- does not qualify (due to having entries, or due to components
18961 -- that do not qualify).
18963 if Is_Protected_Type
(Ent
)
18964 and then not Has_Preelaborable_Initialization
(Ent
)
18967 ("protected type & does not have preelaborable "
18968 & "initialization", Ent
);
18970 -- Otherwise mark the type as definitely having preelaborable
18974 Set_Known_To_Have_Preelab_Init
(Ent
);
18977 if Has_Pragma_Preelab_Init
(Ent
)
18978 and then Warn_On_Redundant_Constructs
18980 Error_Pragma
("?r?duplicate pragma%!");
18982 Set_Has_Pragma_Preelab_Init
(Ent
);
18986 --------------------
18987 -- Persistent_BSS --
18988 --------------------
18990 -- pragma Persistent_BSS [(object_NAME)];
18992 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
18999 Check_At_Most_N_Arguments
(1);
19001 -- Case of application to specific object (one argument)
19003 if Arg_Count
= 1 then
19004 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19006 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
19008 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
19011 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
19014 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19016 -- A pragma that applies to a Ghost entity becomes Ghost for
19017 -- the purposes of legality checks and removal of ignored Ghost
19020 Mark_Ghost_Pragma
(N
, Ent
);
19022 -- Check for duplication before inserting in list of
19023 -- representation items.
19025 Check_Duplicate_Pragma
(Ent
);
19027 if Rep_Item_Too_Late
(Ent
, N
) then
19031 Decl
:= Parent
(Ent
);
19033 if Present
(Expression
(Decl
)) then
19035 ("object for pragma% cannot have initialization", Arg1
);
19038 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
19040 ("object type for pragma% is not potentially persistent",
19045 Make_Linker_Section_Pragma
19046 (Ent
, Sloc
(N
), ".persistent.bss");
19047 Insert_After
(N
, Prag
);
19050 -- Case of use as configuration pragma with no arguments
19053 Check_Valid_Configuration_Pragma
;
19054 Persistent_BSS_Mode
:= True;
19056 end Persistent_BSS
;
19058 --------------------
19059 -- Rename_Pragma --
19060 --------------------
19062 -- pragma Rename_Pragma (
19063 -- [New_Name =>] IDENTIFIER,
19064 -- [Renamed =>] pragma_IDENTIFIER);
19066 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
19067 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19068 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19072 Check_Valid_Configuration_Pragma
;
19073 Check_Arg_Count
(2);
19074 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
19075 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
19077 if Nkind
(New_Name
) /= N_Identifier
then
19078 Error_Pragma_Arg
("identifier expected", Arg1
);
19081 if Nkind
(Old_Name
) /= N_Identifier
then
19082 Error_Pragma_Arg
("identifier expected", Arg2
);
19085 -- The New_Name arg should not be an existing pragma (but we allow
19086 -- it; it's just a warning). The Old_Name arg must be an existing
19089 if Is_Pragma_Name
(Chars
(New_Name
)) then
19090 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
19093 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
19094 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
19097 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
19104 -- pragma Polling (ON | OFF);
19106 when Pragma_Polling
=>
19108 Check_Arg_Count
(1);
19109 Check_No_Identifiers
;
19110 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19111 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
19113 -----------------------------------
19114 -- Post/Post_Class/Postcondition --
19115 -----------------------------------
19117 -- pragma Post (Boolean_EXPRESSION);
19118 -- pragma Post_Class (Boolean_EXPRESSION);
19119 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19120 -- [,[Message =>] String_EXPRESSION]);
19122 -- Characteristics:
19124 -- * Analysis - The annotation undergoes initial checks to verify
19125 -- the legal placement and context. Secondary checks preanalyze the
19128 -- Analyze_Pre_Post_Condition_In_Decl_Part
19130 -- * Expansion - The annotation is expanded during the expansion of
19131 -- the related subprogram [body] contract as performed in:
19133 -- Expand_Subprogram_Contract
19135 -- * Template - The annotation utilizes the generic template of the
19136 -- related subprogram [body] when it is:
19138 -- aspect on subprogram declaration
19139 -- aspect on stand alone subprogram body
19140 -- pragma on stand alone subprogram body
19142 -- The annotation must prepare its own template when it is:
19144 -- pragma on subprogram declaration
19146 -- * Globals - Capture of global references must occur after full
19149 -- * Instance - The annotation is instantiated automatically when
19150 -- the related generic subprogram [body] is instantiated except for
19151 -- the "pragma on subprogram declaration" case. In that scenario
19152 -- the annotation must instantiate itself.
19155 | Pragma_Post_Class
19156 | Pragma_Postcondition
19158 Analyze_Pre_Post_Condition
;
19160 --------------------------------
19161 -- Pre/Pre_Class/Precondition --
19162 --------------------------------
19164 -- pragma Pre (Boolean_EXPRESSION);
19165 -- pragma Pre_Class (Boolean_EXPRESSION);
19166 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19167 -- [,[Message =>] String_EXPRESSION]);
19169 -- Characteristics:
19171 -- * Analysis - The annotation undergoes initial checks to verify
19172 -- the legal placement and context. Secondary checks preanalyze the
19175 -- Analyze_Pre_Post_Condition_In_Decl_Part
19177 -- * Expansion - The annotation is expanded during the expansion of
19178 -- the related subprogram [body] contract as performed in:
19180 -- Expand_Subprogram_Contract
19182 -- * Template - The annotation utilizes the generic template of the
19183 -- related subprogram [body] when it is:
19185 -- aspect on subprogram declaration
19186 -- aspect on stand alone subprogram body
19187 -- pragma on stand alone subprogram body
19189 -- The annotation must prepare its own template when it is:
19191 -- pragma on subprogram declaration
19193 -- * Globals - Capture of global references must occur after full
19196 -- * Instance - The annotation is instantiated automatically when
19197 -- the related generic subprogram [body] is instantiated except for
19198 -- the "pragma on subprogram declaration" case. In that scenario
19199 -- the annotation must instantiate itself.
19203 | Pragma_Precondition
19205 Analyze_Pre_Post_Condition
;
19211 -- pragma Predicate
19212 -- ([Entity =>] type_LOCAL_NAME,
19213 -- [Check =>] boolean_EXPRESSION);
19215 when Pragma_Predicate
=> Predicate
: declare
19222 Check_Arg_Count
(2);
19223 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19224 Check_Optional_Identifier
(Arg2
, Name_Check
);
19226 Check_Arg_Is_Local_Name
(Arg1
);
19228 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19229 Find_Type
(Type_Id
);
19230 Typ
:= Entity
(Type_Id
);
19232 if Typ
= Any_Type
then
19236 -- A pragma that applies to a Ghost entity becomes Ghost for the
19237 -- purposes of legality checks and removal of ignored Ghost code.
19239 Mark_Ghost_Pragma
(N
, Typ
);
19241 -- The remaining processing is simply to link the pragma on to
19242 -- the rep item chain, for processing when the type is frozen.
19243 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19244 -- mark the type as having predicates.
19246 -- If the current policy for predicate checking is Ignore mark the
19247 -- subtype accordingly. In the case of predicates we consider them
19248 -- enabled unless Ignore is specified (either directly or with a
19249 -- general Assertion_Policy pragma) to preserve existing warnings.
19251 Set_Has_Predicates
(Typ
);
19252 Set_Predicates_Ignored
(Typ
,
19253 Present
(Check_Policy_List
)
19255 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
19256 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19259 -----------------------
19260 -- Predicate_Failure --
19261 -----------------------
19263 -- pragma Predicate_Failure
19264 -- ([Entity =>] type_LOCAL_NAME,
19265 -- [Message =>] string_EXPRESSION);
19267 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
19274 Check_Arg_Count
(2);
19275 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19276 Check_Optional_Identifier
(Arg2
, Name_Message
);
19278 Check_Arg_Is_Local_Name
(Arg1
);
19280 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19281 Find_Type
(Type_Id
);
19282 Typ
:= Entity
(Type_Id
);
19284 if Typ
= Any_Type
then
19288 -- A pragma that applies to a Ghost entity becomes Ghost for the
19289 -- purposes of legality checks and removal of ignored Ghost code.
19291 Mark_Ghost_Pragma
(N
, Typ
);
19293 -- The remaining processing is simply to link the pragma on to
19294 -- the rep item chain, for processing when the type is frozen.
19295 -- This is accomplished by a call to Rep_Item_Too_Late.
19297 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19298 end Predicate_Failure
;
19304 -- pragma Preelaborate [(library_unit_NAME)];
19306 -- Set the flag Is_Preelaborated of program unit name entity
19308 when Pragma_Preelaborate
=> Preelaborate
: declare
19309 Pa
: constant Node_Id
:= Parent
(N
);
19310 Pk
: constant Node_Kind
:= Nkind
(Pa
);
19314 Check_Ada_83_Warning
;
19315 Check_Valid_Library_Unit_Pragma
;
19317 if Nkind
(N
) = N_Null_Statement
then
19321 Ent
:= Find_Lib_Unit_Name
;
19323 -- A pragma that applies to a Ghost entity becomes Ghost for the
19324 -- purposes of legality checks and removal of ignored Ghost code.
19326 Mark_Ghost_Pragma
(N
, Ent
);
19327 Check_Duplicate_Pragma
(Ent
);
19329 -- This filters out pragmas inside generic parents that show up
19330 -- inside instantiations. Pragmas that come from aspects in the
19331 -- unit are not ignored.
19333 if Present
(Ent
) then
19334 if Pk
= N_Package_Specification
19335 and then Present
(Generic_Parent
(Pa
))
19336 and then not From_Aspect_Specification
(N
)
19341 if not Debug_Flag_U
then
19342 Set_Is_Preelaborated
(Ent
);
19343 Set_Suppress_Elaboration_Warnings
(Ent
);
19349 -------------------------------
19350 -- Prefix_Exception_Messages --
19351 -------------------------------
19353 -- pragma Prefix_Exception_Messages;
19355 when Pragma_Prefix_Exception_Messages
=>
19357 Check_Valid_Configuration_Pragma
;
19358 Check_Arg_Count
(0);
19359 Prefix_Exception_Messages
:= True;
19365 -- pragma Priority (EXPRESSION);
19367 when Pragma_Priority
=> Priority
: declare
19368 P
: constant Node_Id
:= Parent
(N
);
19373 Check_No_Identifiers
;
19374 Check_Arg_Count
(1);
19378 if Nkind
(P
) = N_Subprogram_Body
then
19379 Check_In_Main_Program
;
19381 Ent
:= Defining_Unit_Name
(Specification
(P
));
19383 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
19384 Ent
:= Defining_Identifier
(Ent
);
19387 Arg
:= Get_Pragma_Arg
(Arg1
);
19388 Analyze_And_Resolve
(Arg
, Standard_Integer
);
19392 if not Is_OK_Static_Expression
(Arg
) then
19393 Flag_Non_Static_Expr
19394 ("main subprogram priority is not static!", Arg
);
19397 -- If constraint error, then we already signalled an error
19399 elsif Raises_Constraint_Error
(Arg
) then
19402 -- Otherwise check in range except if Relaxed_RM_Semantics
19403 -- where we ignore the value if out of range.
19406 if not Relaxed_RM_Semantics
19407 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
19410 ("main subprogram priority is out of range", Arg1
);
19413 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
19417 -- Load an arbitrary entity from System.Tasking.Stages or
19418 -- System.Tasking.Restricted.Stages (depending on the
19419 -- supported profile) to make sure that one of these packages
19420 -- is implicitly with'ed, since we need to have the tasking
19421 -- run time active for the pragma Priority to have any effect.
19422 -- Previously we with'ed the package System.Tasking, but this
19423 -- package does not trigger the required initialization of the
19424 -- run-time library.
19427 Discard
: Entity_Id
;
19428 pragma Warnings
(Off
, Discard
);
19430 if Restricted_Profile
then
19431 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
19433 Discard
:= RTE
(RE_Activate_Tasks
);
19437 -- Task or Protected, must be of type Integer
19439 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
19440 Arg
:= Get_Pragma_Arg
(Arg1
);
19441 Ent
:= Defining_Identifier
(Parent
(P
));
19443 -- The expression must be analyzed in the special manner
19444 -- described in "Handling of Default and Per-Object
19445 -- Expressions" in sem.ads.
19447 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
19449 if not Is_OK_Static_Expression
(Arg
) then
19450 Check_Restriction
(Static_Priorities
, Arg
);
19453 -- Anything else is incorrect
19459 -- Check duplicate pragma before we chain the pragma in the Rep
19460 -- Item chain of Ent.
19462 Check_Duplicate_Pragma
(Ent
);
19463 Record_Rep_Item
(Ent
, N
);
19466 -----------------------------------
19467 -- Priority_Specific_Dispatching --
19468 -----------------------------------
19470 -- pragma Priority_Specific_Dispatching (
19471 -- policy_IDENTIFIER,
19472 -- first_priority_EXPRESSION,
19473 -- last_priority_EXPRESSION);
19475 when Pragma_Priority_Specific_Dispatching
=>
19476 Priority_Specific_Dispatching
: declare
19477 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
19478 -- This is the entity System.Any_Priority;
19481 Lower_Bound
: Node_Id
;
19482 Upper_Bound
: Node_Id
;
19488 Check_Arg_Count
(3);
19489 Check_No_Identifiers
;
19490 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19491 Check_Valid_Configuration_Pragma
;
19492 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19493 DP
:= Fold_Upper
(Name_Buffer
(1));
19495 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
19496 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
19497 Lower_Val
:= Expr_Value
(Lower_Bound
);
19499 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
19500 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
19501 Upper_Val
:= Expr_Value
(Upper_Bound
);
19503 -- It is not allowed to use Task_Dispatching_Policy and
19504 -- Priority_Specific_Dispatching in the same partition.
19506 if Task_Dispatching_Policy
/= ' ' then
19507 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19509 ("pragma% incompatible with Task_Dispatching_Policy#");
19511 -- Check lower bound in range
19513 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19515 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19518 ("first_priority is out of range", Arg2
);
19520 -- Check upper bound in range
19522 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19524 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19527 ("last_priority is out of range", Arg3
);
19529 -- Check that the priority range is valid
19531 elsif Lower_Val
> Upper_Val
then
19533 ("last_priority_expression must be greater than or equal to "
19534 & "first_priority_expression");
19536 -- Store the new policy, but always preserve System_Location since
19537 -- we like the error message with the run-time name.
19540 -- Check overlapping in the priority ranges specified in other
19541 -- Priority_Specific_Dispatching pragmas within the same
19542 -- partition. We can only check those we know about.
19545 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
19547 if Specific_Dispatching
.Table
(J
).First_Priority
in
19548 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19549 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
19550 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19553 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
19555 ("priority range overlaps with "
19556 & "Priority_Specific_Dispatching#");
19560 -- The use of Priority_Specific_Dispatching is incompatible
19561 -- with Task_Dispatching_Policy.
19563 if Task_Dispatching_Policy
/= ' ' then
19564 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19566 ("Priority_Specific_Dispatching incompatible "
19567 & "with Task_Dispatching_Policy#");
19570 -- The use of Priority_Specific_Dispatching forces ceiling
19573 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
19574 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19576 ("Priority_Specific_Dispatching incompatible "
19577 & "with Locking_Policy#");
19579 -- Set the Ceiling_Locking policy, but preserve System_Location
19580 -- since we like the error message with the run time name.
19583 Locking_Policy
:= 'C';
19585 if Locking_Policy_Sloc
/= System_Location
then
19586 Locking_Policy_Sloc
:= Loc
;
19590 -- Add entry in the table
19592 Specific_Dispatching
.Append
19593 ((Dispatching_Policy
=> DP
,
19594 First_Priority
=> UI_To_Int
(Lower_Val
),
19595 Last_Priority
=> UI_To_Int
(Upper_Val
),
19596 Pragma_Loc
=> Loc
));
19598 end Priority_Specific_Dispatching
;
19604 -- pragma Profile (profile_IDENTIFIER);
19606 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19608 when Pragma_Profile
=>
19610 Check_Arg_Count
(1);
19611 Check_Valid_Configuration_Pragma
;
19612 Check_No_Identifiers
;
19615 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19618 if Chars
(Argx
) = Name_Ravenscar
then
19619 Set_Ravenscar_Profile
(Ravenscar
, N
);
19621 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
19622 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
19624 elsif Chars
(Argx
) = Name_Restricted
then
19625 Set_Profile_Restrictions
19627 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19629 elsif Chars
(Argx
) = Name_Rational
then
19630 Set_Rational_Profile
;
19632 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19633 Set_Profile_Restrictions
19634 (No_Implementation_Extensions
,
19635 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19638 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19642 ----------------------
19643 -- Profile_Warnings --
19644 ----------------------
19646 -- pragma Profile_Warnings (profile_IDENTIFIER);
19648 -- profile_IDENTIFIER => Restricted | Ravenscar
19650 when Pragma_Profile_Warnings
=>
19652 Check_Arg_Count
(1);
19653 Check_Valid_Configuration_Pragma
;
19654 Check_No_Identifiers
;
19657 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19660 if Chars
(Argx
) = Name_Ravenscar
then
19661 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
19663 elsif Chars
(Argx
) = Name_Restricted
then
19664 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
19666 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19667 Set_Profile_Restrictions
19668 (No_Implementation_Extensions
, N
, Warn
=> True);
19671 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19675 --------------------------
19676 -- Propagate_Exceptions --
19677 --------------------------
19679 -- pragma Propagate_Exceptions;
19681 -- Note: this pragma is obsolete and has no effect
19683 when Pragma_Propagate_Exceptions
=>
19685 Check_Arg_Count
(0);
19687 if Warn_On_Obsolescent_Feature
then
19689 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19690 "and has no effect?j?", N
);
19693 -----------------------------
19694 -- Provide_Shift_Operators --
19695 -----------------------------
19697 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19699 when Pragma_Provide_Shift_Operators
=>
19700 Provide_Shift_Operators
: declare
19703 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
19704 -- Insert declaration and pragma Instrinsic for named shift op
19706 ----------------------------
19707 -- Declare_Shift_Operator --
19708 ----------------------------
19710 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
19716 Make_Subprogram_Declaration
(Loc
,
19717 Make_Function_Specification
(Loc
,
19718 Defining_Unit_Name
=>
19719 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
19721 Result_Definition
=>
19722 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
19724 Parameter_Specifications
=> New_List
(
19725 Make_Parameter_Specification
(Loc
,
19726 Defining_Identifier
=>
19727 Make_Defining_Identifier
(Loc
, Name_Value
),
19729 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
19731 Make_Parameter_Specification
(Loc
,
19732 Defining_Identifier
=>
19733 Make_Defining_Identifier
(Loc
, Name_Amount
),
19735 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
19739 Chars
=> Name_Import
,
19740 Pragma_Argument_Associations
=> New_List
(
19741 Make_Pragma_Argument_Association
(Loc
,
19742 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
19743 Make_Pragma_Argument_Association
(Loc
,
19744 Expression
=> Make_Identifier
(Loc
, Nam
))));
19746 Insert_After
(N
, Import
);
19747 Insert_After
(N
, Func
);
19748 end Declare_Shift_Operator
;
19750 -- Start of processing for Provide_Shift_Operators
19754 Check_Arg_Count
(1);
19755 Check_Arg_Is_Local_Name
(Arg1
);
19757 Arg1
:= Get_Pragma_Arg
(Arg1
);
19759 -- We must have an entity name
19761 if not Is_Entity_Name
(Arg1
) then
19763 ("pragma % must apply to integer first subtype", Arg1
);
19766 -- If no Entity, means there was a prior error so ignore
19768 if Present
(Entity
(Arg1
)) then
19769 Ent
:= Entity
(Arg1
);
19771 -- Apply error checks
19773 if not Is_First_Subtype
(Ent
) then
19775 ("cannot apply pragma %",
19776 "\& is not a first subtype",
19779 elsif not Is_Integer_Type
(Ent
) then
19781 ("cannot apply pragma %",
19782 "\& is not an integer type",
19785 elsif Has_Shift_Operator
(Ent
) then
19787 ("cannot apply pragma %",
19788 "\& already has declared shift operators",
19791 elsif Is_Frozen
(Ent
) then
19793 ("pragma % appears too late",
19794 "\& is already frozen",
19798 -- Now declare the operators. We do this during analysis rather
19799 -- than expansion, since we want the operators available if we
19800 -- are operating in -gnatc or ASIS mode.
19802 Declare_Shift_Operator
(Name_Rotate_Left
);
19803 Declare_Shift_Operator
(Name_Rotate_Right
);
19804 Declare_Shift_Operator
(Name_Shift_Left
);
19805 Declare_Shift_Operator
(Name_Shift_Right
);
19806 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
19808 end Provide_Shift_Operators
;
19814 -- pragma Psect_Object (
19815 -- [Internal =>] LOCAL_NAME,
19816 -- [, [External =>] EXTERNAL_SYMBOL]
19817 -- [, [Size =>] EXTERNAL_SYMBOL]);
19819 when Pragma_Common_Object
19820 | Pragma_Psect_Object
19822 Psect_Object
: declare
19823 Args
: Args_List
(1 .. 3);
19824 Names
: constant Name_List
(1 .. 3) := (
19829 Internal
: Node_Id
renames Args
(1);
19830 External
: Node_Id
renames Args
(2);
19831 Size
: Node_Id
renames Args
(3);
19833 Def_Id
: Entity_Id
;
19835 procedure Check_Arg
(Arg
: Node_Id
);
19836 -- Checks that argument is either a string literal or an
19837 -- identifier, and posts error message if not.
19843 procedure Check_Arg
(Arg
: Node_Id
) is
19845 if not Nkind_In
(Original_Node
(Arg
),
19850 ("inappropriate argument for pragma %", Arg
);
19854 -- Start of processing for Common_Object/Psect_Object
19858 Gather_Associations
(Names
, Args
);
19859 Process_Extended_Import_Export_Internal_Arg
(Internal
);
19861 Def_Id
:= Entity
(Internal
);
19863 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
19865 ("pragma% must designate an object", Internal
);
19868 Check_Arg
(Internal
);
19870 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
19872 ("cannot use pragma% for imported/exported object",
19876 if Is_Concurrent_Type
(Etype
(Internal
)) then
19878 ("cannot specify pragma % for task/protected object",
19882 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
19884 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
19886 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
19889 if Ekind
(Def_Id
) = E_Constant
then
19891 ("cannot specify pragma % for a constant", Internal
);
19894 if Is_Record_Type
(Etype
(Internal
)) then
19900 Ent
:= First_Entity
(Etype
(Internal
));
19901 while Present
(Ent
) loop
19902 Decl
:= Declaration_Node
(Ent
);
19904 if Ekind
(Ent
) = E_Component
19905 and then Nkind
(Decl
) = N_Component_Declaration
19906 and then Present
(Expression
(Decl
))
19907 and then Warn_On_Export_Import
19910 ("?x?object for pragma % has defaults", Internal
);
19920 if Present
(Size
) then
19924 if Present
(External
) then
19925 Check_Arg_Is_External_Name
(External
);
19928 -- If all error tests pass, link pragma on to the rep item chain
19930 Record_Rep_Item
(Def_Id
, N
);
19937 -- pragma Pure [(library_unit_NAME)];
19939 when Pragma_Pure
=> Pure
: declare
19943 Check_Ada_83_Warning
;
19945 -- If the pragma comes from a subprogram instantiation, nothing to
19946 -- check, this can happen at any level of nesting.
19948 if Is_Wrapper_Package
(Current_Scope
) then
19951 Check_Valid_Library_Unit_Pragma
;
19954 if Nkind
(N
) = N_Null_Statement
then
19958 Ent
:= Find_Lib_Unit_Name
;
19960 -- A pragma that applies to a Ghost entity becomes Ghost for the
19961 -- purposes of legality checks and removal of ignored Ghost code.
19963 Mark_Ghost_Pragma
(N
, Ent
);
19965 if not Debug_Flag_U
then
19967 Set_Has_Pragma_Pure
(Ent
);
19968 Set_Suppress_Elaboration_Warnings
(Ent
);
19972 -------------------
19973 -- Pure_Function --
19974 -------------------
19976 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19978 when Pragma_Pure_Function
=> Pure_Function
: declare
19979 Def_Id
: Entity_Id
;
19982 Effective
: Boolean := False;
19986 Check_Arg_Count
(1);
19987 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19988 Check_Arg_Is_Local_Name
(Arg1
);
19989 E_Id
:= Get_Pragma_Arg
(Arg1
);
19991 if Error_Posted
(E_Id
) then
19995 -- Loop through homonyms (overloadings) of referenced entity
19997 E
:= Entity
(E_Id
);
19999 -- A pragma that applies to a Ghost entity becomes Ghost for the
20000 -- purposes of legality checks and removal of ignored Ghost code.
20002 Mark_Ghost_Pragma
(N
, E
);
20004 if Present
(E
) then
20006 Def_Id
:= Get_Base_Subprogram
(E
);
20008 if not Ekind_In
(Def_Id
, E_Function
,
20009 E_Generic_Function
,
20013 ("pragma% requires a function name", Arg1
);
20016 Set_Is_Pure
(Def_Id
);
20018 if not Has_Pragma_Pure_Function
(Def_Id
) then
20019 Set_Has_Pragma_Pure_Function
(Def_Id
);
20023 exit when From_Aspect_Specification
(N
);
20025 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
20029 and then Warn_On_Redundant_Constructs
20032 ("pragma Pure_Function on& is redundant?r?",
20038 --------------------
20039 -- Queuing_Policy --
20040 --------------------
20042 -- pragma Queuing_Policy (policy_IDENTIFIER);
20044 when Pragma_Queuing_Policy
=> declare
20048 Check_Ada_83_Warning
;
20049 Check_Arg_Count
(1);
20050 Check_No_Identifiers
;
20051 Check_Arg_Is_Queuing_Policy
(Arg1
);
20052 Check_Valid_Configuration_Pragma
;
20053 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20054 QP
:= Fold_Upper
(Name_Buffer
(1));
20056 if Queuing_Policy
/= ' '
20057 and then Queuing_Policy
/= QP
20059 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
20060 Error_Pragma
("queuing policy incompatible with policy#");
20062 -- Set new policy, but always preserve System_Location since we
20063 -- like the error message with the run time name.
20066 Queuing_Policy
:= QP
;
20068 if Queuing_Policy_Sloc
/= System_Location
then
20069 Queuing_Policy_Sloc
:= Loc
;
20078 -- pragma Rational, for compatibility with foreign compiler
20080 when Pragma_Rational
=>
20081 Set_Rational_Profile
;
20083 ---------------------
20084 -- Refined_Depends --
20085 ---------------------
20087 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20089 -- DEPENDENCY_RELATION ::=
20091 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20093 -- DEPENDENCY_CLAUSE ::=
20094 -- OUTPUT_LIST =>[+] INPUT_LIST
20095 -- | NULL_DEPENDENCY_CLAUSE
20097 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20099 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20101 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20103 -- OUTPUT ::= NAME | FUNCTION_RESULT
20106 -- where FUNCTION_RESULT is a function Result attribute_reference
20108 -- Characteristics:
20110 -- * Analysis - The annotation undergoes initial checks to verify
20111 -- the legal placement and context. Secondary checks fully analyze
20112 -- the dependency clauses/global list in:
20114 -- Analyze_Refined_Depends_In_Decl_Part
20116 -- * Expansion - None.
20118 -- * Template - The annotation utilizes the generic template of the
20119 -- related subprogram body.
20121 -- * Globals - Capture of global references must occur after full
20124 -- * Instance - The annotation is instantiated automatically when
20125 -- the related generic subprogram body is instantiated.
20127 when Pragma_Refined_Depends
=> Refined_Depends
: declare
20128 Body_Id
: Entity_Id
;
20130 Spec_Id
: Entity_Id
;
20133 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20137 -- Chain the pragma on the contract for further processing by
20138 -- Analyze_Refined_Depends_In_Decl_Part.
20140 Add_Contract_Item
(N
, Body_Id
);
20142 -- The legality checks of pragmas Refined_Depends and
20143 -- Refined_Global are affected by the SPARK mode in effect and
20144 -- the volatility of the context. In addition these two pragmas
20145 -- are subject to an inherent order:
20147 -- 1) Refined_Global
20148 -- 2) Refined_Depends
20150 -- Analyze all these pragmas in the order outlined above
20152 Analyze_If_Present
(Pragma_SPARK_Mode
);
20153 Analyze_If_Present
(Pragma_Volatile_Function
);
20154 Analyze_If_Present
(Pragma_Refined_Global
);
20155 Analyze_Refined_Depends_In_Decl_Part
(N
);
20157 end Refined_Depends
;
20159 --------------------
20160 -- Refined_Global --
20161 --------------------
20163 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20165 -- GLOBAL_SPECIFICATION ::=
20168 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20170 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20172 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20173 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20174 -- GLOBAL_ITEM ::= NAME
20176 -- Characteristics:
20178 -- * Analysis - The annotation undergoes initial checks to verify
20179 -- the legal placement and context. Secondary checks fully analyze
20180 -- the dependency clauses/global list in:
20182 -- Analyze_Refined_Global_In_Decl_Part
20184 -- * Expansion - None.
20186 -- * Template - The annotation utilizes the generic template of the
20187 -- related subprogram body.
20189 -- * Globals - Capture of global references must occur after full
20192 -- * Instance - The annotation is instantiated automatically when
20193 -- the related generic subprogram body is instantiated.
20195 when Pragma_Refined_Global
=> Refined_Global
: declare
20196 Body_Id
: Entity_Id
;
20198 Spec_Id
: Entity_Id
;
20201 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20205 -- Chain the pragma on the contract for further processing by
20206 -- Analyze_Refined_Global_In_Decl_Part.
20208 Add_Contract_Item
(N
, Body_Id
);
20210 -- The legality checks of pragmas Refined_Depends and
20211 -- Refined_Global are affected by the SPARK mode in effect and
20212 -- the volatility of the context. In addition these two pragmas
20213 -- are subject to an inherent order:
20215 -- 1) Refined_Global
20216 -- 2) Refined_Depends
20218 -- Analyze all these pragmas in the order outlined above
20220 Analyze_If_Present
(Pragma_SPARK_Mode
);
20221 Analyze_If_Present
(Pragma_Volatile_Function
);
20222 Analyze_Refined_Global_In_Decl_Part
(N
);
20223 Analyze_If_Present
(Pragma_Refined_Depends
);
20225 end Refined_Global
;
20231 -- pragma Refined_Post (boolean_EXPRESSION);
20233 -- Characteristics:
20235 -- * Analysis - The annotation is fully analyzed immediately upon
20236 -- elaboration as it cannot forward reference entities.
20238 -- * Expansion - The annotation is expanded during the expansion of
20239 -- the related subprogram body contract as performed in:
20241 -- Expand_Subprogram_Contract
20243 -- * Template - The annotation utilizes the generic template of the
20244 -- related subprogram body.
20246 -- * Globals - Capture of global references must occur after full
20249 -- * Instance - The annotation is instantiated automatically when
20250 -- the related generic subprogram body is instantiated.
20252 when Pragma_Refined_Post
=> Refined_Post
: declare
20253 Body_Id
: Entity_Id
;
20255 Spec_Id
: Entity_Id
;
20258 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20260 -- Fully analyze the pragma when it appears inside a subprogram
20261 -- body because it cannot benefit from forward references.
20265 -- Chain the pragma on the contract for completeness
20267 Add_Contract_Item
(N
, Body_Id
);
20269 -- The legality checks of pragma Refined_Post are affected by
20270 -- the SPARK mode in effect and the volatility of the context.
20271 -- Analyze all pragmas in a specific order.
20273 Analyze_If_Present
(Pragma_SPARK_Mode
);
20274 Analyze_If_Present
(Pragma_Volatile_Function
);
20275 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
20277 -- Currently it is not possible to inline pre/postconditions on
20278 -- a subprogram subject to pragma Inline_Always.
20280 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
20284 -------------------
20285 -- Refined_State --
20286 -------------------
20288 -- pragma Refined_State (REFINEMENT_LIST);
20290 -- REFINEMENT_LIST ::=
20291 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20293 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20295 -- CONSTITUENT_LIST ::=
20298 -- | (CONSTITUENT {, CONSTITUENT})
20300 -- CONSTITUENT ::= object_NAME | state_NAME
20302 -- Characteristics:
20304 -- * Analysis - The annotation undergoes initial checks to verify
20305 -- the legal placement and context. Secondary checks preanalyze the
20306 -- refinement clauses in:
20308 -- Analyze_Refined_State_In_Decl_Part
20310 -- * Expansion - None.
20312 -- * Template - The annotation utilizes the template of the related
20315 -- * Globals - Capture of global references must occur after full
20318 -- * Instance - The annotation is instantiated automatically when
20319 -- the related generic package body is instantiated.
20321 when Pragma_Refined_State
=> Refined_State
: declare
20322 Pack_Decl
: Node_Id
;
20323 Spec_Id
: Entity_Id
;
20327 Check_No_Identifiers
;
20328 Check_Arg_Count
(1);
20330 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
20332 -- Ensure the proper placement of the pragma. Refined states must
20333 -- be associated with a package body.
20335 if Nkind
(Pack_Decl
) = N_Package_Body
then
20338 -- Otherwise the pragma is associated with an illegal construct
20345 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
20347 -- A pragma that applies to a Ghost entity becomes Ghost for the
20348 -- purposes of legality checks and removal of ignored Ghost code.
20350 Mark_Ghost_Pragma
(N
, Spec_Id
);
20352 -- Chain the pragma on the contract for further processing by
20353 -- Analyze_Refined_State_In_Decl_Part.
20355 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
20357 -- The legality checks of pragma Refined_State are affected by the
20358 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20360 Analyze_If_Present
(Pragma_SPARK_Mode
);
20362 -- State refinement is allowed only when the corresponding package
20363 -- declaration has non-null pragma Abstract_State. Refinement not
20364 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20366 if SPARK_Mode
/= Off
20368 (No
(Abstract_States
(Spec_Id
))
20369 or else Has_Null_Abstract_State
(Spec_Id
))
20372 ("useless refinement, package & does not define abstract "
20373 & "states", N
, Spec_Id
);
20378 -----------------------
20379 -- Relative_Deadline --
20380 -----------------------
20382 -- pragma Relative_Deadline (time_span_EXPRESSION);
20384 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
20385 P
: constant Node_Id
:= Parent
(N
);
20390 Check_No_Identifiers
;
20391 Check_Arg_Count
(1);
20393 Arg
:= Get_Pragma_Arg
(Arg1
);
20395 -- The expression must be analyzed in the special manner described
20396 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20398 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
20402 if Nkind
(P
) = N_Subprogram_Body
then
20403 Check_In_Main_Program
;
20405 -- Only Task and subprogram cases allowed
20407 elsif Nkind
(P
) /= N_Task_Definition
then
20411 -- Check duplicate pragma before we set the corresponding flag
20413 if Has_Relative_Deadline_Pragma
(P
) then
20414 Error_Pragma
("duplicate pragma% not allowed");
20417 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20418 -- Relative_Deadline pragma node cannot be inserted in the Rep
20419 -- Item chain of Ent since it is rewritten by the expander as a
20420 -- procedure call statement that will break the chain.
20422 Set_Has_Relative_Deadline_Pragma
(P
);
20423 end Relative_Deadline
;
20425 ------------------------
20426 -- Remote_Access_Type --
20427 ------------------------
20429 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20431 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
20436 Check_Arg_Count
(1);
20437 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20438 Check_Arg_Is_Local_Name
(Arg1
);
20440 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
20442 -- A pragma that applies to a Ghost entity becomes Ghost for the
20443 -- purposes of legality checks and removal of ignored Ghost code.
20445 Mark_Ghost_Pragma
(N
, E
);
20447 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
20448 and then Ekind
(E
) = E_General_Access_Type
20449 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
20450 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
20452 and then Is_Valid_Remote_Object_Type
20453 (Root_Type
(Directly_Designated_Type
(E
)))
20455 Set_Is_Remote_Types
(E
);
20459 ("pragma% applies only to formal access-to-class-wide types",
20462 end Remote_Access_Type
;
20464 ---------------------------
20465 -- Remote_Call_Interface --
20466 ---------------------------
20468 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20470 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
20471 Cunit_Node
: Node_Id
;
20472 Cunit_Ent
: Entity_Id
;
20476 Check_Ada_83_Warning
;
20477 Check_Valid_Library_Unit_Pragma
;
20479 if Nkind
(N
) = N_Null_Statement
then
20483 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20484 K
:= Nkind
(Unit
(Cunit_Node
));
20485 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20487 -- A pragma that applies to a Ghost entity becomes Ghost for the
20488 -- purposes of legality checks and removal of ignored Ghost code.
20490 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20492 if K
= N_Package_Declaration
20493 or else K
= N_Generic_Package_Declaration
20494 or else K
= N_Subprogram_Declaration
20495 or else K
= N_Generic_Subprogram_Declaration
20496 or else (K
= N_Subprogram_Body
20497 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
20502 "pragma% must apply to package or subprogram declaration");
20505 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
20506 end Remote_Call_Interface
;
20512 -- pragma Remote_Types [(library_unit_NAME)];
20514 when Pragma_Remote_Types
=> Remote_Types
: declare
20515 Cunit_Node
: Node_Id
;
20516 Cunit_Ent
: Entity_Id
;
20519 Check_Ada_83_Warning
;
20520 Check_Valid_Library_Unit_Pragma
;
20522 if Nkind
(N
) = N_Null_Statement
then
20526 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20527 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20529 -- A pragma that applies to a Ghost entity becomes Ghost for the
20530 -- purposes of legality checks and removal of ignored Ghost code.
20532 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20534 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20535 N_Generic_Package_Declaration
)
20538 ("pragma% can only apply to a package declaration");
20541 Set_Is_Remote_Types
(Cunit_Ent
);
20548 -- pragma Ravenscar;
20550 when Pragma_Ravenscar
=>
20552 Check_Arg_Count
(0);
20553 Check_Valid_Configuration_Pragma
;
20554 Set_Ravenscar_Profile
(Ravenscar
, N
);
20556 if Warn_On_Obsolescent_Feature
then
20558 ("pragma Ravenscar is an obsolescent feature?j?", N
);
20560 ("|use pragma Profile (Ravenscar) instead?j?", N
);
20563 -------------------------
20564 -- Restricted_Run_Time --
20565 -------------------------
20567 -- pragma Restricted_Run_Time;
20569 when Pragma_Restricted_Run_Time
=>
20571 Check_Arg_Count
(0);
20572 Check_Valid_Configuration_Pragma
;
20573 Set_Profile_Restrictions
20574 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
20576 if Warn_On_Obsolescent_Feature
then
20578 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20581 ("|use pragma Profile (Restricted) instead?j?", N
);
20588 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20591 -- restriction_IDENTIFIER
20592 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20594 when Pragma_Restrictions
=>
20595 Process_Restrictions_Or_Restriction_Warnings
20596 (Warn
=> Treat_Restrictions_As_Warnings
);
20598 --------------------------
20599 -- Restriction_Warnings --
20600 --------------------------
20602 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20605 -- restriction_IDENTIFIER
20606 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20608 when Pragma_Restriction_Warnings
=>
20610 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
20616 -- pragma Reviewable;
20618 when Pragma_Reviewable
=>
20619 Check_Ada_83_Warning
;
20620 Check_Arg_Count
(0);
20622 -- Call dummy debugging function rv. This is done to assist front
20623 -- end debugging. By placing a Reviewable pragma in the source
20624 -- program, a breakpoint on rv catches this place in the source,
20625 -- allowing convenient stepping to the point of interest.
20629 --------------------------
20630 -- Secondary_Stack_Size --
20631 --------------------------
20633 -- pragma Secondary_Stack_Size (EXPRESSION);
20635 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
20636 P
: constant Node_Id
:= Parent
(N
);
20642 Check_No_Identifiers
;
20643 Check_Arg_Count
(1);
20645 if Nkind
(P
) = N_Task_Definition
then
20646 Arg
:= Get_Pragma_Arg
(Arg1
);
20647 Ent
:= Defining_Identifier
(Parent
(P
));
20649 -- The expression must be analyzed in the special manner
20650 -- described in "Handling of Default Expressions" in sem.ads.
20652 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20654 -- The pragma cannot appear if the No_Secondary_Stack
20655 -- restriction is in effect.
20657 Check_Restriction
(No_Secondary_Stack
, Arg
);
20659 -- Anything else is incorrect
20665 -- Check duplicate pragma before we chain the pragma in the Rep
20666 -- Item chain of Ent.
20668 Check_Duplicate_Pragma
(Ent
);
20669 Record_Rep_Item
(Ent
, N
);
20670 end Secondary_Stack_Size
;
20672 --------------------------
20673 -- Short_Circuit_And_Or --
20674 --------------------------
20676 -- pragma Short_Circuit_And_Or;
20678 when Pragma_Short_Circuit_And_Or
=>
20680 Check_Arg_Count
(0);
20681 Check_Valid_Configuration_Pragma
;
20682 Short_Circuit_And_Or
:= True;
20684 -------------------
20685 -- Share_Generic --
20686 -------------------
20688 -- pragma Share_Generic (GNAME {, GNAME});
20690 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20692 when Pragma_Share_Generic
=>
20694 Process_Generic_List
;
20700 -- pragma Shared (LOCAL_NAME);
20702 when Pragma_Shared
=>
20704 Process_Atomic_Independent_Shared_Volatile
;
20706 --------------------
20707 -- Shared_Passive --
20708 --------------------
20710 -- pragma Shared_Passive [(library_unit_NAME)];
20712 -- Set the flag Is_Shared_Passive of program unit name entity
20714 when Pragma_Shared_Passive
=> Shared_Passive
: declare
20715 Cunit_Node
: Node_Id
;
20716 Cunit_Ent
: Entity_Id
;
20719 Check_Ada_83_Warning
;
20720 Check_Valid_Library_Unit_Pragma
;
20722 if Nkind
(N
) = N_Null_Statement
then
20726 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20727 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20729 -- A pragma that applies to a Ghost entity becomes Ghost for the
20730 -- purposes of legality checks and removal of ignored Ghost code.
20732 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20734 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20735 N_Generic_Package_Declaration
)
20738 ("pragma% can only apply to a package declaration");
20741 Set_Is_Shared_Passive
(Cunit_Ent
);
20742 end Shared_Passive
;
20744 -----------------------
20745 -- Short_Descriptors --
20746 -----------------------
20748 -- pragma Short_Descriptors;
20750 -- Recognize and validate, but otherwise ignore
20752 when Pragma_Short_Descriptors
=>
20754 Check_Arg_Count
(0);
20755 Check_Valid_Configuration_Pragma
;
20757 ------------------------------
20758 -- Simple_Storage_Pool_Type --
20759 ------------------------------
20761 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20763 when Pragma_Simple_Storage_Pool_Type
=>
20764 Simple_Storage_Pool_Type
: declare
20770 Check_Arg_Count
(1);
20771 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20773 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20774 Find_Type
(Type_Id
);
20775 Typ
:= Entity
(Type_Id
);
20777 if Typ
= Any_Type
then
20781 -- A pragma that applies to a Ghost entity becomes Ghost for the
20782 -- purposes of legality checks and removal of ignored Ghost code.
20784 Mark_Ghost_Pragma
(N
, Typ
);
20786 -- We require the pragma to apply to a type declared in a package
20787 -- declaration, but not (immediately) within a package body.
20789 if Ekind
(Current_Scope
) /= E_Package
20790 or else In_Package_Body
(Current_Scope
)
20793 ("pragma% can only apply to type declared immediately "
20794 & "within a package declaration");
20797 -- A simple storage pool type must be an immutably limited record
20798 -- or private type. If the pragma is given for a private type,
20799 -- the full type is similarly restricted (which is checked later
20800 -- in Freeze_Entity).
20802 if Is_Record_Type
(Typ
)
20803 and then not Is_Limited_View
(Typ
)
20806 ("pragma% can only apply to explicitly limited record type");
20808 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
20810 ("pragma% can only apply to a private type that is limited");
20812 elsif not Is_Record_Type
(Typ
)
20813 and then not Is_Private_Type
(Typ
)
20816 ("pragma% can only apply to limited record or private type");
20819 Record_Rep_Item
(Typ
, N
);
20820 end Simple_Storage_Pool_Type
;
20822 ----------------------
20823 -- Source_File_Name --
20824 ----------------------
20826 -- There are five forms for this pragma:
20828 -- pragma Source_File_Name (
20829 -- [UNIT_NAME =>] unit_NAME,
20830 -- BODY_FILE_NAME => STRING_LITERAL
20831 -- [, [INDEX =>] INTEGER_LITERAL]);
20833 -- pragma Source_File_Name (
20834 -- [UNIT_NAME =>] unit_NAME,
20835 -- SPEC_FILE_NAME => STRING_LITERAL
20836 -- [, [INDEX =>] INTEGER_LITERAL]);
20838 -- pragma Source_File_Name (
20839 -- BODY_FILE_NAME => STRING_LITERAL
20840 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20841 -- [, CASING => CASING_SPEC]);
20843 -- pragma Source_File_Name (
20844 -- SPEC_FILE_NAME => STRING_LITERAL
20845 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20846 -- [, CASING => CASING_SPEC]);
20848 -- pragma Source_File_Name (
20849 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20850 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20851 -- [, CASING => CASING_SPEC]);
20853 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20855 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20856 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20857 -- only be used when no project file is used, while SFNP can only be
20858 -- used when a project file is used.
20860 -- No processing here. Processing was completed during parsing, since
20861 -- we need to have file names set as early as possible. Units are
20862 -- loaded well before semantic processing starts.
20864 -- The only processing we defer to this point is the check for
20865 -- correct placement.
20867 when Pragma_Source_File_Name
=>
20869 Check_Valid_Configuration_Pragma
;
20871 ------------------------------
20872 -- Source_File_Name_Project --
20873 ------------------------------
20875 -- See Source_File_Name for syntax
20877 -- No processing here. Processing was completed during parsing, since
20878 -- we need to have file names set as early as possible. Units are
20879 -- loaded well before semantic processing starts.
20881 -- The only processing we defer to this point is the check for
20882 -- correct placement.
20884 when Pragma_Source_File_Name_Project
=>
20886 Check_Valid_Configuration_Pragma
;
20888 -- Check that a pragma Source_File_Name_Project is used only in a
20889 -- configuration pragmas file.
20891 -- Pragmas Source_File_Name_Project should only be generated by
20892 -- the Project Manager in configuration pragmas files.
20894 -- This is really an ugly test. It seems to depend on some
20895 -- accidental and undocumented property. At the very least it
20896 -- needs to be documented, but it would be better to have a
20897 -- clean way of testing if we are in a configuration file???
20899 if Present
(Parent
(N
)) then
20901 ("pragma% can only appear in a configuration pragmas file");
20904 ----------------------
20905 -- Source_Reference --
20906 ----------------------
20908 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20910 -- Nothing to do, all processing completed in Par.Prag, since we need
20911 -- the information for possible parser messages that are output.
20913 when Pragma_Source_Reference
=>
20920 -- pragma SPARK_Mode [(On | Off)];
20922 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
20923 Mode_Id
: SPARK_Mode_Type
;
20925 procedure Check_Pragma_Conformance
20926 (Context_Pragma
: Node_Id
;
20927 Entity
: Entity_Id
;
20928 Entity_Pragma
: Node_Id
);
20929 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20930 -- conformance of pragma N depending the following scenarios:
20932 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20933 -- compatible with the pragma Context_Pragma that was inherited
20934 -- from the context:
20935 -- * If the mode of Context_Pragma is ON, then the new mode can
20937 -- * If the mode of Context_Pragma is OFF, then the only allowed
20938 -- new mode is also OFF. Emit error if this is not the case.
20940 -- If Entity is not Empty, verify that pragma N is compatible with
20941 -- pragma Entity_Pragma that belongs to Entity.
20942 -- * If Entity_Pragma is Empty, always issue an error as this
20943 -- corresponds to the case where a previous section of Entity
20944 -- has no SPARK_Mode set.
20945 -- * If the mode of Entity_Pragma is ON, then the new mode can
20947 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20948 -- new mode is also OFF. Emit error if this is not the case.
20950 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
20951 -- Subsidiary to routines Process_xxx. Verify that the related
20952 -- entity E subject to pragma SPARK_Mode is library-level.
20954 procedure Process_Body
(Decl
: Node_Id
);
20955 -- Verify the legality of pragma SPARK_Mode when it appears as the
20956 -- top of the body declarations of entry, package, protected unit,
20957 -- subprogram or task unit body denoted by Decl.
20959 procedure Process_Overloadable
(Decl
: Node_Id
);
20960 -- Verify the legality of pragma SPARK_Mode when it applies to an
20961 -- entry or [generic] subprogram declaration denoted by Decl.
20963 procedure Process_Private_Part
(Decl
: Node_Id
);
20964 -- Verify the legality of pragma SPARK_Mode when it appears at the
20965 -- top of the private declarations of a package spec, protected or
20966 -- task unit declaration denoted by Decl.
20968 procedure Process_Statement_Part
(Decl
: Node_Id
);
20969 -- Verify the legality of pragma SPARK_Mode when it appears at the
20970 -- top of the statement sequence of a package body denoted by node
20973 procedure Process_Visible_Part
(Decl
: Node_Id
);
20974 -- Verify the legality of pragma SPARK_Mode when it appears at the
20975 -- top of the visible declarations of a package spec, protected or
20976 -- task unit declaration denoted by Decl. The routine is also used
20977 -- on protected or task units declared without a definition.
20979 procedure Set_SPARK_Context
;
20980 -- Subsidiary to routines Process_xxx. Set the global variables
20981 -- which represent the mode of the context from pragma N. Ensure
20982 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20984 ------------------------------
20985 -- Check_Pragma_Conformance --
20986 ------------------------------
20988 procedure Check_Pragma_Conformance
20989 (Context_Pragma
: Node_Id
;
20990 Entity
: Entity_Id
;
20991 Entity_Pragma
: Node_Id
)
20993 Err_Id
: Entity_Id
;
20997 -- The current pragma may appear without an argument. If this
20998 -- is the case, associate all error messages with the pragma
21001 if Present
(Arg1
) then
21007 -- The mode of the current pragma is compared against that of
21008 -- an enclosing context.
21010 if Present
(Context_Pragma
) then
21011 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
21013 -- Issue an error if the new mode is less restrictive than
21014 -- that of the context.
21016 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
21017 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21020 ("cannot change SPARK_Mode from Off to On", Err_N
);
21021 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21022 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
21027 -- The mode of the current pragma is compared against that of
21028 -- an initial package, protected type, subprogram or task type
21031 if Present
(Entity
) then
21033 -- A simple protected or task type is transformed into an
21034 -- anonymous type whose name cannot be used to issue error
21035 -- messages. Recover the original entity of the type.
21037 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
21040 (Original_Node
(Unit_Declaration_Node
(Entity
)));
21045 -- Both the initial declaration and the completion carry
21046 -- SPARK_Mode pragmas.
21048 if Present
(Entity_Pragma
) then
21049 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
21051 -- Issue an error if the new mode is less restrictive
21052 -- than that of the initial declaration.
21054 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
21055 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21057 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21058 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
21060 ("\value Off was set for SPARK_Mode on&#",
21065 -- Otherwise the initial declaration lacks a SPARK_Mode
21066 -- pragma in which case the current pragma is illegal as
21067 -- it cannot "complete".
21070 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21071 Error_Msg_Sloc
:= Sloc
(Err_Id
);
21073 ("\no value was set for SPARK_Mode on&#",
21078 end Check_Pragma_Conformance
;
21080 --------------------------------
21081 -- Check_Library_Level_Entity --
21082 --------------------------------
21084 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
21085 procedure Add_Entity_To_Name_Buffer
;
21086 -- Add the E_Kind of entity E to the name buffer
21088 -------------------------------
21089 -- Add_Entity_To_Name_Buffer --
21090 -------------------------------
21092 procedure Add_Entity_To_Name_Buffer
is
21094 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
21095 Add_Str_To_Name_Buffer
("entry");
21097 elsif Ekind_In
(E
, E_Generic_Package
,
21101 Add_Str_To_Name_Buffer
("package");
21103 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
21104 Add_Str_To_Name_Buffer
("protected type");
21106 elsif Ekind_In
(E
, E_Function
,
21107 E_Generic_Function
,
21108 E_Generic_Procedure
,
21112 Add_Str_To_Name_Buffer
("subprogram");
21115 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
21116 Add_Str_To_Name_Buffer
("task type");
21118 end Add_Entity_To_Name_Buffer
;
21122 Msg_1
: constant String := "incorrect placement of pragma%";
21125 -- Start of processing for Check_Library_Level_Entity
21128 if not Is_Library_Level_Entity
(E
) then
21129 Error_Msg_Name_1
:= Pname
;
21130 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
21133 Add_Str_To_Name_Buffer
("\& is not a library-level ");
21134 Add_Entity_To_Name_Buffer
;
21136 Msg_2
:= Name_Find
;
21137 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
21141 end Check_Library_Level_Entity
;
21147 procedure Process_Body
(Decl
: Node_Id
) is
21148 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21149 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
21152 -- Ignore pragma when applied to the special body created for
21153 -- inlining, recognized by its internal name _Parent.
21155 if Chars
(Body_Id
) = Name_uParent
then
21159 Check_Library_Level_Entity
(Body_Id
);
21161 -- For entry bodies, verify the legality against:
21162 -- * The mode of the context
21163 -- * The mode of the spec (if any)
21165 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
21167 -- A stand alone subprogram body
21169 if Body_Id
= Spec_Id
then
21170 Check_Pragma_Conformance
21171 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21173 Entity_Pragma
=> Empty
);
21175 -- An entry or subprogram body that completes a previous
21179 Check_Pragma_Conformance
21180 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21182 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21186 Set_SPARK_Pragma
(Body_Id
, N
);
21187 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21189 -- For package bodies, verify the legality against:
21190 -- * The mode of the context
21191 -- * The mode of the private part
21193 -- This case is separated from protected and task bodies
21194 -- because the statement part of the package body inherits
21195 -- the mode of the body declarations.
21197 elsif Nkind
(Decl
) = N_Package_Body
then
21198 Check_Pragma_Conformance
21199 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21201 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21204 Set_SPARK_Pragma
(Body_Id
, N
);
21205 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21206 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21207 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
21209 -- For protected and task bodies, verify the legality against:
21210 -- * The mode of the context
21211 -- * The mode of the private part
21215 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
21217 Check_Pragma_Conformance
21218 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21220 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21223 Set_SPARK_Pragma
(Body_Id
, N
);
21224 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21228 --------------------------
21229 -- Process_Overloadable --
21230 --------------------------
21232 procedure Process_Overloadable
(Decl
: Node_Id
) is
21233 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21234 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
21237 Check_Library_Level_Entity
(Spec_Id
);
21239 -- Verify the legality against:
21240 -- * The mode of the context
21242 Check_Pragma_Conformance
21243 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21245 Entity_Pragma
=> Empty
);
21247 Set_SPARK_Pragma
(Spec_Id
, N
);
21248 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21250 -- When the pragma applies to the anonymous object created for
21251 -- a single task type, decorate the type as well. This scenario
21252 -- arises when the single task type lacks a task definition,
21253 -- therefore there is no issue with respect to a potential
21254 -- pragma SPARK_Mode in the private part.
21256 -- task type Anon_Task_Typ;
21257 -- Obj : Anon_Task_Typ;
21258 -- pragma SPARK_Mode ...;
21260 if Is_Single_Task_Object
(Spec_Id
) then
21261 Set_SPARK_Pragma
(Spec_Typ
, N
);
21262 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
21263 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
21264 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
21266 end Process_Overloadable
;
21268 --------------------------
21269 -- Process_Private_Part --
21270 --------------------------
21272 procedure Process_Private_Part
(Decl
: Node_Id
) is
21273 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21276 Check_Library_Level_Entity
(Spec_Id
);
21278 -- Verify the legality against:
21279 -- * The mode of the visible declarations
21281 Check_Pragma_Conformance
21282 (Context_Pragma
=> Empty
,
21284 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21287 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21288 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
21289 end Process_Private_Part
;
21291 ----------------------------
21292 -- Process_Statement_Part --
21293 ----------------------------
21295 procedure Process_Statement_Part
(Decl
: Node_Id
) is
21296 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21299 Check_Library_Level_Entity
(Body_Id
);
21301 -- Verify the legality against:
21302 -- * The mode of the body declarations
21304 Check_Pragma_Conformance
21305 (Context_Pragma
=> Empty
,
21307 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
21310 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21311 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
21312 end Process_Statement_Part
;
21314 --------------------------
21315 -- Process_Visible_Part --
21316 --------------------------
21318 procedure Process_Visible_Part
(Decl
: Node_Id
) is
21319 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21320 Obj_Id
: Entity_Id
;
21323 Check_Library_Level_Entity
(Spec_Id
);
21325 -- Verify the legality against:
21326 -- * The mode of the context
21328 Check_Pragma_Conformance
21329 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21331 Entity_Pragma
=> Empty
);
21333 -- A task unit declared without a definition does not set the
21334 -- SPARK_Mode of the context because the task does not have any
21335 -- entries that could inherit the mode.
21337 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
21338 N_Task_Type_Declaration
)
21343 Set_SPARK_Pragma
(Spec_Id
, N
);
21344 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21345 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21346 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
21348 -- When the pragma applies to a single protected or task type,
21349 -- decorate the corresponding anonymous object as well.
21351 -- protected Anon_Prot_Typ is
21352 -- pragma SPARK_Mode ...;
21354 -- end Anon_Prot_Typ;
21356 -- Obj : Anon_Prot_Typ;
21358 if Is_Single_Concurrent_Type
(Spec_Id
) then
21359 Obj_Id
:= Anonymous_Object
(Spec_Id
);
21361 Set_SPARK_Pragma
(Obj_Id
, N
);
21362 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
21364 end Process_Visible_Part
;
21366 -----------------------
21367 -- Set_SPARK_Context --
21368 -----------------------
21370 procedure Set_SPARK_Context
is
21372 SPARK_Mode
:= Mode_Id
;
21373 SPARK_Mode_Pragma
:= N
;
21374 end Set_SPARK_Context
;
21382 -- Start of processing for Do_SPARK_Mode
21385 -- When a SPARK_Mode pragma appears inside an instantiation whose
21386 -- enclosing context has SPARK_Mode set to "off", the pragma has
21387 -- no semantic effect.
21389 if Ignore_Pragma_SPARK_Mode
then
21390 Rewrite
(N
, Make_Null_Statement
(Loc
));
21396 Check_No_Identifiers
;
21397 Check_At_Most_N_Arguments
(1);
21399 -- Check the legality of the mode (no argument = ON)
21401 if Arg_Count
= 1 then
21402 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21403 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
21408 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
21409 Context
:= Parent
(N
);
21411 -- The pragma appears in a configuration file
21413 if No
(Context
) then
21414 Check_Valid_Configuration_Pragma
;
21416 if Present
(SPARK_Mode_Pragma
) then
21417 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21418 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
21424 -- The pragma acts as a configuration pragma in a compilation unit
21426 -- pragma SPARK_Mode ...;
21427 -- package Pack is ...;
21429 elsif Nkind
(Context
) = N_Compilation_Unit
21430 and then List_Containing
(N
) = Context_Items
(Context
)
21432 Check_Valid_Configuration_Pragma
;
21435 -- Otherwise the placement of the pragma within the tree dictates
21436 -- its associated construct. Inspect the declarative list where
21437 -- the pragma resides to find a potential construct.
21441 while Present
(Stmt
) loop
21443 -- Skip prior pragmas, but check for duplicates. Note that
21444 -- this also takes care of pragmas generated for aspects.
21446 if Nkind
(Stmt
) = N_Pragma
then
21447 if Pragma_Name
(Stmt
) = Pname
then
21448 Error_Msg_Name_1
:= Pname
;
21449 Error_Msg_Sloc
:= Sloc
(Stmt
);
21450 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
21454 -- The pragma applies to an expression function that has
21455 -- already been rewritten into a subprogram declaration.
21457 -- function Expr_Func return ... is (...);
21458 -- pragma SPARK_Mode ...;
21460 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
21461 and then Nkind
(Original_Node
(Stmt
)) =
21462 N_Expression_Function
21464 Process_Overloadable
(Stmt
);
21467 -- The pragma applies to the anonymous object created for a
21468 -- single concurrent type.
21470 -- protected type Anon_Prot_Typ ...;
21471 -- Obj : Anon_Prot_Typ;
21472 -- pragma SPARK_Mode ...;
21474 elsif Nkind
(Stmt
) = N_Object_Declaration
21475 and then Is_Single_Concurrent_Object
21476 (Defining_Entity
(Stmt
))
21478 Process_Overloadable
(Stmt
);
21481 -- Skip internally generated code
21483 elsif not Comes_From_Source
(Stmt
) then
21486 -- The pragma applies to an entry or [generic] subprogram
21490 -- pragma SPARK_Mode ...;
21493 -- procedure Proc ...;
21494 -- pragma SPARK_Mode ...;
21496 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
21497 N_Subprogram_Declaration
)
21498 or else (Nkind
(Stmt
) = N_Entry_Declaration
21499 and then Is_Protected_Type
21500 (Scope
(Defining_Entity
(Stmt
))))
21502 Process_Overloadable
(Stmt
);
21505 -- Otherwise the pragma does not apply to a legal construct
21506 -- or it does not appear at the top of a declarative or a
21507 -- statement list. Issue an error and stop the analysis.
21517 -- The pragma applies to a package or a subprogram that acts as
21518 -- a compilation unit.
21520 -- procedure Proc ...;
21521 -- pragma SPARK_Mode ...;
21523 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
21524 Context
:= Unit
(Parent
(Context
));
21527 -- The pragma appears at the top of entry, package, protected
21528 -- unit, subprogram or task unit body declarations.
21530 -- entry Ent when ... is
21531 -- pragma SPARK_Mode ...;
21533 -- package body Pack is
21534 -- pragma SPARK_Mode ...;
21536 -- procedure Proc ... is
21537 -- pragma SPARK_Mode;
21539 -- protected body Prot is
21540 -- pragma SPARK_Mode ...;
21542 if Nkind_In
(Context
, N_Entry_Body
,
21548 Process_Body
(Context
);
21550 -- The pragma appears at the top of the visible or private
21551 -- declaration of a package spec, protected or task unit.
21554 -- pragma SPARK_Mode ...;
21556 -- pragma SPARK_Mode ...;
21558 -- protected [type] Prot is
21559 -- pragma SPARK_Mode ...;
21561 -- pragma SPARK_Mode ...;
21563 elsif Nkind_In
(Context
, N_Package_Specification
,
21564 N_Protected_Definition
,
21567 if List_Containing
(N
) = Visible_Declarations
(Context
) then
21568 Process_Visible_Part
(Parent
(Context
));
21570 Process_Private_Part
(Parent
(Context
));
21573 -- The pragma appears at the top of package body statements
21575 -- package body Pack is
21577 -- pragma SPARK_Mode;
21579 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
21580 and then Nkind
(Parent
(Context
)) = N_Package_Body
21582 Process_Statement_Part
(Parent
(Context
));
21584 -- The pragma appeared as an aspect of a [generic] subprogram
21585 -- declaration that acts as a compilation unit.
21588 -- procedure Proc ...;
21589 -- pragma SPARK_Mode ...;
21591 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
21592 N_Subprogram_Declaration
)
21594 Process_Overloadable
(Context
);
21596 -- The pragma does not apply to a legal construct, issue error
21604 --------------------------------
21605 -- Static_Elaboration_Desired --
21606 --------------------------------
21608 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21610 when Pragma_Static_Elaboration_Desired
=>
21612 Check_At_Most_N_Arguments
(1);
21614 if Is_Compilation_Unit
(Current_Scope
)
21615 and then Ekind
(Current_Scope
) = E_Package
21617 Set_Static_Elaboration_Desired
(Current_Scope
, True);
21619 Error_Pragma
("pragma% must apply to a library-level package");
21626 -- pragma Storage_Size (EXPRESSION);
21628 when Pragma_Storage_Size
=> Storage_Size
: declare
21629 P
: constant Node_Id
:= Parent
(N
);
21633 Check_No_Identifiers
;
21634 Check_Arg_Count
(1);
21636 -- The expression must be analyzed in the special manner described
21637 -- in "Handling of Default Expressions" in sem.ads.
21639 Arg
:= Get_Pragma_Arg
(Arg1
);
21640 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21642 if not Is_OK_Static_Expression
(Arg
) then
21643 Check_Restriction
(Static_Storage_Size
, Arg
);
21646 if Nkind
(P
) /= N_Task_Definition
then
21651 if Has_Storage_Size_Pragma
(P
) then
21652 Error_Pragma
("duplicate pragma% not allowed");
21654 Set_Has_Storage_Size_Pragma
(P
, True);
21657 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
21665 -- pragma Storage_Unit (NUMERIC_LITERAL);
21667 -- Only permitted argument is System'Storage_Unit value
21669 when Pragma_Storage_Unit
=>
21670 Check_No_Identifiers
;
21671 Check_Arg_Count
(1);
21672 Check_Arg_Is_Integer_Literal
(Arg1
);
21674 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
21675 UI_From_Int
(Ttypes
.System_Storage_Unit
)
21677 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
21679 ("the only allowed argument for pragma% is ^", Arg1
);
21682 --------------------
21683 -- Stream_Convert --
21684 --------------------
21686 -- pragma Stream_Convert (
21687 -- [Entity =>] type_LOCAL_NAME,
21688 -- [Read =>] function_NAME,
21689 -- [Write =>] function NAME);
21691 when Pragma_Stream_Convert
=> Stream_Convert
: declare
21692 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
21693 -- Check that the given argument is the name of a local function
21694 -- of one argument that is not overloaded earlier in the current
21695 -- local scope. A check is also made that the argument is a
21696 -- function with one parameter.
21698 --------------------------------------
21699 -- Check_OK_Stream_Convert_Function --
21700 --------------------------------------
21702 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
21706 Check_Arg_Is_Local_Name
(Arg
);
21707 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
21709 if Has_Homonym
(Ent
) then
21711 ("argument for pragma% may not be overloaded", Arg
);
21714 if Ekind
(Ent
) /= E_Function
21715 or else No
(First_Formal
(Ent
))
21716 or else Present
(Next_Formal
(First_Formal
(Ent
)))
21719 ("argument for pragma% must be function of one argument",
21722 end Check_OK_Stream_Convert_Function
;
21724 -- Start of processing for Stream_Convert
21728 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
21729 Check_Arg_Count
(3);
21730 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21731 Check_Optional_Identifier
(Arg2
, Name_Read
);
21732 Check_Optional_Identifier
(Arg3
, Name_Write
);
21733 Check_Arg_Is_Local_Name
(Arg1
);
21734 Check_OK_Stream_Convert_Function
(Arg2
);
21735 Check_OK_Stream_Convert_Function
(Arg3
);
21738 Typ
: constant Entity_Id
:=
21739 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
21740 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
21741 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
21744 Check_First_Subtype
(Arg1
);
21746 -- Check for too early or too late. Note that we don't enforce
21747 -- the rule about primitive operations in this case, since, as
21748 -- is the case for explicit stream attributes themselves, these
21749 -- restrictions are not appropriate. Note that the chaining of
21750 -- the pragma by Rep_Item_Too_Late is actually the critical
21751 -- processing done for this pragma.
21753 if Rep_Item_Too_Early
(Typ
, N
)
21755 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
21760 -- Return if previous error
21762 if Etype
(Typ
) = Any_Type
21764 Etype
(Read
) = Any_Type
21766 Etype
(Write
) = Any_Type
21773 if Underlying_Type
(Etype
(Read
)) /= Typ
then
21775 ("incorrect return type for function&", Arg2
);
21778 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
21780 ("incorrect parameter type for function&", Arg3
);
21783 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
21784 Underlying_Type
(Etype
(Write
))
21787 ("result type of & does not match Read parameter type",
21791 end Stream_Convert
;
21797 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21799 -- This is processed by the parser since some of the style checks
21800 -- take place during source scanning and parsing. This means that
21801 -- we don't need to issue error messages here.
21803 when Pragma_Style_Checks
=> Style_Checks
: declare
21804 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21810 Check_No_Identifiers
;
21812 -- Two argument form
21814 if Arg_Count
= 2 then
21815 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21822 E_Id
:= Get_Pragma_Arg
(Arg2
);
21825 if not Is_Entity_Name
(E_Id
) then
21827 ("second argument of pragma% must be entity name",
21831 E
:= Entity
(E_Id
);
21833 if not Ignore_Style_Checks_Pragmas
then
21838 Set_Suppress_Style_Checks
21839 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
21840 exit when No
(Homonym
(E
));
21847 -- One argument form
21850 Check_Arg_Count
(1);
21852 if Nkind
(A
) = N_String_Literal
then
21856 Slen
: constant Natural := Natural (String_Length
(S
));
21857 Options
: String (1 .. Slen
);
21863 C
:= Get_String_Char
(S
, Pos
(J
));
21864 exit when not In_Character_Range
(C
);
21865 Options
(J
) := Get_Character
(C
);
21867 -- If at end of string, set options. As per discussion
21868 -- above, no need to check for errors, since we issued
21869 -- them in the parser.
21872 if not Ignore_Style_Checks_Pragmas
then
21873 Set_Style_Check_Options
(Options
);
21883 elsif Nkind
(A
) = N_Identifier
then
21884 if Chars
(A
) = Name_All_Checks
then
21885 if not Ignore_Style_Checks_Pragmas
then
21887 Set_GNAT_Style_Check_Options
;
21889 Set_Default_Style_Check_Options
;
21893 elsif Chars
(A
) = Name_On
then
21894 if not Ignore_Style_Checks_Pragmas
then
21895 Style_Check
:= True;
21898 elsif Chars
(A
) = Name_Off
then
21899 if not Ignore_Style_Checks_Pragmas
then
21900 Style_Check
:= False;
21911 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21913 when Pragma_Subtitle
=>
21915 Check_Arg_Count
(1);
21916 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
21917 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21924 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21926 when Pragma_Suppress
=>
21927 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
21933 -- pragma Suppress_All;
21935 -- The only check made here is that the pragma has no arguments.
21936 -- There are no placement rules, and the processing required (setting
21937 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21938 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21939 -- then creates and inserts a pragma Suppress (All_Checks).
21941 when Pragma_Suppress_All
=>
21943 Check_Arg_Count
(0);
21945 -------------------------
21946 -- Suppress_Debug_Info --
21947 -------------------------
21949 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21951 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
21952 Nam_Id
: Entity_Id
;
21956 Check_Arg_Count
(1);
21957 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21958 Check_Arg_Is_Local_Name
(Arg1
);
21960 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21962 -- A pragma that applies to a Ghost entity becomes Ghost for the
21963 -- purposes of legality checks and removal of ignored Ghost code.
21965 Mark_Ghost_Pragma
(N
, Nam_Id
);
21966 Set_Debug_Info_Off
(Nam_Id
);
21967 end Suppress_Debug_Info
;
21969 ----------------------------------
21970 -- Suppress_Exception_Locations --
21971 ----------------------------------
21973 -- pragma Suppress_Exception_Locations;
21975 when Pragma_Suppress_Exception_Locations
=>
21977 Check_Arg_Count
(0);
21978 Check_Valid_Configuration_Pragma
;
21979 Exception_Locations_Suppressed
:= True;
21981 -----------------------------
21982 -- Suppress_Initialization --
21983 -----------------------------
21985 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21987 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
21993 Check_Arg_Count
(1);
21994 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21995 Check_Arg_Is_Local_Name
(Arg1
);
21997 E_Id
:= Get_Pragma_Arg
(Arg1
);
21999 if Etype
(E_Id
) = Any_Type
then
22003 E
:= Entity
(E_Id
);
22005 -- A pragma that applies to a Ghost entity becomes Ghost for the
22006 -- purposes of legality checks and removal of ignored Ghost code.
22008 Mark_Ghost_Pragma
(N
, E
);
22010 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
22012 ("pragma% requires variable, type or subtype", Arg1
);
22015 if Rep_Item_Too_Early
(E
, N
)
22017 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
22022 -- For incomplete/private type, set flag on full view
22024 if Is_Incomplete_Or_Private_Type
(E
) then
22025 if No
(Full_View
(Base_Type
(E
))) then
22027 ("argument of pragma% cannot be an incomplete type", Arg1
);
22029 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
22032 -- For first subtype, set flag on base type
22034 elsif Is_First_Subtype
(E
) then
22035 Set_Suppress_Initialization
(Base_Type
(E
));
22037 -- For other than first subtype, set flag on subtype or variable
22040 Set_Suppress_Initialization
(E
);
22048 -- pragma System_Name (DIRECT_NAME);
22050 -- Syntax check: one argument, which must be the identifier GNAT or
22051 -- the identifier GCC, no other identifiers are acceptable.
22053 when Pragma_System_Name
=>
22055 Check_No_Identifiers
;
22056 Check_Arg_Count
(1);
22057 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
22059 -----------------------------
22060 -- Task_Dispatching_Policy --
22061 -----------------------------
22063 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22065 when Pragma_Task_Dispatching_Policy
=> declare
22069 Check_Ada_83_Warning
;
22070 Check_Arg_Count
(1);
22071 Check_No_Identifiers
;
22072 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22073 Check_Valid_Configuration_Pragma
;
22074 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22075 DP
:= Fold_Upper
(Name_Buffer
(1));
22077 if Task_Dispatching_Policy
/= ' '
22078 and then Task_Dispatching_Policy
/= DP
22080 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22082 ("task dispatching policy incompatible with policy#");
22084 -- Set new policy, but always preserve System_Location since we
22085 -- like the error message with the run time name.
22088 Task_Dispatching_Policy
:= DP
;
22090 if Task_Dispatching_Policy_Sloc
/= System_Location
then
22091 Task_Dispatching_Policy_Sloc
:= Loc
;
22100 -- pragma Task_Info (EXPRESSION);
22102 when Pragma_Task_Info
=> Task_Info
: declare
22103 P
: constant Node_Id
:= Parent
(N
);
22109 if Warn_On_Obsolescent_Feature
then
22111 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22112 & "instead?j?", N
);
22115 if Nkind
(P
) /= N_Task_Definition
then
22116 Error_Pragma
("pragma% must appear in task definition");
22119 Check_No_Identifiers
;
22120 Check_Arg_Count
(1);
22122 Analyze_And_Resolve
22123 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
22125 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
22129 Ent
:= Defining_Identifier
(Parent
(P
));
22131 -- Check duplicate pragma before we chain the pragma in the Rep
22132 -- Item chain of Ent.
22135 (Ent
, Name_Task_Info
, Check_Parents
=> False)
22137 Error_Pragma
("duplicate pragma% not allowed");
22140 Record_Rep_Item
(Ent
, N
);
22147 -- pragma Task_Name (string_EXPRESSION);
22149 when Pragma_Task_Name
=> Task_Name
: declare
22150 P
: constant Node_Id
:= Parent
(N
);
22155 Check_No_Identifiers
;
22156 Check_Arg_Count
(1);
22158 Arg
:= Get_Pragma_Arg
(Arg1
);
22160 -- The expression is used in the call to Create_Task, and must be
22161 -- expanded there, not in the context of the current spec. It must
22162 -- however be analyzed to capture global references, in case it
22163 -- appears in a generic context.
22165 Preanalyze_And_Resolve
(Arg
, Standard_String
);
22167 if Nkind
(P
) /= N_Task_Definition
then
22171 Ent
:= Defining_Identifier
(Parent
(P
));
22173 -- Check duplicate pragma before we chain the pragma in the Rep
22174 -- Item chain of Ent.
22177 (Ent
, Name_Task_Name
, Check_Parents
=> False)
22179 Error_Pragma
("duplicate pragma% not allowed");
22182 Record_Rep_Item
(Ent
, N
);
22189 -- pragma Task_Storage (
22190 -- [Task_Type =>] LOCAL_NAME,
22191 -- [Top_Guard =>] static_integer_EXPRESSION);
22193 when Pragma_Task_Storage
=> Task_Storage
: declare
22194 Args
: Args_List
(1 .. 2);
22195 Names
: constant Name_List
(1 .. 2) := (
22199 Task_Type
: Node_Id
renames Args
(1);
22200 Top_Guard
: Node_Id
renames Args
(2);
22206 Gather_Associations
(Names
, Args
);
22208 if No
(Task_Type
) then
22210 ("missing task_type argument for pragma%");
22213 Check_Arg_Is_Local_Name
(Task_Type
);
22215 Ent
:= Entity
(Task_Type
);
22217 if not Is_Task_Type
(Ent
) then
22219 ("argument for pragma% must be task type", Task_Type
);
22222 if No
(Top_Guard
) then
22224 ("pragma% takes two arguments", Task_Type
);
22226 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
22229 Check_First_Subtype
(Task_Type
);
22231 if Rep_Item_Too_Late
(Ent
, N
) then
22240 -- pragma Test_Case
22241 -- ([Name =>] Static_String_EXPRESSION
22242 -- ,[Mode =>] MODE_TYPE
22243 -- [, Requires => Boolean_EXPRESSION]
22244 -- [, Ensures => Boolean_EXPRESSION]);
22246 -- MODE_TYPE ::= Nominal | Robustness
22248 -- Characteristics:
22250 -- * Analysis - The annotation undergoes initial checks to verify
22251 -- the legal placement and context. Secondary checks preanalyze the
22254 -- Analyze_Test_Case_In_Decl_Part
22256 -- * Expansion - None.
22258 -- * Template - The annotation utilizes the generic template of the
22259 -- related subprogram when it is:
22261 -- aspect on subprogram declaration
22263 -- The annotation must prepare its own template when it is:
22265 -- pragma on subprogram declaration
22267 -- * Globals - Capture of global references must occur after full
22270 -- * Instance - The annotation is instantiated automatically when
22271 -- the related generic subprogram is instantiated except for the
22272 -- "pragma on subprogram declaration" case. In that scenario the
22273 -- annotation must instantiate itself.
22275 when Pragma_Test_Case
=> Test_Case
: declare
22276 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
22277 -- Ensure that the contract of subprogram Subp_Id does not contain
22278 -- another Test_Case pragma with the same Name as the current one.
22280 -------------------------
22281 -- Check_Distinct_Name --
22282 -------------------------
22284 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
22285 Items
: constant Node_Id
:= Contract
(Subp_Id
);
22286 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
22290 -- Inspect all Test_Case pragma of the related subprogram
22291 -- looking for one with a duplicate "Name" argument.
22293 if Present
(Items
) then
22294 Prag
:= Contract_Test_Cases
(Items
);
22295 while Present
(Prag
) loop
22296 if Pragma_Name
(Prag
) = Name_Test_Case
22298 and then String_Equal
22299 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
22301 Error_Msg_Sloc
:= Sloc
(Prag
);
22302 Error_Pragma
("name for pragma % is already used #");
22305 Prag
:= Next_Pragma
(Prag
);
22308 end Check_Distinct_Name
;
22312 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
22315 Subp_Decl
: Node_Id
;
22316 Subp_Id
: Entity_Id
;
22318 -- Start of processing for Test_Case
22322 Check_At_Least_N_Arguments
(2);
22323 Check_At_Most_N_Arguments
(4);
22325 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
22329 Check_Optional_Identifier
(Arg1
, Name_Name
);
22330 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22334 Check_Optional_Identifier
(Arg2
, Name_Mode
);
22335 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
22337 -- Arguments "Requires" and "Ensures"
22339 if Present
(Arg3
) then
22340 if Present
(Arg4
) then
22341 Check_Identifier
(Arg3
, Name_Requires
);
22342 Check_Identifier
(Arg4
, Name_Ensures
);
22344 Check_Identifier_Is_One_Of
22345 (Arg3
, Name_Requires
, Name_Ensures
);
22349 -- Pragma Test_Case must be associated with a subprogram declared
22350 -- in a library-level package. First determine whether the current
22351 -- compilation unit is a legal context.
22353 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
22354 N_Generic_Package_Declaration
)
22358 -- Otherwise the placement is illegal
22362 ("pragma % must be specified within a package declaration");
22366 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
22368 -- Find the enclosing context
22370 Context
:= Parent
(Subp_Decl
);
22372 if Present
(Context
) then
22373 Context
:= Parent
(Context
);
22376 -- Verify the placement of the pragma
22378 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
22380 ("pragma % cannot be applied to abstract subprogram");
22383 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
22384 Error_Pragma
("pragma % cannot be applied to entry");
22387 -- The context is a [generic] subprogram declared at the top level
22388 -- of the [generic] package unit.
22390 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
22391 N_Subprogram_Declaration
)
22392 and then Present
(Context
)
22393 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
22394 N_Package_Declaration
)
22398 -- Otherwise the placement is illegal
22402 ("pragma % must be applied to a library-level subprogram "
22407 Subp_Id
:= Defining_Entity
(Subp_Decl
);
22409 -- A pragma that applies to a Ghost entity becomes Ghost for the
22410 -- purposes of legality checks and removal of ignored Ghost code.
22412 Mark_Ghost_Pragma
(N
, Subp_Id
);
22414 -- Chain the pragma on the contract for further processing by
22415 -- Analyze_Test_Case_In_Decl_Part.
22417 Add_Contract_Item
(N
, Subp_Id
);
22419 -- Preanalyze the original aspect argument "Name" for ASIS or for
22420 -- a generic subprogram to properly capture global references.
22422 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
22423 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
22425 if Present
(Asp_Arg
) then
22427 -- The argument appears with an identifier in association
22430 if Nkind
(Asp_Arg
) = N_Component_Association
then
22431 Asp_Arg
:= Expression
(Asp_Arg
);
22434 Check_Expr_Is_OK_Static_Expression
22435 (Asp_Arg
, Standard_String
);
22439 -- Ensure that the all Test_Case pragmas of the related subprogram
22440 -- have distinct names.
22442 Check_Distinct_Name
(Subp_Id
);
22444 -- Fully analyze the pragma when it appears inside an entry
22445 -- or subprogram body because it cannot benefit from forward
22448 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
22450 N_Subprogram_Body_Stub
)
22452 -- The legality checks of pragma Test_Case are affected by the
22453 -- SPARK mode in effect and the volatility of the context.
22454 -- Analyze all pragmas in a specific order.
22456 Analyze_If_Present
(Pragma_SPARK_Mode
);
22457 Analyze_If_Present
(Pragma_Volatile_Function
);
22458 Analyze_Test_Case_In_Decl_Part
(N
);
22462 --------------------------
22463 -- Thread_Local_Storage --
22464 --------------------------
22466 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22468 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
22474 Check_Arg_Count
(1);
22475 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22476 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22478 Id
:= Get_Pragma_Arg
(Arg1
);
22481 if not Is_Entity_Name
(Id
)
22482 or else Ekind
(Entity
(Id
)) /= E_Variable
22484 Error_Pragma_Arg
("local variable name required", Arg1
);
22489 -- A pragma that applies to a Ghost entity becomes Ghost for the
22490 -- purposes of legality checks and removal of ignored Ghost code.
22492 Mark_Ghost_Pragma
(N
, E
);
22494 if Rep_Item_Too_Early
(E
, N
)
22496 Rep_Item_Too_Late
(E
, N
)
22501 Set_Has_Pragma_Thread_Local_Storage
(E
);
22502 Set_Has_Gigi_Rep_Item
(E
);
22503 end Thread_Local_Storage
;
22509 -- pragma Time_Slice (static_duration_EXPRESSION);
22511 when Pragma_Time_Slice
=> Time_Slice
: declare
22517 Check_Arg_Count
(1);
22518 Check_No_Identifiers
;
22519 Check_In_Main_Program
;
22520 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
22522 if not Error_Posted
(Arg1
) then
22524 while Present
(Nod
) loop
22525 if Nkind
(Nod
) = N_Pragma
22526 and then Pragma_Name
(Nod
) = Name_Time_Slice
22528 Error_Msg_Name_1
:= Pname
;
22529 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
22536 -- Process only if in main unit
22538 if Get_Source_Unit
(Loc
) = Main_Unit
then
22539 Opt
.Time_Slice_Set
:= True;
22540 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
22542 if Val
<= Ureal_0
then
22543 Opt
.Time_Slice_Value
:= 0;
22545 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
22546 Opt
.Time_Slice_Value
:= 1_000_000_000
;
22549 Opt
.Time_Slice_Value
:=
22550 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
22559 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22561 -- TITLING_OPTION ::=
22562 -- [Title =>] STRING_LITERAL
22563 -- | [Subtitle =>] STRING_LITERAL
22565 when Pragma_Title
=> Title
: declare
22566 Args
: Args_List
(1 .. 2);
22567 Names
: constant Name_List
(1 .. 2) := (
22573 Gather_Associations
(Names
, Args
);
22576 for J
in 1 .. 2 loop
22577 if Present
(Args
(J
)) then
22578 Check_Arg_Is_OK_Static_Expression
22579 (Args
(J
), Standard_String
);
22584 ----------------------------
22585 -- Type_Invariant[_Class] --
22586 ----------------------------
22588 -- pragma Type_Invariant[_Class]
22589 -- ([Entity =>] type_LOCAL_NAME,
22590 -- [Check =>] EXPRESSION);
22592 when Pragma_Type_Invariant
22593 | Pragma_Type_Invariant_Class
22595 Type_Invariant
: declare
22596 I_Pragma
: Node_Id
;
22599 Check_Arg_Count
(2);
22601 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22602 -- setting Class_Present for the Type_Invariant_Class case.
22604 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
22605 I_Pragma
:= New_Copy
(N
);
22606 Set_Pragma_Identifier
22607 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
22608 Rewrite
(N
, I_Pragma
);
22609 Set_Analyzed
(N
, False);
22611 end Type_Invariant
;
22613 ---------------------
22614 -- Unchecked_Union --
22615 ---------------------
22617 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22619 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
22620 Assoc
: constant Node_Id
:= Arg1
;
22621 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
22631 Check_No_Identifiers
;
22632 Check_Arg_Count
(1);
22633 Check_Arg_Is_Local_Name
(Arg1
);
22635 Find_Type
(Type_Id
);
22637 Typ
:= Entity
(Type_Id
);
22639 -- A pragma that applies to a Ghost entity becomes Ghost for the
22640 -- purposes of legality checks and removal of ignored Ghost code.
22642 Mark_Ghost_Pragma
(N
, Typ
);
22645 or else Rep_Item_Too_Early
(Typ
, N
)
22649 Typ
:= Underlying_Type
(Typ
);
22652 if Rep_Item_Too_Late
(Typ
, N
) then
22656 Check_First_Subtype
(Arg1
);
22658 -- Note remaining cases are references to a type in the current
22659 -- declarative part. If we find an error, we post the error on
22660 -- the relevant type declaration at an appropriate point.
22662 if not Is_Record_Type
(Typ
) then
22663 Error_Msg_N
("unchecked union must be record type", Typ
);
22666 elsif Is_Tagged_Type
(Typ
) then
22667 Error_Msg_N
("unchecked union must not be tagged", Typ
);
22670 elsif not Has_Discriminants
(Typ
) then
22672 ("unchecked union must have one discriminant", Typ
);
22675 -- Note: in previous versions of GNAT we used to check for limited
22676 -- types and give an error, but in fact the standard does allow
22677 -- Unchecked_Union on limited types, so this check was removed.
22679 -- Similarly, GNAT used to require that all discriminants have
22680 -- default values, but this is not mandated by the RM.
22682 -- Proceed with basic error checks completed
22685 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
22686 Clist
:= Component_List
(Tdef
);
22688 -- Check presence of component list and variant part
22690 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
22692 ("unchecked union must have variant part", Tdef
);
22696 -- Check components
22698 Comp
:= First
(Component_Items
(Clist
));
22699 while Present
(Comp
) loop
22700 Check_Component
(Comp
, Typ
);
22704 -- Check variant part
22706 Vpart
:= Variant_Part
(Clist
);
22708 Variant
:= First
(Variants
(Vpart
));
22709 while Present
(Variant
) loop
22710 Check_Variant
(Variant
, Typ
);
22715 Set_Is_Unchecked_Union
(Typ
);
22716 Set_Convention
(Typ
, Convention_C
);
22717 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
22718 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
22719 end Unchecked_Union
;
22721 ----------------------------
22722 -- Unevaluated_Use_Of_Old --
22723 ----------------------------
22725 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22727 when Pragma_Unevaluated_Use_Of_Old
=>
22729 Check_Arg_Count
(1);
22730 Check_No_Identifiers
;
22731 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
22733 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22734 -- a declarative part or a package spec.
22736 if not Is_Configuration_Pragma
then
22737 Check_Is_In_Decl_Part_Or_Package_Spec
;
22740 -- Store proper setting of Uneval_Old
22742 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22743 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
22745 ------------------------
22746 -- Unimplemented_Unit --
22747 ------------------------
22749 -- pragma Unimplemented_Unit;
22751 -- Note: this only gives an error if we are generating code, or if
22752 -- we are in a generic library unit (where the pragma appears in the
22753 -- body, not in the spec).
22755 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
22756 Cunitent
: constant Entity_Id
:=
22757 Cunit_Entity
(Get_Source_Unit
(Loc
));
22758 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
22762 Check_Arg_Count
(0);
22764 if Operating_Mode
= Generate_Code
22765 or else Ent_Kind
= E_Generic_Function
22766 or else Ent_Kind
= E_Generic_Procedure
22767 or else Ent_Kind
= E_Generic_Package
22769 Get_Name_String
(Chars
(Cunitent
));
22770 Set_Casing
(Mixed_Case
);
22771 Write_Str
(Name_Buffer
(1 .. Name_Len
));
22772 Write_Str
(" is not supported in this configuration");
22774 raise Unrecoverable_Error
;
22776 end Unimplemented_Unit
;
22778 ------------------------
22779 -- Universal_Aliasing --
22780 ------------------------
22782 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22784 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
22789 Check_Arg_Count
(1);
22790 Check_Optional_Identifier
(Arg2
, Name_Entity
);
22791 Check_Arg_Is_Local_Name
(Arg1
);
22792 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22794 if E_Id
= Any_Type
then
22796 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
22797 Error_Pragma_Arg
("pragma% requires type", Arg1
);
22800 -- A pragma that applies to a Ghost entity becomes Ghost for the
22801 -- purposes of legality checks and removal of ignored Ghost code.
22803 Mark_Ghost_Pragma
(N
, E_Id
);
22804 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
22805 Record_Rep_Item
(E_Id
, N
);
22806 end Universal_Alias
;
22808 --------------------
22809 -- Universal_Data --
22810 --------------------
22812 -- pragma Universal_Data [(library_unit_NAME)];
22814 when Pragma_Universal_Data
=>
22816 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
22822 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22824 when Pragma_Unmodified
=>
22825 Analyze_Unmodified_Or_Unused
;
22831 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22833 -- or when used in a context clause:
22835 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22837 when Pragma_Unreferenced
=>
22838 Analyze_Unreferenced_Or_Unused
;
22840 --------------------------
22841 -- Unreferenced_Objects --
22842 --------------------------
22844 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22846 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
22848 Arg_Expr
: Node_Id
;
22849 Arg_Id
: Entity_Id
;
22851 Ghost_Error_Posted
: Boolean := False;
22852 -- Flag set when an error concerning the illegal mix of Ghost and
22853 -- non-Ghost types is emitted.
22855 Ghost_Id
: Entity_Id
:= Empty
;
22856 -- The entity of the first Ghost type encountered while processing
22857 -- the arguments of the pragma.
22861 Check_At_Least_N_Arguments
(1);
22864 while Present
(Arg
) loop
22865 Check_No_Identifier
(Arg
);
22866 Check_Arg_Is_Local_Name
(Arg
);
22867 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22869 if Is_Entity_Name
(Arg_Expr
) then
22870 Arg_Id
:= Entity
(Arg_Expr
);
22872 if Is_Type
(Arg_Id
) then
22873 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
22875 -- A pragma that applies to a Ghost entity becomes Ghost
22876 -- for the purposes of legality checks and removal of
22877 -- ignored Ghost code.
22879 Mark_Ghost_Pragma
(N
, Arg_Id
);
22881 -- Capture the entity of the first Ghost type being
22882 -- processed for error detection purposes.
22884 if Is_Ghost_Entity
(Arg_Id
) then
22885 if No
(Ghost_Id
) then
22886 Ghost_Id
:= Arg_Id
;
22889 -- Otherwise the type is non-Ghost. It is illegal to mix
22890 -- references to Ghost and non-Ghost entities
22893 elsif Present
(Ghost_Id
)
22894 and then not Ghost_Error_Posted
22896 Ghost_Error_Posted
:= True;
22898 Error_Msg_Name_1
:= Pname
;
22900 ("pragma % cannot mention ghost and non-ghost types",
22903 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22904 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22906 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22907 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22911 ("argument for pragma% must be type or subtype", Arg
);
22915 ("argument for pragma% must be type or subtype", Arg
);
22920 end Unreferenced_Objects
;
22922 ------------------------------
22923 -- Unreserve_All_Interrupts --
22924 ------------------------------
22926 -- pragma Unreserve_All_Interrupts;
22928 when Pragma_Unreserve_All_Interrupts
=>
22930 Check_Arg_Count
(0);
22932 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
22933 Unreserve_All_Interrupts
:= True;
22940 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22942 when Pragma_Unsuppress
=>
22944 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
22950 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
22952 when Pragma_Unused
=>
22953 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
22954 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
22956 -------------------
22957 -- Use_VADS_Size --
22958 -------------------
22960 -- pragma Use_VADS_Size;
22962 when Pragma_Use_VADS_Size
=>
22964 Check_Arg_Count
(0);
22965 Check_Valid_Configuration_Pragma
;
22966 Use_VADS_Size
:= True;
22968 ---------------------
22969 -- Validity_Checks --
22970 ---------------------
22972 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22974 when Pragma_Validity_Checks
=> Validity_Checks
: declare
22975 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22981 Check_Arg_Count
(1);
22982 Check_No_Identifiers
;
22984 -- Pragma always active unless in CodePeer or GNATprove modes,
22985 -- which use a fixed configuration of validity checks.
22987 if not (CodePeer_Mode
or GNATprove_Mode
) then
22988 if Nkind
(A
) = N_String_Literal
then
22992 Slen
: constant Natural := Natural (String_Length
(S
));
22993 Options
: String (1 .. Slen
);
22997 -- Couldn't we use a for loop here over Options'Range???
23001 C
:= Get_String_Char
(S
, Pos
(J
));
23003 -- This is a weird test, it skips setting validity
23004 -- checks entirely if any element of S is out of
23005 -- range of Character, what is that about ???
23007 exit when not In_Character_Range
(C
);
23008 Options
(J
) := Get_Character
(C
);
23011 Set_Validity_Check_Options
(Options
);
23019 elsif Nkind
(A
) = N_Identifier
then
23020 if Chars
(A
) = Name_All_Checks
then
23021 Set_Validity_Check_Options
("a");
23022 elsif Chars
(A
) = Name_On
then
23023 Validity_Checks_On
:= True;
23024 elsif Chars
(A
) = Name_Off
then
23025 Validity_Checks_On
:= False;
23029 end Validity_Checks
;
23035 -- pragma Volatile (LOCAL_NAME);
23037 when Pragma_Volatile
=>
23038 Process_Atomic_Independent_Shared_Volatile
;
23040 -------------------------
23041 -- Volatile_Components --
23042 -------------------------
23044 -- pragma Volatile_Components (array_LOCAL_NAME);
23046 -- Volatile is handled by the same circuit as Atomic_Components
23048 --------------------------
23049 -- Volatile_Full_Access --
23050 --------------------------
23052 -- pragma Volatile_Full_Access (LOCAL_NAME);
23054 when Pragma_Volatile_Full_Access
=>
23056 Process_Atomic_Independent_Shared_Volatile
;
23058 -----------------------
23059 -- Volatile_Function --
23060 -----------------------
23062 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23064 when Pragma_Volatile_Function
=> Volatile_Function
: declare
23065 Over_Id
: Entity_Id
;
23066 Spec_Id
: Entity_Id
;
23067 Subp_Decl
: Node_Id
;
23071 Check_No_Identifiers
;
23072 Check_At_Most_N_Arguments
(1);
23075 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23077 -- Generic subprogram
23079 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23082 -- Body acts as spec
23084 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23085 and then No
(Corresponding_Spec
(Subp_Decl
))
23089 -- Body stub acts as spec
23091 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23092 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23098 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23106 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23108 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
23113 -- A pragma that applies to a Ghost entity becomes Ghost for the
23114 -- purposes of legality checks and removal of ignored Ghost code.
23116 Mark_Ghost_Pragma
(N
, Spec_Id
);
23118 -- Chain the pragma on the contract for completeness
23120 Add_Contract_Item
(N
, Spec_Id
);
23122 -- The legality checks of pragma Volatile_Function are affected by
23123 -- the SPARK mode in effect. Analyze all pragmas in a specific
23126 Analyze_If_Present
(Pragma_SPARK_Mode
);
23128 -- A volatile function cannot override a non-volatile function
23129 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23130 -- in New_Overloaded_Entity, however at that point the pragma has
23131 -- not been processed yet.
23133 Over_Id
:= Overridden_Operation
(Spec_Id
);
23135 if Present
(Over_Id
)
23136 and then not Is_Volatile_Function
(Over_Id
)
23139 ("incompatible volatile function values in effect", Spec_Id
);
23141 Error_Msg_Sloc
:= Sloc
(Over_Id
);
23143 ("\& declared # with Volatile_Function value False",
23146 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
23148 ("\overridden # with Volatile_Function value True",
23152 -- Analyze the Boolean expression (if any)
23154 if Present
(Arg1
) then
23155 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
23157 end Volatile_Function
;
23159 ----------------------
23160 -- Warning_As_Error --
23161 ----------------------
23163 -- pragma Warning_As_Error (static_string_EXPRESSION);
23165 when Pragma_Warning_As_Error
=>
23167 Check_Arg_Count
(1);
23168 Check_No_Identifiers
;
23169 Check_Valid_Configuration_Pragma
;
23171 if not Is_Static_String_Expression
(Arg1
) then
23173 ("argument of pragma% must be static string expression",
23176 -- OK static string expression
23179 Acquire_Warning_Match_String
(Arg1
);
23180 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
23181 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
23182 new String'(Name_Buffer (1 .. Name_Len));
23189 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23191 -- DETAILS ::= On | Off
23192 -- DETAILS ::= On | Off, local_NAME
23193 -- DETAILS ::= static_string_EXPRESSION
23194 -- DETAILS ::= On | Off, static_string_EXPRESSION
23196 -- TOOL_NAME ::= GNAT | GNATProve
23198 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23200 -- Note: If the first argument matches an allowed tool name, it is
23201 -- always considered to be a tool name, even if there is a string
23202 -- variable of that name.
23204 -- Note if the second argument of DETAILS is a local_NAME then the
23205 -- second form is always understood. If the intention is to use
23206 -- the fourth form, then you can write NAME & "" to force the
23207 -- intepretation as a static_string_EXPRESSION.
23209 when Pragma_Warnings => Warnings : declare
23210 Reason : String_Id;
23214 Check_At_Least_N_Arguments (1);
23216 -- See if last argument is labeled Reason. If so, make sure we
23217 -- have a string literal or a concatenation of string literals,
23218 -- and acquire the REASON string. Then remove the REASON argument
23219 -- by decreasing Num_Args by one; Remaining processing looks only
23220 -- at first Num_Args arguments).
23223 Last_Arg : constant Node_Id :=
23224 Last (Pragma_Argument_Associations (N));
23227 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23228 and then Chars (Last_Arg) = Name_Reason
23231 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23232 Reason := End_String;
23233 Arg_Count := Arg_Count - 1;
23235 -- Not allowed in compiler units (bootstrap issues)
23237 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23239 -- No REASON string, set null string as reason
23242 Reason := Null_String_Id;
23246 -- Now proceed with REASON taken care of and eliminated
23248 Check_No_Identifiers;
23250 -- If debug flag -gnatd.i is set, pragma is ignored
23252 if Debug_Flag_Dot_I then
23256 -- Process various forms of the pragma
23259 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23260 Shifted_Args : List_Id;
23263 -- See if first argument is a tool name, currently either
23264 -- GNAT or GNATprove. If so, either ignore the pragma if the
23265 -- tool used does not match, or continue as if no tool name
23266 -- was given otherwise, by shifting the arguments.
23268 if Nkind (Argx) = N_Identifier
23269 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23271 if Chars (Argx) = Name_Gnat then
23272 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23273 Rewrite (N, Make_Null_Statement (Loc));
23278 elsif Chars (Argx) = Name_Gnatprove then
23279 if not GNATprove_Mode then
23280 Rewrite (N, Make_Null_Statement (Loc));
23286 raise Program_Error;
23289 -- At this point, the pragma Warnings applies to the tool,
23290 -- so continue with shifted arguments.
23292 Arg_Count := Arg_Count - 1;
23294 if Arg_Count = 1 then
23295 Shifted_Args := New_List (New_Copy (Arg2));
23296 elsif Arg_Count = 2 then
23297 Shifted_Args := New_List (New_Copy (Arg2),
23299 elsif Arg_Count = 3 then
23300 Shifted_Args := New_List (New_Copy (Arg2),
23304 raise Program_Error;
23309 Chars => Name_Warnings,
23310 Pragma_Argument_Associations => Shifted_Args));
23315 -- One argument case
23317 if Arg_Count = 1 then
23319 -- On/Off one argument case was processed by parser
23321 if Nkind (Argx) = N_Identifier
23322 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23326 -- One argument case must be ON/OFF or static string expr
23328 elsif not Is_Static_String_Expression (Arg1) then
23330 ("argument of pragma% must be On/Off or static string "
23331 & "expression", Arg1);
23333 -- One argument string expression case
23337 Lit : constant Node_Id := Expr_Value_S (Argx);
23338 Str : constant String_Id := Strval (Lit);
23339 Len : constant Nat := String_Length (Str);
23347 while J <= Len loop
23348 C := Get_String_Char (Str, J);
23349 OK := In_Character_Range (C);
23352 Chr := Get_Character (C);
23354 -- Dash case: only -Wxxx is accepted
23361 C := Get_String_Char (Str, J);
23362 Chr := Get_Character (C);
23363 exit when Chr = 'W
';
23368 elsif J < Len and then Chr = '.' then
23370 C := Get_String_Char (Str, J);
23371 Chr := Get_Character (C);
23373 if not Set_Dot_Warning_Switch (Chr) then
23375 ("invalid warning switch character "
23376 & '.' & Chr, Arg1);
23382 OK := Set_Warning_Switch (Chr);
23388 ("invalid warning switch character " & Chr,
23397 -- Two or more arguments (must be two)
23400 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23401 Check_Arg_Count (2);
23409 E_Id := Get_Pragma_Arg (Arg2);
23412 -- In the expansion of an inlined body, a reference to
23413 -- the formal may be wrapped in a conversion if the
23414 -- actual is a conversion. Retrieve the real entity name.
23416 if (In_Instance_Body or In_Inlined_Body)
23417 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23419 E_Id := Expression (E_Id);
23422 -- Entity name case
23424 if Is_Entity_Name (E_Id) then
23425 E := Entity (E_Id);
23432 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23435 -- For OFF case, make entry in warnings off
23436 -- pragma table for later processing. But we do
23437 -- not do that within an instance, since these
23438 -- warnings are about what is needed in the
23439 -- template, not an instance of it.
23441 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23442 and then Warn_On_Warnings_Off
23443 and then not In_Instance
23445 Warnings_Off_Pragmas.Append ((N, E, Reason));
23448 if Is_Enumeration_Type (E) then
23452 Lit := First_Literal (E);
23453 while Present (Lit) loop
23454 Set_Warnings_Off (Lit);
23455 Next_Literal (Lit);
23460 exit when No (Homonym (E));
23465 -- Error if not entity or static string expression case
23467 elsif not Is_Static_String_Expression (Arg2) then
23469 ("second argument of pragma% must be entity name "
23470 & "or static string expression", Arg2);
23472 -- Static string expression case
23475 Acquire_Warning_Match_String (Arg2);
23477 -- Note on configuration pragma case: If this is a
23478 -- configuration pragma, then for an OFF pragma, we
23479 -- just set Config True in the call, which is all
23480 -- that needs to be done. For the case of ON, this
23481 -- is normally an error, unless it is canceling the
23482 -- effect of a previous OFF pragma in the same file.
23483 -- In any other case, an error will be signalled (ON
23484 -- with no matching OFF).
23486 -- Note: We set Used if we are inside a generic to
23487 -- disable the test that the non-config case actually
23488 -- cancels a warning. That's because we can't be sure
23489 -- there isn't an instantiation in some other unit
23490 -- where a warning is suppressed.
23492 -- We could do a little better here by checking if the
23493 -- generic unit we are inside is public, but for now
23494 -- we don't bother with that refinement.
23496 if Chars (Argx) = Name_Off then
23497 Set_Specific_Warning_Off
23498 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23499 Config => Is_Configuration_Pragma,
23500 Used => Inside_A_Generic or else In_Instance);
23502 elsif Chars (Argx) = Name_On then
23503 Set_Specific_Warning_On
23504 (Loc, Name_Buffer (1 .. Name_Len), Err);
23508 ("??pragma Warnings On with no matching "
23509 & "Warnings Off", Loc);
23518 -------------------
23519 -- Weak_External --
23520 -------------------
23522 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23524 when Pragma_Weak_External => Weak_External : declare
23529 Check_Arg_Count (1);
23530 Check_Optional_Identifier (Arg1, Name_Entity);
23531 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23532 Ent := Entity (Get_Pragma_Arg (Arg1));
23534 if Rep_Item_Too_Early (Ent, N) then
23537 Ent := Underlying_Type (Ent);
23540 -- The only processing required is to link this item on to the
23541 -- list of rep items for the given entity. This is accomplished
23542 -- by the call to Rep_Item_Too_Late (when no error is detected
23543 -- and False is returned).
23545 if Rep_Item_Too_Late (Ent, N) then
23548 Set_Has_Gigi_Rep_Item (Ent);
23552 -----------------------------
23553 -- Wide_Character_Encoding --
23554 -----------------------------
23556 -- pragma Wide_Character_Encoding (IDENTIFIER);
23558 when Pragma_Wide_Character_Encoding =>
23561 -- Nothing to do, handled in parser. Note that we do not enforce
23562 -- configuration pragma placement, this pragma can appear at any
23563 -- place in the source, allowing mixed encodings within a single
23568 --------------------
23569 -- Unknown_Pragma --
23570 --------------------
23572 -- Should be impossible, since the case of an unknown pragma is
23573 -- separately processed before the case statement is entered.
23575 when Unknown_Pragma =>
23576 raise Program_Error;
23579 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23580 -- until AI is formally approved.
23582 -- Check_Order_Dependence;
23585 when Pragma_Exit => null;
23586 end Analyze_Pragma;
23588 ---------------------------------------------
23589 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23590 ---------------------------------------------
23592 -- WARNING: This routine manages Ghost regions. Return statements must be
23593 -- replaced by gotos which jump to the end of the routine and restore the
23596 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23598 Freeze_Id : Entity_Id := Empty)
23600 Disp_Typ : Entity_Id;
23601 -- The dispatching type of the subprogram subject to the pre- or
23604 function Check_References (Nod : Node_Id) return Traverse_Result;
23605 -- Check that expression Nod does not mention non-primitives of the
23606 -- type, global objects of the type, or other illegalities described
23607 -- and implied by AI12-0113.
23609 ----------------------
23610 -- Check_References --
23611 ----------------------
23613 function Check_References (Nod : Node_Id) return Traverse_Result is
23615 if Nkind (Nod) = N_Function_Call
23616 and then Is_Entity_Name (Name (Nod))
23619 Func : constant Entity_Id := Entity (Name (Nod));
23623 -- An operation of the type must be a primitive
23625 if No (Find_Dispatching_Type (Func)) then
23626 Form := First_Formal (Func);
23627 while Present (Form) loop
23628 if Etype (Form) = Disp_Typ then
23630 ("operation in class-wide condition must be "
23631 & "primitive of &", Nod, Disp_Typ);
23634 Next_Formal (Form);
23637 -- A return object of the type is illegal as well
23639 if Etype (Func) = Disp_Typ
23640 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23643 ("operation in class-wide condition must be primitive "
23644 & "of &", Nod, Disp_Typ);
23649 elsif Is_Entity_Name (Nod)
23651 (Etype (Nod) = Disp_Typ
23652 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23653 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23656 ("object in class-wide condition must be formal of type &",
23659 elsif Nkind (Nod) = N_Explicit_Dereference
23660 and then (Etype (Nod) = Disp_Typ
23661 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23662 and then (not Is_Entity_Name (Prefix (Nod))
23663 or else not Is_Formal (Entity (Prefix (Nod))))
23666 ("operation in class-wide condition must be primitive of &",
23671 end Check_References;
23673 procedure Check_Class_Wide_Condition is
23674 new Traverse_Proc (Check_References);
23678 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23679 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23680 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23683 Mode : Ghost_Mode_Type;
23684 Restore_Scope : Boolean := False;
23686 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23689 -- Do not analyze the pragma multiple times
23691 if Is_Analyzed_Pragma (N) then
23695 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23696 -- analysis of the pragma, the Ghost mode at point of declaration and
23697 -- point of analysis may not necessarily be the same. Use the mode in
23698 -- effect at the point of declaration.
23700 Set_Ghost_Mode (N, Mode);
23702 -- Ensure that the subprogram and its formals are visible when analyzing
23703 -- the expression of the pragma.
23705 if not In_Open_Scopes (Spec_Id) then
23706 Restore_Scope := True;
23707 Push_Scope (Spec_Id);
23709 if Is_Generic_Subprogram (Spec_Id) then
23710 Install_Generic_Formals (Spec_Id);
23712 Install_Formals (Spec_Id);
23716 Errors := Serious_Errors_Detected;
23717 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23719 -- Emit a clarification message when the expression contains at least
23720 -- one undefined reference, possibly due to contract "freezing".
23722 if Errors /= Serious_Errors_Detected
23723 and then Present (Freeze_Id)
23724 and then Has_Undefined_Reference (Expr)
23726 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23729 if Class_Present (N) then
23731 -- Verify that a class-wide condition is legal, i.e. the operation is
23732 -- a primitive of a tagged type. Note that a generic subprogram is
23733 -- not a primitive operation.
23735 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23737 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23738 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23740 if From_Aspect_Specification (N) then
23742 ("aspect % can only be specified for a primitive operation "
23743 & "of a tagged type", Corresponding_Aspect (N));
23745 -- The pragma is a source construct
23749 ("pragma % can only be specified for a primitive operation "
23750 & "of a tagged type", N);
23753 -- Remaining semantic checks require a full tree traversal
23756 Check_Class_Wide_Condition (Expr);
23761 if Restore_Scope then
23765 -- Currently it is not possible to inline pre/postconditions on a
23766 -- subprogram subject to pragma Inline_Always.
23768 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23769 Set_Is_Analyzed_Pragma (N);
23771 Restore_Ghost_Mode (Mode);
23772 end Analyze_Pre_Post_Condition_In_Decl_Part;
23774 ------------------------------------------
23775 -- Analyze_Refined_Depends_In_Decl_Part --
23776 ------------------------------------------
23778 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23779 procedure Check_Dependency_Clause
23780 (Spec_Id : Entity_Id;
23781 Dep_Clause : Node_Id;
23782 Dep_States : Elist_Id;
23783 Refinements : List_Id;
23784 Matched_Items : in out Elist_Id);
23785 -- Try to match a single dependency clause Dep_Clause against one or
23786 -- more refinement clauses found in list Refinements. Each successful
23787 -- match eliminates at least one refinement clause from Refinements.
23788 -- Spec_Id denotes the entity of the related subprogram. Dep_States
23789 -- denotes the entities of all abstract states which appear in pragma
23790 -- Depends. Matched_Items contains the entities of all successfully
23791 -- matched items found in pragma Depends.
23793 procedure Check_Output_States
23794 (Spec_Id : Entity_Id;
23795 Spec_Inputs : Elist_Id;
23796 Spec_Outputs : Elist_Id;
23797 Body_Inputs : Elist_Id;
23798 Body_Outputs : Elist_Id);
23799 -- Determine whether pragma Depends contains an output state with a
23800 -- visible refinement and if so, ensure that pragma Refined_Depends
23801 -- mentions all its constituents as outputs. Spec_Id is the entity of
23802 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
23803 -- inputs and outputs of the subprogram spec synthesized from pragma
23804 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
23805 -- of the subprogram body synthesized from pragma Refined_Depends.
23807 function Collect_States (Clauses : List_Id) return Elist_Id;
23808 -- Given a normalized list of dependencies obtained from calling
23809 -- Normalize_Clauses, return a list containing the entities of all
23810 -- states appearing in dependencies. It helps in checking refinements
23811 -- involving a state and a corresponding constituent which is not a
23812 -- direct constituent of the state.
23814 procedure Normalize_Clauses (Clauses : List_Id);
23815 -- Given a list of dependence or refinement clauses Clauses, normalize
23816 -- each clause by creating multiple dependencies with exactly one input
23819 procedure Remove_Extra_Clauses
23820 (Clauses : List_Id;
23821 Matched_Items : Elist_Id);
23822 -- Given a list of refinement clauses Clauses, remove all clauses whose
23823 -- inputs and/or outputs have been previously matched. See the body for
23824 -- all special cases. Matched_Items contains the entities of all matched
23825 -- items found in pragma Depends.
23827 procedure Report_Extra_Clauses
23828 (Spec_Id : Entity_Id;
23829 Clauses : List_Id);
23830 -- Emit an error for each extra clause found in list Clauses. Spec_Id
23831 -- denotes the entity of the related subprogram.
23833 -----------------------------
23834 -- Check_Dependency_Clause --
23835 -----------------------------
23837 procedure Check_Dependency_Clause
23838 (Spec_Id : Entity_Id;
23839 Dep_Clause : Node_Id;
23840 Dep_States : Elist_Id;
23841 Refinements : List_Id;
23842 Matched_Items : in out Elist_Id)
23844 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23845 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23847 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
23848 -- Determine whether dependency item Dep_Item has been matched in a
23849 -- previous clause.
23851 function Is_In_Out_State_Clause return Boolean;
23852 -- Determine whether dependence clause Dep_Clause denotes an abstract
23853 -- state that depends on itself (State => State).
23855 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23856 -- Determine whether item Item denotes an abstract state with visible
23857 -- null refinement.
23859 procedure Match_Items
23860 (Dep_Item : Node_Id;
23861 Ref_Item : Node_Id;
23862 Matched : out Boolean);
23863 -- Try to match dependence item Dep_Item against refinement item
23864 -- Ref_Item. To match against a possible null refinement (see 2, 9),
23865 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23866 -- the following conformance scenarios is in effect:
23867 -- 1) Both items denote null
23868 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23869 -- 3) Both items denote attribute 'Result
23870 -- 4) Both items denote the same object
23871 -- 5) Both items denote the same formal parameter
23872 -- 6) Both items denote the same current instance of a type
23873 -- 7) Both items denote the same discriminant
23874 -- 8) Dep_Item is an abstract state with visible null refinement
23875 -- and Ref_Item denotes null.
23876 -- 9) Dep_Item is an abstract state with visible null refinement
23877 -- and Ref_Item is Empty (special case).
23878 -- 10) Dep_Item is an abstract state with full or partial visible
23879 -- non-null refinement and Ref_Item denotes one of its
23881 -- 11) Dep_Item is an abstract state without a full visible
23882 -- refinement and Ref_Item denotes the same state.
23883 -- When scenario 10 is in effect, the entity of the abstract state
23884 -- denoted by Dep_Item is added to list Refined_States.
23886 procedure Record_Item
(Item_Id
: Entity_Id
);
23887 -- Store the entity of an item denoted by Item_Id in Matched_Items
23889 ------------------------
23890 -- Is_Already_Matched --
23891 ------------------------
23893 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
23894 Item_Id
: Entity_Id
:= Empty
;
23897 -- When the dependency item denotes attribute 'Result, check for
23898 -- the entity of the related subprogram.
23900 if Is_Attribute_Result
(Dep_Item
) then
23901 Item_Id
:= Spec_Id
;
23903 elsif Is_Entity_Name
(Dep_Item
) then
23904 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
23908 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
23909 end Is_Already_Matched
;
23911 ----------------------------
23912 -- Is_In_Out_State_Clause --
23913 ----------------------------
23915 function Is_In_Out_State_Clause
return Boolean is
23916 Dep_Input_Id
: Entity_Id
;
23917 Dep_Output_Id
: Entity_Id
;
23920 -- Detect the following clause:
23923 if Is_Entity_Name
(Dep_Input
)
23924 and then Is_Entity_Name
(Dep_Output
)
23926 -- Handle abstract views generated for limited with clauses
23928 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
23929 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
23932 Ekind
(Dep_Input_Id
) = E_Abstract_State
23933 and then Dep_Input_Id
= Dep_Output_Id
;
23937 end Is_In_Out_State_Clause
;
23939 ---------------------------
23940 -- Is_Null_Refined_State --
23941 ---------------------------
23943 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
23944 Item_Id
: Entity_Id
;
23947 if Is_Entity_Name
(Item
) then
23949 -- Handle abstract views generated for limited with clauses
23951 Item_Id
:= Available_View
(Entity_Of
(Item
));
23954 Ekind
(Item_Id
) = E_Abstract_State
23955 and then Has_Null_Visible_Refinement
(Item_Id
);
23959 end Is_Null_Refined_State
;
23965 procedure Match_Items
23966 (Dep_Item
: Node_Id
;
23967 Ref_Item
: Node_Id
;
23968 Matched
: out Boolean)
23970 Dep_Item_Id
: Entity_Id
;
23971 Ref_Item_Id
: Entity_Id
;
23974 -- Assume that the two items do not match
23978 -- A null matches null or Empty (special case)
23980 if Nkind
(Dep_Item
) = N_Null
23981 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23985 -- Attribute 'Result matches attribute 'Result
23987 elsif Is_Attribute_Result
(Dep_Item
)
23988 and then Is_Attribute_Result
(Ref_Item
)
23990 -- Put the entity of the related function on the list of
23991 -- matched items because attribute 'Result does not carry
23992 -- an entity similar to states and constituents.
23994 Record_Item
(Spec_Id
);
23997 -- Abstract states, current instances of concurrent types,
23998 -- discriminants, formal parameters and objects.
24000 elsif Is_Entity_Name
(Dep_Item
) then
24002 -- Handle abstract views generated for limited with clauses
24004 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24006 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
24008 -- An abstract state with visible null refinement matches
24009 -- null or Empty (special case).
24011 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
24012 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24014 Record_Item
(Dep_Item_Id
);
24017 -- An abstract state with visible non-null refinement
24018 -- matches one of its constituents, or itself for an
24019 -- abstract state with partial visible refinement.
24021 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
24022 if Is_Entity_Name
(Ref_Item
) then
24023 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
24025 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
24028 and then Present
(Encapsulating_State
(Ref_Item_Id
))
24029 and then Find_Encapsulating_State
24030 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
24032 Record_Item
(Dep_Item_Id
);
24035 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
24036 and then Ref_Item_Id
= Dep_Item_Id
24038 Record_Item
(Dep_Item_Id
);
24043 -- An abstract state without a visible refinement matches
24046 elsif Is_Entity_Name
(Ref_Item
)
24047 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24049 Record_Item
(Dep_Item_Id
);
24053 -- A current instance of a concurrent type, discriminant,
24054 -- formal parameter or an object matches itself.
24056 elsif Is_Entity_Name
(Ref_Item
)
24057 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24059 Record_Item
(Dep_Item_Id
);
24069 procedure Record_Item
(Item_Id
: Entity_Id
) is
24071 if No
(Matched_Items
) then
24072 Matched_Items
:= New_Elmt_List
;
24075 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
24080 Clause_Matched
: Boolean := False;
24081 Dummy
: Boolean := False;
24082 Inputs_Match
: Boolean;
24083 Next_Ref_Clause
: Node_Id
;
24084 Outputs_Match
: Boolean;
24085 Ref_Clause
: Node_Id
;
24086 Ref_Input
: Node_Id
;
24087 Ref_Output
: Node_Id
;
24089 -- Start of processing for Check_Dependency_Clause
24092 -- Do not perform this check in an instance because it was already
24093 -- performed successfully in the generic template.
24095 if Is_Generic_Instance
(Spec_Id
) then
24099 -- Examine all refinement clauses and compare them against the
24100 -- dependence clause.
24102 Ref_Clause
:= First
(Refinements
);
24103 while Present
(Ref_Clause
) loop
24104 Next_Ref_Clause
:= Next
(Ref_Clause
);
24106 -- Obtain the attributes of the current refinement clause
24108 Ref_Input
:= Expression
(Ref_Clause
);
24109 Ref_Output
:= First
(Choices
(Ref_Clause
));
24111 -- The current refinement clause matches the dependence clause
24112 -- when both outputs match and both inputs match. See routine
24113 -- Match_Items for all possible conformance scenarios.
24115 -- Depends Dep_Output => Dep_Input
24119 -- Refined_Depends Ref_Output => Ref_Input
24122 (Dep_Item
=> Dep_Input
,
24123 Ref_Item
=> Ref_Input
,
24124 Matched
=> Inputs_Match
);
24127 (Dep_Item
=> Dep_Output
,
24128 Ref_Item
=> Ref_Output
,
24129 Matched
=> Outputs_Match
);
24131 -- An In_Out state clause may be matched against a refinement with
24132 -- a null input or null output as long as the non-null side of the
24133 -- relation contains a valid constituent of the In_Out_State.
24135 if Is_In_Out_State_Clause
then
24137 -- Depends => (State => State)
24138 -- Refined_Depends => (null => Constit) -- OK
24141 and then not Outputs_Match
24142 and then Nkind
(Ref_Output
) = N_Null
24144 Outputs_Match
:= True;
24147 -- Depends => (State => State)
24148 -- Refined_Depends => (Constit => null) -- OK
24150 if not Inputs_Match
24151 and then Outputs_Match
24152 and then Nkind
(Ref_Input
) = N_Null
24154 Inputs_Match
:= True;
24158 -- The current refinement clause is legally constructed following
24159 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24160 -- the pool of candidates. The seach continues because a single
24161 -- dependence clause may have multiple matching refinements.
24163 if Inputs_Match
and Outputs_Match
then
24164 Clause_Matched
:= True;
24165 Remove
(Ref_Clause
);
24168 Ref_Clause
:= Next_Ref_Clause
;
24171 -- Depending on the order or composition of refinement clauses, an
24172 -- In_Out state clause may not be directly refinable.
24174 -- Refined_State => (State => (Constit_1, Constit_2))
24175 -- Depends => ((Output, State) => (Input, State))
24176 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24178 -- Matching normalized clause (State => State) fails because there is
24179 -- no direct refinement capable of satisfying this relation. Another
24180 -- similar case arises when clauses (Constit_1 => Input) and (Output
24181 -- => Constit_2) are matched first, leaving no candidates for clause
24182 -- (State => State). Both scenarios are legal as long as one of the
24183 -- previous clauses mentioned a valid constituent of State.
24185 if not Clause_Matched
24186 and then Is_In_Out_State_Clause
24187 and then Is_Already_Matched
(Dep_Input
)
24189 Clause_Matched
:= True;
24192 -- A clause where the input is an abstract state with visible null
24193 -- refinement or a 'Result attribute is implicitly matched when the
24194 -- output has already been matched in a previous clause.
24196 -- Refined_State => (State => null)
24197 -- Depends => (Output => State) -- implicitly OK
24198 -- Refined_Depends => (Output => ...)
24199 -- Depends => (...'Result => State) -- implicitly OK
24200 -- Refined_Depends => (...'Result => ...)
24202 if not Clause_Matched
24203 and then Is_Null_Refined_State
(Dep_Input
)
24204 and then Is_Already_Matched
(Dep_Output
)
24206 Clause_Matched
:= True;
24209 -- A clause where the output is an abstract state with visible null
24210 -- refinement is implicitly matched when the input has already been
24211 -- matched in a previous clause.
24213 -- Refined_State => (State => null)
24214 -- Depends => (State => Input) -- implicitly OK
24215 -- Refined_Depends => (... => Input)
24217 if not Clause_Matched
24218 and then Is_Null_Refined_State
(Dep_Output
)
24219 and then Is_Already_Matched
(Dep_Input
)
24221 Clause_Matched
:= True;
24224 -- At this point either all refinement clauses have been examined or
24225 -- pragma Refined_Depends contains a solitary null. Only an abstract
24226 -- state with null refinement can possibly match these cases.
24228 -- Refined_State => (State => null)
24229 -- Depends => (State => null)
24230 -- Refined_Depends => null -- OK
24232 if not Clause_Matched
then
24234 (Dep_Item
=> Dep_Input
,
24236 Matched
=> Inputs_Match
);
24239 (Dep_Item
=> Dep_Output
,
24241 Matched
=> Outputs_Match
);
24243 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
24246 -- If the contents of Refined_Depends are legal, then the current
24247 -- dependence clause should be satisfied either by an explicit match
24248 -- or by one of the special cases.
24250 if not Clause_Matched
then
24252 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
24253 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
24255 end Check_Dependency_Clause
;
24257 -------------------------
24258 -- Check_Output_States --
24259 -------------------------
24261 procedure Check_Output_States
24262 (Spec_Id
: Entity_Id
;
24263 Spec_Inputs
: Elist_Id
;
24264 Spec_Outputs
: Elist_Id
;
24265 Body_Inputs
: Elist_Id
;
24266 Body_Outputs
: Elist_Id
)
24268 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24269 -- Determine whether all constituents of state State_Id with full
24270 -- visible refinement are used as outputs in pragma Refined_Depends.
24271 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24273 -----------------------------
24274 -- Check_Constituent_Usage --
24275 -----------------------------
24277 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24278 Constits
: constant Elist_Id
:=
24279 Partial_Refinement_Constituents
(State_Id
);
24280 Constit_Elmt
: Elmt_Id
;
24281 Constit_Id
: Entity_Id
;
24282 Only_Partial
: constant Boolean :=
24283 not Has_Visible_Refinement
(State_Id
);
24284 Posted
: Boolean := False;
24287 if Present
(Constits
) then
24288 Constit_Elmt
:= First_Elmt
(Constits
);
24289 while Present
(Constit_Elmt
) loop
24290 Constit_Id
:= Node
(Constit_Elmt
);
24292 -- Issue an error when a constituent of State_Id is used,
24293 -- and State_Id has only partial visible refinement
24294 -- (SPARK RM 7.2.4(3d)).
24296 if Only_Partial
then
24297 if (Present
(Body_Inputs
)
24298 and then Appears_In
(Body_Inputs
, Constit_Id
))
24300 (Present
(Body_Outputs
)
24301 and then Appears_In
(Body_Outputs
, Constit_Id
))
24303 Error_Msg_Name_1
:= Chars
(State_Id
);
24305 ("constituent & of state % cannot be used in "
24306 & "dependence refinement", N
, Constit_Id
);
24307 Error_Msg_Name_1
:= Chars
(State_Id
);
24308 SPARK_Msg_N
("\use state % instead", N
);
24311 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24313 elsif Present
(Body_Inputs
)
24314 and then Appears_In
(Body_Inputs
, Constit_Id
)
24316 Error_Msg_Name_1
:= Chars
(State_Id
);
24318 ("constituent & of state % must act as output in "
24319 & "dependence refinement", N
, Constit_Id
);
24321 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24323 elsif No
(Body_Outputs
)
24324 or else not Appears_In
(Body_Outputs
, Constit_Id
)
24329 ("output state & must be replaced by all its "
24330 & "constituents in dependence refinement",
24335 ("\constituent & is missing in output list",
24339 Next_Elmt
(Constit_Elmt
);
24342 end Check_Constituent_Usage
;
24347 Item_Elmt
: Elmt_Id
;
24348 Item_Id
: Entity_Id
;
24350 -- Start of processing for Check_Output_States
24353 -- Do not perform this check in an instance because it was already
24354 -- performed successfully in the generic template.
24356 if Is_Generic_Instance
(Spec_Id
) then
24359 -- Inspect the outputs of pragma Depends looking for a state with a
24360 -- visible refinement.
24362 elsif Present
(Spec_Outputs
) then
24363 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
24364 while Present
(Item_Elmt
) loop
24365 Item
:= Node
(Item_Elmt
);
24367 -- Deal with the mixed nature of the input and output lists
24369 if Nkind
(Item
) = N_Defining_Identifier
then
24372 Item_Id
:= Available_View
(Entity_Of
(Item
));
24375 if Ekind
(Item_Id
) = E_Abstract_State
then
24377 -- The state acts as an input-output, skip it
24379 if Present
(Spec_Inputs
)
24380 and then Appears_In
(Spec_Inputs
, Item_Id
)
24384 -- Ensure that all of the constituents are utilized as
24385 -- outputs in pragma Refined_Depends.
24387 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
24388 Check_Constituent_Usage
(Item_Id
);
24392 Next_Elmt
(Item_Elmt
);
24395 end Check_Output_States
;
24397 --------------------
24398 -- Collect_States --
24399 --------------------
24401 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
24402 procedure Collect_State
24404 States
: in out Elist_Id
);
24405 -- Add the entity of Item to list States when it denotes to a state
24407 -------------------
24408 -- Collect_State --
24409 -------------------
24411 procedure Collect_State
24413 States
: in out Elist_Id
)
24418 if Is_Entity_Name
(Item
) then
24419 Id
:= Entity_Of
(Item
);
24421 if Ekind
(Id
) = E_Abstract_State
then
24422 if No
(States
) then
24423 States
:= New_Elmt_List
;
24426 Append_Unique_Elmt
(Id
, States
);
24436 States
: Elist_Id
:= No_Elist
;
24438 -- Start of processing for Collect_States
24441 Clause
:= First
(Clauses
);
24442 while Present
(Clause
) loop
24443 Input
:= Expression
(Clause
);
24444 Output
:= First
(Choices
(Clause
));
24446 Collect_State
(Input
, States
);
24447 Collect_State
(Output
, States
);
24453 end Collect_States
;
24455 -----------------------
24456 -- Normalize_Clauses --
24457 -----------------------
24459 procedure Normalize_Clauses
(Clauses
: List_Id
) is
24460 procedure Normalize_Inputs
(Clause
: Node_Id
);
24461 -- Normalize clause Clause by creating multiple clauses for each
24462 -- input item of Clause. It is assumed that Clause has exactly one
24463 -- output. The transformation is as follows:
24465 -- Output => (Input_1, Input_2) -- original
24467 -- Output => Input_1 -- normalizations
24468 -- Output => Input_2
24470 procedure Normalize_Outputs
(Clause
: Node_Id
);
24471 -- Normalize clause Clause by creating multiple clause for each
24472 -- output item of Clause. The transformation is as follows:
24474 -- (Output_1, Output_2) => Input -- original
24476 -- Output_1 => Input -- normalization
24477 -- Output_2 => Input
24479 ----------------------
24480 -- Normalize_Inputs --
24481 ----------------------
24483 procedure Normalize_Inputs
(Clause
: Node_Id
) is
24484 Inputs
: constant Node_Id
:= Expression
(Clause
);
24485 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24486 Output
: constant List_Id
:= Choices
(Clause
);
24487 Last_Input
: Node_Id
;
24489 New_Clause
: Node_Id
;
24490 Next_Input
: Node_Id
;
24493 -- Normalization is performed only when the original clause has
24494 -- more than one input. Multiple inputs appear as an aggregate.
24496 if Nkind
(Inputs
) = N_Aggregate
then
24497 Last_Input
:= Last
(Expressions
(Inputs
));
24499 -- Create a new clause for each input
24501 Input
:= First
(Expressions
(Inputs
));
24502 while Present
(Input
) loop
24503 Next_Input
:= Next
(Input
);
24505 -- Unhook the current input from the original input list
24506 -- because it will be relocated to a new clause.
24510 -- Special processing for the last input. At this point the
24511 -- original aggregate has been stripped down to one element.
24512 -- Replace the aggregate by the element itself.
24514 if Input
= Last_Input
then
24515 Rewrite
(Inputs
, Input
);
24517 -- Generate a clause of the form:
24522 Make_Component_Association
(Loc
,
24523 Choices
=> New_Copy_List_Tree
(Output
),
24524 Expression
=> Input
);
24526 -- The new clause contains replicated content that has
24527 -- already been analyzed, mark the clause as analyzed.
24529 Set_Analyzed
(New_Clause
);
24530 Insert_After
(Clause
, New_Clause
);
24533 Input
:= Next_Input
;
24536 end Normalize_Inputs
;
24538 -----------------------
24539 -- Normalize_Outputs --
24540 -----------------------
24542 procedure Normalize_Outputs
(Clause
: Node_Id
) is
24543 Inputs
: constant Node_Id
:= Expression
(Clause
);
24544 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24545 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
24546 Last_Output
: Node_Id
;
24547 New_Clause
: Node_Id
;
24548 Next_Output
: Node_Id
;
24552 -- Multiple outputs appear as an aggregate. Nothing to do when
24553 -- the clause has exactly one output.
24555 if Nkind
(Outputs
) = N_Aggregate
then
24556 Last_Output
:= Last
(Expressions
(Outputs
));
24558 -- Create a clause for each output. Note that each time a new
24559 -- clause is created, the original output list slowly shrinks
24560 -- until there is one item left.
24562 Output
:= First
(Expressions
(Outputs
));
24563 while Present
(Output
) loop
24564 Next_Output
:= Next
(Output
);
24566 -- Unhook the output from the original output list as it
24567 -- will be relocated to a new clause.
24571 -- Special processing for the last output. At this point
24572 -- the original aggregate has been stripped down to one
24573 -- element. Replace the aggregate by the element itself.
24575 if Output
= Last_Output
then
24576 Rewrite
(Outputs
, Output
);
24579 -- Generate a clause of the form:
24580 -- (Output => Inputs)
24583 Make_Component_Association
(Loc
,
24584 Choices
=> New_List
(Output
),
24585 Expression
=> New_Copy_Tree
(Inputs
));
24587 -- The new clause contains replicated content that has
24588 -- already been analyzed. There is not need to reanalyze
24591 Set_Analyzed
(New_Clause
);
24592 Insert_After
(Clause
, New_Clause
);
24595 Output
:= Next_Output
;
24598 end Normalize_Outputs
;
24604 -- Start of processing for Normalize_Clauses
24607 Clause
:= First
(Clauses
);
24608 while Present
(Clause
) loop
24609 Normalize_Outputs
(Clause
);
24613 Clause
:= First
(Clauses
);
24614 while Present
(Clause
) loop
24615 Normalize_Inputs
(Clause
);
24618 end Normalize_Clauses
;
24620 --------------------------
24621 -- Remove_Extra_Clauses --
24622 --------------------------
24624 procedure Remove_Extra_Clauses
24625 (Clauses
: List_Id
;
24626 Matched_Items
: Elist_Id
)
24630 Input_Id
: Entity_Id
;
24631 Next_Clause
: Node_Id
;
24633 State_Id
: Entity_Id
;
24636 Clause
:= First
(Clauses
);
24637 while Present
(Clause
) loop
24638 Next_Clause
:= Next
(Clause
);
24640 Input
:= Expression
(Clause
);
24641 Output
:= First
(Choices
(Clause
));
24643 -- Recognize a clause of the form
24647 -- where Input is a constituent of a state which was already
24648 -- successfully matched. This clause must be removed because it
24649 -- simply indicates that some of the constituents of the state
24652 -- Refined_State => (State => (Constit_1, Constit_2))
24653 -- Depends => (Output => State)
24654 -- Refined_Depends => ((Output => Constit_1), -- State matched
24655 -- (null => Constit_2)) -- OK
24657 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
24659 -- Handle abstract views generated for limited with clauses
24661 Input_Id
:= Available_View
(Entity_Of
(Input
));
24663 -- The input must be a constituent of a state
24665 if Ekind_In
(Input_Id
, E_Abstract_State
,
24668 and then Present
(Encapsulating_State
(Input_Id
))
24670 State_Id
:= Encapsulating_State
(Input_Id
);
24672 -- The state must have a non-null visible refinement and be
24673 -- matched in a previous clause.
24675 if Has_Non_Null_Visible_Refinement
(State_Id
)
24676 and then Contains
(Matched_Items
, State_Id
)
24682 -- Recognize a clause of the form
24686 -- where Output is an arbitrary item. This clause must be removed
24687 -- because a null input legitimately matches anything.
24689 elsif Nkind
(Input
) = N_Null
then
24693 Clause
:= Next_Clause
;
24695 end Remove_Extra_Clauses
;
24697 --------------------------
24698 -- Report_Extra_Clauses --
24699 --------------------------
24701 procedure Report_Extra_Clauses
24702 (Spec_Id
: Entity_Id
;
24708 -- Do not perform this check in an instance because it was already
24709 -- performed successfully in the generic template.
24711 if Is_Generic_Instance
(Spec_Id
) then
24714 elsif Present
(Clauses
) then
24715 Clause
:= First
(Clauses
);
24716 while Present
(Clause
) loop
24718 ("unmatched or extra clause in dependence refinement",
24724 end Report_Extra_Clauses
;
24728 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
24729 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
24730 Errors
: constant Nat
:= Serious_Errors_Detected
;
24737 Body_Inputs
: Elist_Id
:= No_Elist
;
24738 Body_Outputs
: Elist_Id
:= No_Elist
;
24739 -- The inputs and outputs of the subprogram body synthesized from pragma
24740 -- Refined_Depends.
24742 Dependencies
: List_Id
:= No_List
;
24744 -- The corresponding Depends pragma along with its clauses
24746 Matched_Items
: Elist_Id
:= No_Elist
;
24747 -- A list containing the entities of all successfully matched items
24748 -- found in pragma Depends.
24750 Refinements
: List_Id
:= No_List
;
24751 -- The clauses of pragma Refined_Depends
24753 Spec_Id
: Entity_Id
;
24754 -- The entity of the subprogram subject to pragma Refined_Depends
24756 Spec_Inputs
: Elist_Id
:= No_Elist
;
24757 Spec_Outputs
: Elist_Id
:= No_Elist
;
24758 -- The inputs and outputs of the subprogram spec synthesized from pragma
24761 States
: Elist_Id
:= No_Elist
;
24762 -- A list containing the entities of all states whose constituents
24763 -- appear in pragma Depends.
24765 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24768 -- Do not analyze the pragma multiple times
24770 if Is_Analyzed_Pragma
(N
) then
24774 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
24776 -- Use the anonymous object as the proper spec when Refined_Depends
24777 -- applies to the body of a single task type. The object carries the
24778 -- proper Chars as well as all non-refined versions of pragmas.
24780 if Is_Single_Concurrent_Type
(Spec_Id
) then
24781 Spec_Id
:= Anonymous_Object
(Spec_Id
);
24784 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
24786 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24787 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24789 if No
(Depends
) then
24791 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
24792 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
24796 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
24798 -- A null dependency relation renders the refinement useless because it
24799 -- cannot possibly mention abstract states with visible refinement. Note
24800 -- that the inverse is not true as states may be refined to null
24801 -- (SPARK RM 7.2.5(2)).
24803 if Nkind
(Deps
) = N_Null
then
24805 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
24806 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
24810 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24811 -- This ensures that the categorization of all refined dependency items
24812 -- is consistent with their role.
24814 Analyze_Depends_In_Decl_Part
(N
);
24816 -- Do not match dependencies against refinements if Refined_Depends is
24817 -- illegal to avoid emitting misleading error.
24819 if Serious_Errors_Detected
= Errors
then
24821 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24822 -- the inputs and outputs of the subprogram spec and body to verify
24823 -- the use of states with visible refinement and their constituents.
24825 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
24826 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
24828 Collect_Subprogram_Inputs_Outputs
24829 (Subp_Id
=> Spec_Id
,
24830 Synthesize
=> True,
24831 Subp_Inputs
=> Spec_Inputs
,
24832 Subp_Outputs
=> Spec_Outputs
,
24833 Global_Seen
=> Dummy
);
24835 Collect_Subprogram_Inputs_Outputs
24836 (Subp_Id
=> Body_Id
,
24837 Synthesize
=> True,
24838 Subp_Inputs
=> Body_Inputs
,
24839 Subp_Outputs
=> Body_Outputs
,
24840 Global_Seen
=> Dummy
);
24842 -- For an output state with a visible refinement, ensure that all
24843 -- constituents appear as outputs in the dependency refinement.
24845 Check_Output_States
24846 (Spec_Id
=> Spec_Id
,
24847 Spec_Inputs
=> Spec_Inputs
,
24848 Spec_Outputs
=> Spec_Outputs
,
24849 Body_Inputs
=> Body_Inputs
,
24850 Body_Outputs
=> Body_Outputs
);
24853 -- Matching is disabled in ASIS because clauses are not normalized as
24854 -- this is a tree altering activity similar to expansion.
24860 -- Multiple dependency clauses appear as component associations of an
24861 -- aggregate. Note that the clauses are copied because the algorithm
24862 -- modifies them and this should not be visible in Depends.
24864 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
24865 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
24866 Normalize_Clauses
(Dependencies
);
24868 -- Gather all states which appear in Depends
24870 States
:= Collect_States
(Dependencies
);
24872 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
24874 if Nkind
(Refs
) = N_Null
then
24875 Refinements
:= No_List
;
24877 -- Multiple dependency clauses appear as component associations of an
24878 -- aggregate. Note that the clauses are copied because the algorithm
24879 -- modifies them and this should not be visible in Refined_Depends.
24881 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
24882 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
24883 Normalize_Clauses
(Refinements
);
24886 -- At this point the clauses of pragmas Depends and Refined_Depends
24887 -- have been normalized into simple dependencies between one output
24888 -- and one input. Examine all clauses of pragma Depends looking for
24889 -- matching clauses in pragma Refined_Depends.
24891 Clause
:= First
(Dependencies
);
24892 while Present
(Clause
) loop
24893 Check_Dependency_Clause
24894 (Spec_Id
=> Spec_Id
,
24895 Dep_Clause
=> Clause
,
24896 Dep_States
=> States
,
24897 Refinements
=> Refinements
,
24898 Matched_Items
=> Matched_Items
);
24903 -- Pragma Refined_Depends may contain multiple clarification clauses
24904 -- which indicate that certain constituents do not influence the data
24905 -- flow in any way. Such clauses must be removed as long as the state
24906 -- has been matched, otherwise they will be incorrectly flagged as
24909 -- Refined_State => (State => (Constit_1, Constit_2))
24910 -- Depends => (Output => State)
24911 -- Refined_Depends => ((Output => Constit_1), -- State matched
24912 -- (null => Constit_2)) -- must be removed
24914 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
24916 if Serious_Errors_Detected
= Errors
then
24917 Report_Extra_Clauses
(Spec_Id
, Refinements
);
24922 Set_Is_Analyzed_Pragma
(N
);
24923 end Analyze_Refined_Depends_In_Decl_Part
;
24925 -----------------------------------------
24926 -- Analyze_Refined_Global_In_Decl_Part --
24927 -----------------------------------------
24929 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
24931 -- The corresponding Global pragma
24933 Has_In_State
: Boolean := False;
24934 Has_In_Out_State
: Boolean := False;
24935 Has_Out_State
: Boolean := False;
24936 Has_Proof_In_State
: Boolean := False;
24937 -- These flags are set when the corresponding Global pragma has a state
24938 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24941 Has_Null_State
: Boolean := False;
24942 -- This flag is set when the corresponding Global pragma has at least
24943 -- one state with a null refinement.
24945 In_Constits
: Elist_Id
:= No_Elist
;
24946 In_Out_Constits
: Elist_Id
:= No_Elist
;
24947 Out_Constits
: Elist_Id
:= No_Elist
;
24948 Proof_In_Constits
: Elist_Id
:= No_Elist
;
24949 -- These lists contain the entities of all Input, In_Out, Output and
24950 -- Proof_In constituents that appear in Refined_Global and participate
24951 -- in state refinement.
24953 In_Items
: Elist_Id
:= No_Elist
;
24954 In_Out_Items
: Elist_Id
:= No_Elist
;
24955 Out_Items
: Elist_Id
:= No_Elist
;
24956 Proof_In_Items
: Elist_Id
:= No_Elist
;
24957 -- These lists contain the entities of all Input, In_Out, Output and
24958 -- Proof_In items defined in the corresponding Global pragma.
24960 Repeat_Items
: Elist_Id
:= No_Elist
;
24961 -- A list of all global items without full visible refinement found
24962 -- in pragma Global. These states should be repeated in the global
24963 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
24964 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
24966 Spec_Id
: Entity_Id
;
24967 -- The entity of the subprogram subject to pragma Refined_Global
24969 States
: Elist_Id
:= No_Elist
;
24970 -- A list of all states with full or partial visible refinement found in
24973 procedure Check_In_Out_States
;
24974 -- Determine whether the corresponding Global pragma mentions In_Out
24975 -- states with visible refinement and if so, ensure that one of the
24976 -- following completions apply to the constituents of the state:
24977 -- 1) there is at least one constituent of mode In_Out
24978 -- 2) there is at least one Input and one Output constituent
24979 -- 3) not all constituents are present and one of them is of mode
24981 -- This routine may remove elements from In_Constits, In_Out_Constits,
24982 -- Out_Constits and Proof_In_Constits.
24984 procedure Check_Input_States
;
24985 -- Determine whether the corresponding Global pragma mentions Input
24986 -- states with visible refinement and if so, ensure that at least one of
24987 -- its constituents appears as an Input item in Refined_Global.
24988 -- This routine may remove elements from In_Constits, In_Out_Constits,
24989 -- Out_Constits and Proof_In_Constits.
24991 procedure Check_Output_States
;
24992 -- Determine whether the corresponding Global pragma mentions Output
24993 -- states with visible refinement and if so, ensure that all of its
24994 -- constituents appear as Output items in Refined_Global.
24995 -- This routine may remove elements from In_Constits, In_Out_Constits,
24996 -- Out_Constits and Proof_In_Constits.
24998 procedure Check_Proof_In_States
;
24999 -- Determine whether the corresponding Global pragma mentions Proof_In
25000 -- states with visible refinement and if so, ensure that at least one of
25001 -- its constituents appears as a Proof_In item in Refined_Global.
25002 -- This routine may remove elements from In_Constits, In_Out_Constits,
25003 -- Out_Constits and Proof_In_Constits.
25005 procedure Check_Refined_Global_List
25007 Global_Mode
: Name_Id
:= Name_Input
);
25008 -- Verify the legality of a single global list declaration. Global_Mode
25009 -- denotes the current mode in effect.
25011 procedure Collect_Global_Items
25013 Mode
: Name_Id
:= Name_Input
);
25014 -- Gather all Input, In_Out, Output and Proof_In items from node List
25015 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25016 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25017 -- and Has_Proof_In_State are set when there is at least one abstract
25018 -- state with full or partial visible refinement available in the
25019 -- corresponding mode. Flag Has_Null_State is set when at least state
25020 -- has a null refinement. Mode denotes the current global mode in
25023 function Present_Then_Remove
25025 Item
: Entity_Id
) return Boolean;
25026 -- Search List for a particular entity Item. If Item has been found,
25027 -- remove it from List. This routine is used to strip lists In_Constits,
25028 -- In_Out_Constits and Out_Constits of valid constituents.
25030 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
25031 -- Same as function Present_Then_Remove, but do not report the presence
25032 -- of Item in List.
25034 procedure Report_Extra_Constituents
;
25035 -- Emit an error for each constituent found in lists In_Constits,
25036 -- In_Out_Constits and Out_Constits.
25038 procedure Report_Missing_Items
;
25039 -- Emit an error for each global item not repeated found in list
25042 -------------------------
25043 -- Check_In_Out_States --
25044 -------------------------
25046 procedure Check_In_Out_States
is
25047 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25048 -- Determine whether one of the following coverage scenarios is in
25050 -- 1) there is at least one constituent of mode In_Out or Output
25051 -- 2) there is at least one pair of constituents with modes Input
25052 -- and Output, or Proof_In and Output.
25053 -- 3) there is at least one constituent of mode Output and not all
25054 -- constituents are present.
25055 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25057 -----------------------------
25058 -- Check_Constituent_Usage --
25059 -----------------------------
25061 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25062 Constits
: constant Elist_Id
:=
25063 Partial_Refinement_Constituents
(State_Id
);
25064 Constit_Elmt
: Elmt_Id
;
25065 Constit_Id
: Entity_Id
;
25066 Has_Missing
: Boolean := False;
25067 In_Out_Seen
: Boolean := False;
25068 Input_Seen
: Boolean := False;
25069 Output_Seen
: Boolean := False;
25070 Proof_In_Seen
: Boolean := False;
25073 -- Process all the constituents of the state and note their modes
25074 -- within the global refinement.
25076 if Present
(Constits
) then
25077 Constit_Elmt
:= First_Elmt
(Constits
);
25078 while Present
(Constit_Elmt
) loop
25079 Constit_Id
:= Node
(Constit_Elmt
);
25081 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25082 Input_Seen
:= True;
25084 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
25085 In_Out_Seen
:= True;
25087 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25088 Output_Seen
:= True;
25090 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25092 Proof_In_Seen
:= True;
25095 Has_Missing
:= True;
25098 Next_Elmt
(Constit_Elmt
);
25102 -- An In_Out constituent is a valid completion
25104 if In_Out_Seen
then
25107 -- A pair of one Input/Proof_In and one Output constituent is a
25108 -- valid completion.
25110 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
25113 elsif Output_Seen
then
25115 -- A single Output constituent is a valid completion only when
25116 -- some of the other constituents are missing.
25118 if Has_Missing
then
25121 -- Otherwise all constituents are of mode Output
25125 ("global refinement of state & must include at least one "
25126 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
25130 -- The state lacks a completion. When full refinement is visible,
25131 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
25132 -- refinement is visible, emit an error if the abstract state
25133 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
25134 -- both are utilized, Check_State_And_Constituent_Use. will issue
25137 elsif not Input_Seen
25138 and then not In_Out_Seen
25139 and then not Output_Seen
25140 and then not Proof_In_Seen
25142 if Has_Visible_Refinement
(State_Id
)
25143 or else Contains
(Repeat_Items
, State_Id
)
25146 ("missing global refinement of state &", N
, State_Id
);
25149 -- Otherwise the state has a malformed completion where at least
25150 -- one of the constituents has a different mode.
25154 ("global refinement of state & redefines the mode of its "
25155 & "constituents", N
, State_Id
);
25157 end Check_Constituent_Usage
;
25161 Item_Elmt
: Elmt_Id
;
25162 Item_Id
: Entity_Id
;
25164 -- Start of processing for Check_In_Out_States
25167 -- Do not perform this check in an instance because it was already
25168 -- performed successfully in the generic template.
25170 if Is_Generic_Instance
(Spec_Id
) then
25173 -- Inspect the In_Out items of the corresponding Global pragma
25174 -- looking for a state with a visible refinement.
25176 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
25177 Item_Elmt
:= First_Elmt
(In_Out_Items
);
25178 while Present
(Item_Elmt
) loop
25179 Item_Id
:= Node
(Item_Elmt
);
25181 -- Ensure that one of the three coverage variants is satisfied
25183 if Ekind
(Item_Id
) = E_Abstract_State
25184 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25186 Check_Constituent_Usage
(Item_Id
);
25189 Next_Elmt
(Item_Elmt
);
25192 end Check_In_Out_States
;
25194 ------------------------
25195 -- Check_Input_States --
25196 ------------------------
25198 procedure Check_Input_States
is
25199 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25200 -- Determine whether at least one constituent of state State_Id with
25201 -- full or partial visible refinement is used and has mode Input.
25202 -- Ensure that the remaining constituents do not have In_Out or
25203 -- Output modes. Emit an error if this is not the case
25204 -- (SPARK RM 7.2.4(5)).
25206 -----------------------------
25207 -- Check_Constituent_Usage --
25208 -----------------------------
25210 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25211 Constits
: constant Elist_Id
:=
25212 Partial_Refinement_Constituents
(State_Id
);
25213 Constit_Elmt
: Elmt_Id
;
25214 Constit_Id
: Entity_Id
;
25215 In_Seen
: Boolean := False;
25218 if Present
(Constits
) then
25219 Constit_Elmt
:= First_Elmt
(Constits
);
25220 while Present
(Constit_Elmt
) loop
25221 Constit_Id
:= Node
(Constit_Elmt
);
25223 -- At least one of the constituents appears as an Input
25225 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25228 -- A Proof_In constituent can refine an Input state as long
25229 -- as there is at least one Input constituent present.
25231 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25235 -- The constituent appears in the global refinement, but has
25236 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25238 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25239 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25241 Error_Msg_Name_1
:= Chars
(State_Id
);
25243 ("constituent & of state % must have mode `Input` in "
25244 & "global refinement", N
, Constit_Id
);
25247 Next_Elmt
(Constit_Elmt
);
25251 -- Not one of the constituents appeared as Input. Always emit an
25252 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25253 -- When only partial refinement is visible, emit an error if the
25254 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25255 -- the case where both are utilized, an error will be issued in
25256 -- Check_State_And_Constituent_Use.
25259 and then (Has_Visible_Refinement
(State_Id
)
25260 or else Contains
(Repeat_Items
, State_Id
))
25263 ("global refinement of state & must include at least one "
25264 & "constituent of mode `Input`", N
, State_Id
);
25266 end Check_Constituent_Usage
;
25270 Item_Elmt
: Elmt_Id
;
25271 Item_Id
: Entity_Id
;
25273 -- Start of processing for Check_Input_States
25276 -- Do not perform this check in an instance because it was already
25277 -- performed successfully in the generic template.
25279 if Is_Generic_Instance
(Spec_Id
) then
25282 -- Inspect the Input items of the corresponding Global pragma looking
25283 -- for a state with a visible refinement.
25285 elsif Has_In_State
and then Present
(In_Items
) then
25286 Item_Elmt
:= First_Elmt
(In_Items
);
25287 while Present
(Item_Elmt
) loop
25288 Item_Id
:= Node
(Item_Elmt
);
25290 -- When full refinement is visible, ensure that at least one of
25291 -- the constituents is utilized and is of mode Input. When only
25292 -- partial refinement is visible, ensure that either one of
25293 -- the constituents is utilized and is of mode Input, or the
25294 -- abstract state is repeated and no constituent is utilized.
25296 if Ekind
(Item_Id
) = E_Abstract_State
25297 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25299 Check_Constituent_Usage
(Item_Id
);
25302 Next_Elmt
(Item_Elmt
);
25305 end Check_Input_States
;
25307 -------------------------
25308 -- Check_Output_States --
25309 -------------------------
25311 procedure Check_Output_States
is
25312 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25313 -- Determine whether all constituents of state State_Id with full
25314 -- visible refinement are used and have mode Output. Emit an error
25315 -- if this is not the case (SPARK RM 7.2.4(5)).
25317 -----------------------------
25318 -- Check_Constituent_Usage --
25319 -----------------------------
25321 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25322 Constits
: constant Elist_Id
:=
25323 Partial_Refinement_Constituents
(State_Id
);
25324 Only_Partial
: constant Boolean :=
25325 not Has_Visible_Refinement
(State_Id
);
25326 Constit_Elmt
: Elmt_Id
;
25327 Constit_Id
: Entity_Id
;
25328 Posted
: Boolean := False;
25331 if Present
(Constits
) then
25332 Constit_Elmt
:= First_Elmt
(Constits
);
25333 while Present
(Constit_Elmt
) loop
25334 Constit_Id
:= Node
(Constit_Elmt
);
25336 -- Issue an error when a constituent of State_Id is utilized
25337 -- and State_Id has only partial visible refinement
25338 -- (SPARK RM 7.2.4(3d)).
25340 if Only_Partial
then
25341 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
25342 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
25344 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25346 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25348 Error_Msg_Name_1
:= Chars
(State_Id
);
25350 ("constituent & of state % cannot be used in global "
25351 & "refinement", N
, Constit_Id
);
25352 Error_Msg_Name_1
:= Chars
(State_Id
);
25353 SPARK_Msg_N
("\use state % instead", N
);
25356 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25359 -- The constituent appears in the global refinement, but has
25360 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25362 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25363 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25364 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25366 Error_Msg_Name_1
:= Chars
(State_Id
);
25368 ("constituent & of state % must have mode `Output` in "
25369 & "global refinement", N
, Constit_Id
);
25371 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25377 ("`Output` state & must be replaced by all its "
25378 & "constituents in global refinement", N
, State_Id
);
25382 ("\constituent & is missing in output list",
25386 Next_Elmt
(Constit_Elmt
);
25389 end Check_Constituent_Usage
;
25393 Item_Elmt
: Elmt_Id
;
25394 Item_Id
: Entity_Id
;
25396 -- Start of processing for Check_Output_States
25399 -- Do not perform this check in an instance because it was already
25400 -- performed successfully in the generic template.
25402 if Is_Generic_Instance
(Spec_Id
) then
25405 -- Inspect the Output items of the corresponding Global pragma
25406 -- looking for a state with a visible refinement.
25408 elsif Has_Out_State
and then Present
(Out_Items
) then
25409 Item_Elmt
:= First_Elmt
(Out_Items
);
25410 while Present
(Item_Elmt
) loop
25411 Item_Id
:= Node
(Item_Elmt
);
25413 -- When full refinement is visible, ensure that all of the
25414 -- constituents are utilized and they have mode Output. When
25415 -- only partial refinement is visible, ensure that no
25416 -- constituent is utilized.
25418 if Ekind
(Item_Id
) = E_Abstract_State
25419 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25421 Check_Constituent_Usage
(Item_Id
);
25424 Next_Elmt
(Item_Elmt
);
25427 end Check_Output_States
;
25429 ---------------------------
25430 -- Check_Proof_In_States --
25431 ---------------------------
25433 procedure Check_Proof_In_States
is
25434 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25435 -- Determine whether at least one constituent of state State_Id with
25436 -- full or partial visible refinement is used and has mode Proof_In.
25437 -- Ensure that the remaining constituents do not have Input, In_Out,
25438 -- or Output modes. Emit an error if this is not the case
25439 -- (SPARK RM 7.2.4(5)).
25441 -----------------------------
25442 -- Check_Constituent_Usage --
25443 -----------------------------
25445 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25446 Constits
: constant Elist_Id
:=
25447 Partial_Refinement_Constituents
(State_Id
);
25448 Constit_Elmt
: Elmt_Id
;
25449 Constit_Id
: Entity_Id
;
25450 Proof_In_Seen
: Boolean := False;
25453 if Present
(Constits
) then
25454 Constit_Elmt
:= First_Elmt
(Constits
);
25455 while Present
(Constit_Elmt
) loop
25456 Constit_Id
:= Node
(Constit_Elmt
);
25458 -- At least one of the constituents appears as Proof_In
25460 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
25461 Proof_In_Seen
:= True;
25463 -- The constituent appears in the global refinement, but has
25464 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25466 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25467 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25468 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25470 Error_Msg_Name_1
:= Chars
(State_Id
);
25472 ("constituent & of state % must have mode `Proof_In` "
25473 & "in global refinement", N
, Constit_Id
);
25476 Next_Elmt
(Constit_Elmt
);
25480 -- Not one of the constituents appeared as Proof_In. Always emit
25481 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25482 -- When only partial refinement is visible, emit an error if the
25483 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25484 -- the case where both are utilized, an error will be issued by
25485 -- Check_State_And_Constituent_Use.
25487 if not Proof_In_Seen
25488 and then (Has_Visible_Refinement
(State_Id
)
25489 or else Contains
(Repeat_Items
, State_Id
))
25492 ("global refinement of state & must include at least one "
25493 & "constituent of mode `Proof_In`", N
, State_Id
);
25495 end Check_Constituent_Usage
;
25499 Item_Elmt
: Elmt_Id
;
25500 Item_Id
: Entity_Id
;
25502 -- Start of processing for Check_Proof_In_States
25505 -- Do not perform this check in an instance because it was already
25506 -- performed successfully in the generic template.
25508 if Is_Generic_Instance
(Spec_Id
) then
25511 -- Inspect the Proof_In items of the corresponding Global pragma
25512 -- looking for a state with a visible refinement.
25514 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
25515 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
25516 while Present
(Item_Elmt
) loop
25517 Item_Id
:= Node
(Item_Elmt
);
25519 -- Ensure that at least one of the constituents is utilized
25520 -- and is of mode Proof_In. When only partial refinement is
25521 -- visible, ensure that either one of the constituents is
25522 -- utilized and is of mode Proof_In, or the abstract state
25523 -- is repeated and no constituent is utilized.
25525 if Ekind
(Item_Id
) = E_Abstract_State
25526 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25528 Check_Constituent_Usage
(Item_Id
);
25531 Next_Elmt
(Item_Elmt
);
25534 end Check_Proof_In_States
;
25536 -------------------------------
25537 -- Check_Refined_Global_List --
25538 -------------------------------
25540 procedure Check_Refined_Global_List
25542 Global_Mode
: Name_Id
:= Name_Input
)
25544 procedure Check_Refined_Global_Item
25546 Global_Mode
: Name_Id
);
25547 -- Verify the legality of a single global item declaration. Parameter
25548 -- Global_Mode denotes the current mode in effect.
25550 -------------------------------
25551 -- Check_Refined_Global_Item --
25552 -------------------------------
25554 procedure Check_Refined_Global_Item
25556 Global_Mode
: Name_Id
)
25558 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
25560 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
25561 -- Issue a common error message for all mode mismatches. Expect
25562 -- denotes the expected mode.
25564 -----------------------------
25565 -- Inconsistent_Mode_Error --
25566 -----------------------------
25568 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
25571 ("global item & has inconsistent modes", Item
, Item_Id
);
25573 Error_Msg_Name_1
:= Global_Mode
;
25574 Error_Msg_Name_2
:= Expect
;
25575 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
25576 end Inconsistent_Mode_Error
;
25580 Enc_State
: Entity_Id
:= Empty
;
25581 -- Encapsulating state for constituent, Empty otherwise
25583 -- Start of processing for Check_Refined_Global_Item
25586 if Ekind_In
(Item_Id
, E_Abstract_State
,
25590 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
25593 -- When the state or object acts as a constituent of another
25594 -- state with a visible refinement, collect it for the state
25595 -- completeness checks performed later on. Note that the item
25596 -- acts as a constituent only when the encapsulating state is
25597 -- present in pragma Global.
25599 if Present
(Enc_State
)
25600 and then (Has_Visible_Refinement
(Enc_State
)
25601 or else Has_Partial_Visible_Refinement
(Enc_State
))
25602 and then Contains
(States
, Enc_State
)
25604 -- If the state has only partial visible refinement, remove it
25605 -- from the list of items that should be repeated from pragma
25608 if not Has_Visible_Refinement
(Enc_State
) then
25609 Present_Then_Remove
(Repeat_Items
, Enc_State
);
25612 if Global_Mode
= Name_Input
then
25613 Append_New_Elmt
(Item_Id
, In_Constits
);
25615 elsif Global_Mode
= Name_In_Out
then
25616 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
25618 elsif Global_Mode
= Name_Output
then
25619 Append_New_Elmt
(Item_Id
, Out_Constits
);
25621 elsif Global_Mode
= Name_Proof_In
then
25622 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
25625 -- When not a constituent, ensure that both occurrences of the
25626 -- item in pragmas Global and Refined_Global match. Also remove
25627 -- it when present from the list of items that should be repeated
25628 -- from pragma Global.
25631 Present_Then_Remove
(Repeat_Items
, Item_Id
);
25633 if Contains
(In_Items
, Item_Id
) then
25634 if Global_Mode
/= Name_Input
then
25635 Inconsistent_Mode_Error
(Name_Input
);
25638 elsif Contains
(In_Out_Items
, Item_Id
) then
25639 if Global_Mode
/= Name_In_Out
then
25640 Inconsistent_Mode_Error
(Name_In_Out
);
25643 elsif Contains
(Out_Items
, Item_Id
) then
25644 if Global_Mode
/= Name_Output
then
25645 Inconsistent_Mode_Error
(Name_Output
);
25648 elsif Contains
(Proof_In_Items
, Item_Id
) then
25651 -- The item does not appear in the corresponding Global pragma,
25652 -- it must be an extra (SPARK RM 7.2.4(3)).
25655 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
25658 end Check_Refined_Global_Item
;
25664 -- Start of processing for Check_Refined_Global_List
25667 -- Do not perform this check in an instance because it was already
25668 -- performed successfully in the generic template.
25670 if Is_Generic_Instance
(Spec_Id
) then
25673 elsif Nkind
(List
) = N_Null
then
25676 -- Single global item declaration
25678 elsif Nkind_In
(List
, N_Expanded_Name
,
25680 N_Selected_Component
)
25682 Check_Refined_Global_Item
(List
, Global_Mode
);
25684 -- Simple global list or moded global list declaration
25686 elsif Nkind
(List
) = N_Aggregate
then
25688 -- The declaration of a simple global list appear as a collection
25691 if Present
(Expressions
(List
)) then
25692 Item
:= First
(Expressions
(List
));
25693 while Present
(Item
) loop
25694 Check_Refined_Global_Item
(Item
, Global_Mode
);
25698 -- The declaration of a moded global list appears as a collection
25699 -- of component associations where individual choices denote
25702 elsif Present
(Component_Associations
(List
)) then
25703 Item
:= First
(Component_Associations
(List
));
25704 while Present
(Item
) loop
25705 Check_Refined_Global_List
25706 (List
=> Expression
(Item
),
25707 Global_Mode
=> Chars
(First
(Choices
(Item
))));
25715 raise Program_Error
;
25721 raise Program_Error
;
25723 end Check_Refined_Global_List
;
25725 --------------------------
25726 -- Collect_Global_Items --
25727 --------------------------
25729 procedure Collect_Global_Items
25731 Mode
: Name_Id
:= Name_Input
)
25733 procedure Collect_Global_Item
25735 Item_Mode
: Name_Id
);
25736 -- Add a single item to the appropriate list. Item_Mode denotes the
25737 -- current mode in effect.
25739 -------------------------
25740 -- Collect_Global_Item --
25741 -------------------------
25743 procedure Collect_Global_Item
25745 Item_Mode
: Name_Id
)
25747 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
25748 -- The above handles abstract views of variables and states built
25749 -- for limited with clauses.
25752 -- Signal that the global list contains at least one abstract
25753 -- state with a visible refinement. Note that the refinement may
25754 -- be null in which case there are no constituents.
25756 if Ekind
(Item_Id
) = E_Abstract_State
then
25757 if Has_Null_Visible_Refinement
(Item_Id
) then
25758 Has_Null_State
:= True;
25760 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25761 Append_New_Elmt
(Item_Id
, States
);
25763 if Item_Mode
= Name_Input
then
25764 Has_In_State
:= True;
25765 elsif Item_Mode
= Name_In_Out
then
25766 Has_In_Out_State
:= True;
25767 elsif Item_Mode
= Name_Output
then
25768 Has_Out_State
:= True;
25769 elsif Item_Mode
= Name_Proof_In
then
25770 Has_Proof_In_State
:= True;
25775 -- Record global items without full visible refinement found in
25776 -- pragma Global which should be repeated in the global refinement
25777 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
25779 if Ekind
(Item_Id
) /= E_Abstract_State
25780 or else not Has_Visible_Refinement
(Item_Id
)
25782 Append_New_Elmt
(Item_Id
, Repeat_Items
);
25785 -- Add the item to the proper list
25787 if Item_Mode
= Name_Input
then
25788 Append_New_Elmt
(Item_Id
, In_Items
);
25789 elsif Item_Mode
= Name_In_Out
then
25790 Append_New_Elmt
(Item_Id
, In_Out_Items
);
25791 elsif Item_Mode
= Name_Output
then
25792 Append_New_Elmt
(Item_Id
, Out_Items
);
25793 elsif Item_Mode
= Name_Proof_In
then
25794 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
25796 end Collect_Global_Item
;
25802 -- Start of processing for Collect_Global_Items
25805 if Nkind
(List
) = N_Null
then
25808 -- Single global item declaration
25810 elsif Nkind_In
(List
, N_Expanded_Name
,
25812 N_Selected_Component
)
25814 Collect_Global_Item
(List
, Mode
);
25816 -- Single global list or moded global list declaration
25818 elsif Nkind
(List
) = N_Aggregate
then
25820 -- The declaration of a simple global list appear as a collection
25823 if Present
(Expressions
(List
)) then
25824 Item
:= First
(Expressions
(List
));
25825 while Present
(Item
) loop
25826 Collect_Global_Item
(Item
, Mode
);
25830 -- The declaration of a moded global list appears as a collection
25831 -- of component associations where individual choices denote mode.
25833 elsif Present
(Component_Associations
(List
)) then
25834 Item
:= First
(Component_Associations
(List
));
25835 while Present
(Item
) loop
25836 Collect_Global_Items
25837 (List
=> Expression
(Item
),
25838 Mode
=> Chars
(First
(Choices
(Item
))));
25846 raise Program_Error
;
25849 -- To accomodate partial decoration of disabled SPARK features, this
25850 -- routine may be called with illegal input. If this is the case, do
25851 -- not raise Program_Error.
25856 end Collect_Global_Items
;
25858 -------------------------
25859 -- Present_Then_Remove --
25860 -------------------------
25862 function Present_Then_Remove
25864 Item
: Entity_Id
) return Boolean
25869 if Present
(List
) then
25870 Elmt
:= First_Elmt
(List
);
25871 while Present
(Elmt
) loop
25872 if Node
(Elmt
) = Item
then
25873 Remove_Elmt
(List
, Elmt
);
25882 end Present_Then_Remove
;
25884 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
25887 Ignore
:= Present_Then_Remove
(List
, Item
);
25888 end Present_Then_Remove
;
25890 -------------------------------
25891 -- Report_Extra_Constituents --
25892 -------------------------------
25894 procedure Report_Extra_Constituents
is
25895 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
25896 -- Emit an error for every element of List
25898 ---------------------------------------
25899 -- Report_Extra_Constituents_In_List --
25900 ---------------------------------------
25902 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
25903 Constit_Elmt
: Elmt_Id
;
25906 if Present
(List
) then
25907 Constit_Elmt
:= First_Elmt
(List
);
25908 while Present
(Constit_Elmt
) loop
25909 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
25910 Next_Elmt
(Constit_Elmt
);
25913 end Report_Extra_Constituents_In_List
;
25915 -- Start of processing for Report_Extra_Constituents
25918 -- Do not perform this check in an instance because it was already
25919 -- performed successfully in the generic template.
25921 if Is_Generic_Instance
(Spec_Id
) then
25925 Report_Extra_Constituents_In_List
(In_Constits
);
25926 Report_Extra_Constituents_In_List
(In_Out_Constits
);
25927 Report_Extra_Constituents_In_List
(Out_Constits
);
25928 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
25930 end Report_Extra_Constituents
;
25932 --------------------------
25933 -- Report_Missing_Items --
25934 --------------------------
25936 procedure Report_Missing_Items
is
25937 Item_Elmt
: Elmt_Id
;
25938 Item_Id
: Entity_Id
;
25941 -- Do not perform this check in an instance because it was already
25942 -- performed successfully in the generic template.
25944 if Is_Generic_Instance
(Spec_Id
) then
25948 if Present
(Repeat_Items
) then
25949 Item_Elmt
:= First_Elmt
(Repeat_Items
);
25950 while Present
(Item_Elmt
) loop
25951 Item_Id
:= Node
(Item_Elmt
);
25952 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
25953 Next_Elmt
(Item_Elmt
);
25957 end Report_Missing_Items
;
25961 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25962 Errors
: constant Nat
:= Serious_Errors_Detected
;
25964 No_Constit
: Boolean;
25966 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25969 -- Do not analyze the pragma multiple times
25971 if Is_Analyzed_Pragma
(N
) then
25975 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25977 -- Use the anonymous object as the proper spec when Refined_Global
25978 -- applies to the body of a single task type. The object carries the
25979 -- proper Chars as well as all non-refined versions of pragmas.
25981 if Is_Single_Concurrent_Type
(Spec_Id
) then
25982 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25985 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25986 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
25988 -- The subprogram declaration lacks pragma Global. This renders
25989 -- Refined_Global useless as there is nothing to refine.
25991 if No
(Global
) then
25993 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25994 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
25998 -- Extract all relevant items from the corresponding Global pragma
26000 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26002 -- Package and subprogram bodies are instantiated individually in
26003 -- a separate compiler pass. Due to this mode of instantiation, the
26004 -- refinement of a state may no longer be visible when a subprogram
26005 -- body contract is instantiated. Since the generic template is legal,
26006 -- do not perform this check in the instance to circumvent this oddity.
26008 if Is_Generic_Instance
(Spec_Id
) then
26011 -- Non-instance case
26014 -- The corresponding Global pragma must mention at least one
26015 -- state with a visible refinement at the point Refined_Global
26016 -- is processed. States with null refinements need Refined_Global
26017 -- pragma (SPARK RM 7.2.4(2)).
26019 if not Has_In_State
26020 and then not Has_In_Out_State
26021 and then not Has_Out_State
26022 and then not Has_Proof_In_State
26023 and then not Has_Null_State
26026 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26027 & "depend on abstract state with visible refinement"),
26031 -- The global refinement of inputs and outputs cannot be null when
26032 -- the corresponding Global pragma contains at least one item except
26033 -- in the case where we have states with null refinements.
26035 elsif Nkind
(Items
) = N_Null
26037 (Present
(In_Items
)
26038 or else Present
(In_Out_Items
)
26039 or else Present
(Out_Items
)
26040 or else Present
(Proof_In_Items
))
26041 and then not Has_Null_State
26044 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
26045 & "global items"), N
, Spec_Id
);
26050 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26051 -- This ensures that the categorization of all refined global items is
26052 -- consistent with their role.
26054 Analyze_Global_In_Decl_Part
(N
);
26056 -- Perform all refinement checks with respect to completeness and mode
26059 if Serious_Errors_Detected
= Errors
then
26060 Check_Refined_Global_List
(Items
);
26063 -- Store the information that no constituent is used in the global
26064 -- refinement, prior to calling checking procedures which remove items
26065 -- from the list of constituents.
26069 and then No
(In_Out_Constits
)
26070 and then No
(Out_Constits
)
26071 and then No
(Proof_In_Constits
);
26073 -- For Input states with visible refinement, at least one constituent
26074 -- must be used as an Input in the global refinement.
26076 if Serious_Errors_Detected
= Errors
then
26077 Check_Input_States
;
26080 -- Verify all possible completion variants for In_Out states with
26081 -- visible refinement.
26083 if Serious_Errors_Detected
= Errors
then
26084 Check_In_Out_States
;
26087 -- For Output states with visible refinement, all constituents must be
26088 -- used as Outputs in the global refinement.
26090 if Serious_Errors_Detected
= Errors
then
26091 Check_Output_States
;
26094 -- For Proof_In states with visible refinement, at least one constituent
26095 -- must be used as Proof_In in the global refinement.
26097 if Serious_Errors_Detected
= Errors
then
26098 Check_Proof_In_States
;
26101 -- Emit errors for all constituents that belong to other states with
26102 -- visible refinement that do not appear in Global.
26104 if Serious_Errors_Detected
= Errors
then
26105 Report_Extra_Constituents
;
26108 -- Emit errors for all items in Global that are not repeated in the
26109 -- global refinement and for which there is no full visible refinement
26110 -- and, in the case of states with partial visible refinement, no
26111 -- constituent is mentioned in the global refinement.
26113 if Serious_Errors_Detected
= Errors
then
26114 Report_Missing_Items
;
26117 -- Emit an error if no constituent is used in the global refinement
26118 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
26119 -- one may be issued by the checking procedures. Do not perform this
26120 -- check in an instance because it was already performed successfully
26121 -- in the generic template.
26123 if Serious_Errors_Detected
= Errors
26124 and then not Is_Generic_Instance
(Spec_Id
)
26125 and then not Has_Null_State
26126 and then No_Constit
26128 SPARK_Msg_N
("missing refinement", N
);
26132 Set_Is_Analyzed_Pragma
(N
);
26133 end Analyze_Refined_Global_In_Decl_Part
;
26135 ----------------------------------------
26136 -- Analyze_Refined_State_In_Decl_Part --
26137 ----------------------------------------
26139 procedure Analyze_Refined_State_In_Decl_Part
26141 Freeze_Id
: Entity_Id
:= Empty
)
26143 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
26144 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26145 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
26147 Available_States
: Elist_Id
:= No_Elist
;
26148 -- A list of all abstract states defined in the package declaration that
26149 -- are available for refinement. The list is used to report unrefined
26152 Body_States
: Elist_Id
:= No_Elist
;
26153 -- A list of all hidden states that appear in the body of the related
26154 -- package. The list is used to report unused hidden states.
26156 Constituents_Seen
: Elist_Id
:= No_Elist
;
26157 -- A list that contains all constituents processed so far. The list is
26158 -- used to detect multiple uses of the same constituent.
26160 Freeze_Posted
: Boolean := False;
26161 -- A flag that controls the output of a freezing-related error (see use
26164 Refined_States_Seen
: Elist_Id
:= No_Elist
;
26165 -- A list that contains all refined states processed so far. The list is
26166 -- used to detect duplicate refinements.
26168 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
26169 -- Perform full analysis of a single refinement clause
26171 procedure Report_Unrefined_States
(States
: Elist_Id
);
26172 -- Emit errors for all unrefined abstract states found in list States
26174 -------------------------------
26175 -- Analyze_Refinement_Clause --
26176 -------------------------------
26178 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
26179 AR_Constit
: Entity_Id
:= Empty
;
26180 AW_Constit
: Entity_Id
:= Empty
;
26181 ER_Constit
: Entity_Id
:= Empty
;
26182 EW_Constit
: Entity_Id
:= Empty
;
26183 -- The entities of external constituents that contain one of the
26184 -- following enabled properties: Async_Readers, Async_Writers,
26185 -- Effective_Reads and Effective_Writes.
26187 External_Constit_Seen
: Boolean := False;
26188 -- Flag used to mark when at least one external constituent is part
26189 -- of the state refinement.
26191 Non_Null_Seen
: Boolean := False;
26192 Null_Seen
: Boolean := False;
26193 -- Flags used to detect multiple uses of null in a single clause or a
26194 -- mixture of null and non-null constituents.
26196 Part_Of_Constits
: Elist_Id
:= No_Elist
;
26197 -- A list of all candidate constituents subject to indicator Part_Of
26198 -- where the encapsulating state is the current state.
26201 State_Id
: Entity_Id
;
26202 -- The current state being refined
26204 procedure Analyze_Constituent
(Constit
: Node_Id
);
26205 -- Perform full analysis of a single constituent
26207 procedure Check_External_Property
26208 (Prop_Nam
: Name_Id
;
26210 Constit
: Entity_Id
);
26211 -- Determine whether a property denoted by name Prop_Nam is present
26212 -- in the refined state. Emit an error if this is not the case. Flag
26213 -- Enabled should be set when the property applies to the refined
26214 -- state. Constit denotes the constituent (if any) which introduces
26215 -- the property in the refinement.
26217 procedure Match_State
;
26218 -- Determine whether the state being refined appears in list
26219 -- Available_States. Emit an error when attempting to re-refine the
26220 -- state or when the state is not defined in the package declaration,
26221 -- otherwise remove the state from Available_States.
26223 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
26224 -- Emit errors for all unused Part_Of constituents in list Constits
26226 -------------------------
26227 -- Analyze_Constituent --
26228 -------------------------
26230 procedure Analyze_Constituent
(Constit
: Node_Id
) is
26231 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
26232 -- Determine whether constituent Constit denoted by its entity
26233 -- Constit_Id appears in Body_States. Emit an error when the
26234 -- constituent is not a valid hidden state of the related package
26235 -- or when it is used more than once. Otherwise remove the
26236 -- constituent from Body_States.
26238 -----------------------
26239 -- Match_Constituent --
26240 -----------------------
26242 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
26243 procedure Collect_Constituent
;
26244 -- Verify the legality of constituent Constit_Id and add it to
26245 -- the refinements of State_Id.
26247 -------------------------
26248 -- Collect_Constituent --
26249 -------------------------
26251 procedure Collect_Constituent
is
26252 Constits
: Elist_Id
;
26255 -- The Ghost policy in effect at the point of abstract state
26256 -- declaration and constituent must match (SPARK RM 6.9(15))
26258 Check_Ghost_Refinement
26259 (State
, State_Id
, Constit
, Constit_Id
);
26261 -- A synchronized state must be refined by a synchronized
26262 -- object or another synchronized state (SPARK RM 9.6).
26264 if Is_Synchronized_State
(State_Id
)
26265 and then not Is_Synchronized_Object
(Constit_Id
)
26266 and then not Is_Synchronized_State
(Constit_Id
)
26269 ("constituent of synchronized state & must be "
26270 & "synchronized", Constit
, State_Id
);
26273 -- Add the constituent to the list of processed items to aid
26274 -- with the detection of duplicates.
26276 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
26278 -- Collect the constituent in the list of refinement items
26279 -- and establish a relation between the refined state and
26282 Constits
:= Refinement_Constituents
(State_Id
);
26284 if No
(Constits
) then
26285 Constits
:= New_Elmt_List
;
26286 Set_Refinement_Constituents
(State_Id
, Constits
);
26289 Append_Elmt
(Constit_Id
, Constits
);
26290 Set_Encapsulating_State
(Constit_Id
, State_Id
);
26292 -- The state has at least one legal constituent, mark the
26293 -- start of the refinement region. The region ends when the
26294 -- body declarations end (see routine Analyze_Declarations).
26296 Set_Has_Visible_Refinement
(State_Id
);
26298 -- When the constituent is external, save its relevant
26299 -- property for further checks.
26301 if Async_Readers_Enabled
(Constit_Id
) then
26302 AR_Constit
:= Constit_Id
;
26303 External_Constit_Seen
:= True;
26306 if Async_Writers_Enabled
(Constit_Id
) then
26307 AW_Constit
:= Constit_Id
;
26308 External_Constit_Seen
:= True;
26311 if Effective_Reads_Enabled
(Constit_Id
) then
26312 ER_Constit
:= Constit_Id
;
26313 External_Constit_Seen
:= True;
26316 if Effective_Writes_Enabled
(Constit_Id
) then
26317 EW_Constit
:= Constit_Id
;
26318 External_Constit_Seen
:= True;
26320 end Collect_Constituent
;
26324 State_Elmt
: Elmt_Id
;
26326 -- Start of processing for Match_Constituent
26329 -- Detect a duplicate use of a constituent
26331 if Contains
(Constituents_Seen
, Constit_Id
) then
26333 ("duplicate use of constituent &", Constit
, Constit_Id
);
26337 -- The constituent is subject to a Part_Of indicator
26339 if Present
(Encapsulating_State
(Constit_Id
)) then
26340 if Encapsulating_State
(Constit_Id
) = State_Id
then
26341 Remove
(Part_Of_Constits
, Constit_Id
);
26342 Collect_Constituent
;
26344 -- The constituent is part of another state and is used
26345 -- incorrectly in the refinement of the current state.
26348 Error_Msg_Name_1
:= Chars
(State_Id
);
26350 ("& cannot act as constituent of state %",
26351 Constit
, Constit_Id
);
26353 ("\Part_Of indicator specifies encapsulator &",
26354 Constit
, Encapsulating_State
(Constit_Id
));
26357 -- The only other source of legal constituents is the body
26358 -- state space of the related package.
26361 if Present
(Body_States
) then
26362 State_Elmt
:= First_Elmt
(Body_States
);
26363 while Present
(State_Elmt
) loop
26365 -- Consume a valid constituent to signal that it has
26366 -- been encountered.
26368 if Node
(State_Elmt
) = Constit_Id
then
26369 Remove_Elmt
(Body_States
, State_Elmt
);
26370 Collect_Constituent
;
26374 Next_Elmt
(State_Elmt
);
26378 -- Constants are part of the hidden state of a package, but
26379 -- the compiler cannot determine whether they have variable
26380 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26381 -- hidden state. Accept the constant quietly even if it is
26382 -- a visible state or lacks a Part_Of indicator.
26384 if Ekind
(Constit_Id
) = E_Constant
then
26385 Collect_Constituent
;
26387 -- If we get here, then the constituent is not a hidden
26388 -- state of the related package and may not be used in a
26389 -- refinement (SPARK RM 7.2.2(9)).
26392 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26394 ("cannot use & in refinement, constituent is not a "
26395 & "hidden state of package %", Constit
, Constit_Id
);
26398 end Match_Constituent
;
26402 Constit_Id
: Entity_Id
;
26403 Constits
: Elist_Id
;
26405 -- Start of processing for Analyze_Constituent
26408 -- Detect multiple uses of null in a single refinement clause or a
26409 -- mixture of null and non-null constituents.
26411 if Nkind
(Constit
) = N_Null
then
26414 ("multiple null constituents not allowed", Constit
);
26416 elsif Non_Null_Seen
then
26418 ("cannot mix null and non-null constituents", Constit
);
26423 -- Collect the constituent in the list of refinement items
26425 Constits
:= Refinement_Constituents
(State_Id
);
26427 if No
(Constits
) then
26428 Constits
:= New_Elmt_List
;
26429 Set_Refinement_Constituents
(State_Id
, Constits
);
26432 Append_Elmt
(Constit
, Constits
);
26434 -- The state has at least one legal constituent, mark the
26435 -- start of the refinement region. The region ends when the
26436 -- body declarations end (see Analyze_Declarations).
26438 Set_Has_Visible_Refinement
(State_Id
);
26441 -- Non-null constituents
26444 Non_Null_Seen
:= True;
26448 ("cannot mix null and non-null constituents", Constit
);
26452 Resolve_State
(Constit
);
26454 -- Ensure that the constituent denotes a valid state or a
26455 -- whole object (SPARK RM 7.2.2(5)).
26457 if Is_Entity_Name
(Constit
) then
26458 Constit_Id
:= Entity_Of
(Constit
);
26460 -- When a constituent is declared after a subprogram body
26461 -- that caused "freezing" of the related contract where
26462 -- pragma Refined_State resides, the constituent appears
26463 -- undefined and carries Any_Id as its entity.
26465 -- package body Pack
26466 -- with Refined_State => (State => Constit)
26469 -- with Refined_Global => (Input => Constit)
26477 if Constit_Id
= Any_Id
then
26478 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
26480 -- Emit a specialized info message when the contract of
26481 -- the related package body was "frozen" by another body.
26482 -- Note that it is not possible to precisely identify why
26483 -- the constituent is undefined because it is not visible
26484 -- when pragma Refined_State is analyzed. This message is
26485 -- a reasonable approximation.
26487 if Present
(Freeze_Id
) and then not Freeze_Posted
then
26488 Freeze_Posted
:= True;
26490 Error_Msg_Name_1
:= Chars
(Body_Id
);
26491 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
26493 ("body & declared # freezes the contract of %",
26496 ("\all constituents must be declared before body #",
26499 -- A misplaced constituent is a critical error because
26500 -- pragma Refined_Depends or Refined_Global depends on
26501 -- the proper link between a state and a constituent.
26502 -- Stop the compilation, as this leads to a multitude
26503 -- of misleading cascaded errors.
26505 raise Program_Error
;
26508 -- The constituent is a valid state or object
26510 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
26514 Match_Constituent
(Constit_Id
);
26516 -- The variable may eventually become a constituent of a
26517 -- single protected/task type. Record the reference now
26518 -- and verify its legality when analyzing the contract of
26519 -- the variable (SPARK RM 9.3).
26521 if Ekind
(Constit_Id
) = E_Variable
then
26522 Record_Possible_Part_Of_Reference
26523 (Var_Id
=> Constit_Id
,
26527 -- Otherwise the constituent is illegal
26531 ("constituent & must denote object or state",
26532 Constit
, Constit_Id
);
26535 -- The constituent is illegal
26538 SPARK_Msg_N
("malformed constituent", Constit
);
26541 end Analyze_Constituent
;
26543 -----------------------------
26544 -- Check_External_Property --
26545 -----------------------------
26547 procedure Check_External_Property
26548 (Prop_Nam
: Name_Id
;
26550 Constit
: Entity_Id
)
26553 -- The property is missing in the declaration of the state, but
26554 -- a constituent is introducing it in the state refinement
26555 -- (SPARK RM 7.2.8(2)).
26557 if not Enabled
and then Present
(Constit
) then
26558 Error_Msg_Name_1
:= Prop_Nam
;
26559 Error_Msg_Name_2
:= Chars
(State_Id
);
26561 ("constituent & introduces external property % in refinement "
26562 & "of state %", State
, Constit
);
26564 Error_Msg_Sloc
:= Sloc
(State_Id
);
26566 ("\property is missing in abstract state declaration #",
26569 end Check_External_Property
;
26575 procedure Match_State
is
26576 State_Elmt
: Elmt_Id
;
26579 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
26581 if Contains
(Refined_States_Seen
, State_Id
) then
26583 ("duplicate refinement of state &", State
, State_Id
);
26587 -- Inspect the abstract states defined in the package declaration
26588 -- looking for a match.
26590 State_Elmt
:= First_Elmt
(Available_States
);
26591 while Present
(State_Elmt
) loop
26593 -- A valid abstract state is being refined in the body. Add
26594 -- the state to the list of processed refined states to aid
26595 -- with the detection of duplicate refinements. Remove the
26596 -- state from Available_States to signal that it has already
26599 if Node
(State_Elmt
) = State_Id
then
26600 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
26601 Remove_Elmt
(Available_States
, State_Elmt
);
26605 Next_Elmt
(State_Elmt
);
26608 -- If we get here, we are refining a state that is not defined in
26609 -- the package declaration.
26611 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26613 ("cannot refine state, & is not defined in package %",
26617 --------------------------------
26618 -- Report_Unused_Constituents --
26619 --------------------------------
26621 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
26622 Constit_Elmt
: Elmt_Id
;
26623 Constit_Id
: Entity_Id
;
26624 Posted
: Boolean := False;
26627 if Present
(Constits
) then
26628 Constit_Elmt
:= First_Elmt
(Constits
);
26629 while Present
(Constit_Elmt
) loop
26630 Constit_Id
:= Node
(Constit_Elmt
);
26632 -- Generate an error message of the form:
26634 -- state ... has unused Part_Of constituents
26635 -- abstract state ... defined at ...
26636 -- constant ... defined at ...
26637 -- variable ... defined at ...
26642 ("state & has unused Part_Of constituents",
26646 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
26648 if Ekind
(Constit_Id
) = E_Abstract_State
then
26650 ("\abstract state & defined #", State
, Constit_Id
);
26652 elsif Ekind
(Constit_Id
) = E_Constant
then
26654 ("\constant & defined #", State
, Constit_Id
);
26657 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
26658 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
26661 Next_Elmt
(Constit_Elmt
);
26664 end Report_Unused_Constituents
;
26666 -- Local declarations
26668 Body_Ref
: Node_Id
;
26669 Body_Ref_Elmt
: Elmt_Id
;
26671 Extra_State
: Node_Id
;
26673 -- Start of processing for Analyze_Refinement_Clause
26676 -- A refinement clause appears as a component association where the
26677 -- sole choice is the state and the expressions are the constituents.
26678 -- This is a syntax error, always report.
26680 if Nkind
(Clause
) /= N_Component_Association
then
26681 Error_Msg_N
("malformed state refinement clause", Clause
);
26685 -- Analyze the state name of a refinement clause
26687 State
:= First
(Choices
(Clause
));
26690 Resolve_State
(State
);
26692 -- Ensure that the state name denotes a valid abstract state that is
26693 -- defined in the spec of the related package.
26695 if Is_Entity_Name
(State
) then
26696 State_Id
:= Entity_Of
(State
);
26698 -- When the abstract state is undefined, it appears as Any_Id. Do
26699 -- not continue with the analysis of the clause.
26701 if State_Id
= Any_Id
then
26704 -- Catch any attempts to re-refine a state or refine a state that
26705 -- is not defined in the package declaration.
26707 elsif Ekind
(State_Id
) = E_Abstract_State
then
26711 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
26715 -- References to a state with visible refinement are illegal.
26716 -- When nested packages are involved, detecting such references is
26717 -- tricky because pragma Refined_State is analyzed later than the
26718 -- offending pragma Depends or Global. References that occur in
26719 -- such nested context are stored in a list. Emit errors for all
26720 -- references found in Body_References (SPARK RM 6.1.4(8)).
26722 if Present
(Body_References
(State_Id
)) then
26723 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
26724 while Present
(Body_Ref_Elmt
) loop
26725 Body_Ref
:= Node
(Body_Ref_Elmt
);
26727 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
26728 Error_Msg_Sloc
:= Sloc
(State
);
26729 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
26731 Next_Elmt
(Body_Ref_Elmt
);
26735 -- The state name is illegal. This is a syntax error, always report.
26738 Error_Msg_N
("malformed state name in refinement clause", State
);
26742 -- A refinement clause may only refine one state at a time
26744 Extra_State
:= Next
(State
);
26746 if Present
(Extra_State
) then
26748 ("refinement clause cannot cover multiple states", Extra_State
);
26751 -- Replicate the Part_Of constituents of the refined state because
26752 -- the algorithm will consume items.
26754 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
26756 -- Analyze all constituents of the refinement. Multiple constituents
26757 -- appear as an aggregate.
26759 Constit
:= Expression
(Clause
);
26761 if Nkind
(Constit
) = N_Aggregate
then
26762 if Present
(Component_Associations
(Constit
)) then
26764 ("constituents of refinement clause must appear in "
26765 & "positional form", Constit
);
26767 else pragma Assert
(Present
(Expressions
(Constit
)));
26768 Constit
:= First
(Expressions
(Constit
));
26769 while Present
(Constit
) loop
26770 Analyze_Constituent
(Constit
);
26775 -- Various forms of a single constituent. Note that these may include
26776 -- malformed constituents.
26779 Analyze_Constituent
(Constit
);
26782 -- Verify that external constituents do not introduce new external
26783 -- property in the state refinement (SPARK RM 7.2.8(2)).
26785 if Is_External_State
(State_Id
) then
26786 Check_External_Property
26787 (Prop_Nam
=> Name_Async_Readers
,
26788 Enabled
=> Async_Readers_Enabled
(State_Id
),
26789 Constit
=> AR_Constit
);
26791 Check_External_Property
26792 (Prop_Nam
=> Name_Async_Writers
,
26793 Enabled
=> Async_Writers_Enabled
(State_Id
),
26794 Constit
=> AW_Constit
);
26796 Check_External_Property
26797 (Prop_Nam
=> Name_Effective_Reads
,
26798 Enabled
=> Effective_Reads_Enabled
(State_Id
),
26799 Constit
=> ER_Constit
);
26801 Check_External_Property
26802 (Prop_Nam
=> Name_Effective_Writes
,
26803 Enabled
=> Effective_Writes_Enabled
(State_Id
),
26804 Constit
=> EW_Constit
);
26806 -- When a refined state is not external, it should not have external
26807 -- constituents (SPARK RM 7.2.8(1)).
26809 elsif External_Constit_Seen
then
26811 ("non-external state & cannot contain external constituents in "
26812 & "refinement", State
, State_Id
);
26815 -- Ensure that all Part_Of candidate constituents have been mentioned
26816 -- in the refinement clause.
26818 Report_Unused_Constituents
(Part_Of_Constits
);
26819 end Analyze_Refinement_Clause
;
26821 -----------------------------
26822 -- Report_Unrefined_States --
26823 -----------------------------
26825 procedure Report_Unrefined_States
(States
: Elist_Id
) is
26826 State_Elmt
: Elmt_Id
;
26829 if Present
(States
) then
26830 State_Elmt
:= First_Elmt
(States
);
26831 while Present
(State_Elmt
) loop
26833 ("abstract state & must be refined", Node
(State_Elmt
));
26835 Next_Elmt
(State_Elmt
);
26838 end Report_Unrefined_States
;
26840 -- Local declarations
26842 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
26845 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26848 -- Do not analyze the pragma multiple times
26850 if Is_Analyzed_Pragma
(N
) then
26854 -- Replicate the abstract states declared by the package because the
26855 -- matching algorithm will consume states.
26857 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
26859 -- Gather all abstract states and objects declared in the visible
26860 -- state space of the package body. These items must be utilized as
26861 -- constituents in a state refinement.
26863 Body_States
:= Collect_Body_States
(Body_Id
);
26865 -- Multiple non-null state refinements appear as an aggregate
26867 if Nkind
(Clauses
) = N_Aggregate
then
26868 if Present
(Expressions
(Clauses
)) then
26870 ("state refinements must appear as component associations",
26873 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
26874 Clause
:= First
(Component_Associations
(Clauses
));
26875 while Present
(Clause
) loop
26876 Analyze_Refinement_Clause
(Clause
);
26881 -- Various forms of a single state refinement. Note that these may
26882 -- include malformed refinements.
26885 Analyze_Refinement_Clause
(Clauses
);
26888 -- List all abstract states that were left unrefined
26890 Report_Unrefined_States
(Available_States
);
26892 Set_Is_Analyzed_Pragma
(N
);
26893 end Analyze_Refined_State_In_Decl_Part
;
26895 ------------------------------------
26896 -- Analyze_Test_Case_In_Decl_Part --
26897 ------------------------------------
26899 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
26900 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26901 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26903 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
26904 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26905 -- denoted by Arg_Nam.
26907 ------------------------------
26908 -- Preanalyze_Test_Case_Arg --
26909 ------------------------------
26911 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
26915 -- Preanalyze the original aspect argument for ASIS or for a generic
26916 -- subprogram to properly capture global references.
26918 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
26922 Arg_Nam
=> Arg_Nam
,
26923 From_Aspect
=> True);
26925 if Present
(Arg
) then
26926 Preanalyze_Assert_Expression
26927 (Expression
(Arg
), Standard_Boolean
);
26931 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
26933 if Present
(Arg
) then
26934 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
26936 end Preanalyze_Test_Case_Arg
;
26940 Restore_Scope
: Boolean := False;
26942 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26945 -- Do not analyze the pragma multiple times
26947 if Is_Analyzed_Pragma
(N
) then
26951 -- Ensure that the formal parameters are visible when analyzing all
26952 -- clauses. This falls out of the general rule of aspects pertaining
26953 -- to subprogram declarations.
26955 if not In_Open_Scopes
(Spec_Id
) then
26956 Restore_Scope
:= True;
26957 Push_Scope
(Spec_Id
);
26959 if Is_Generic_Subprogram
(Spec_Id
) then
26960 Install_Generic_Formals
(Spec_Id
);
26962 Install_Formals
(Spec_Id
);
26966 Preanalyze_Test_Case_Arg
(Name_Requires
);
26967 Preanalyze_Test_Case_Arg
(Name_Ensures
);
26969 if Restore_Scope
then
26973 -- Currently it is not possible to inline pre/postconditions on a
26974 -- subprogram subject to pragma Inline_Always.
26976 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
26978 Set_Is_Analyzed_Pragma
(N
);
26979 end Analyze_Test_Case_In_Decl_Part
;
26985 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
26990 if Present
(List
) then
26991 Elmt
:= First_Elmt
(List
);
26992 while Present
(Elmt
) loop
26993 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
26996 Id
:= Entity_Of
(Node
(Elmt
));
26999 if Id
= Item_Id
then
27010 -----------------------------------
27011 -- Build_Pragma_Check_Equivalent --
27012 -----------------------------------
27014 function Build_Pragma_Check_Equivalent
27016 Subp_Id
: Entity_Id
:= Empty
;
27017 Inher_Id
: Entity_Id
:= Empty
;
27018 Keep_Pragma_Id
: Boolean := False) return Node_Id
27020 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
27021 -- Detect whether node N references a formal parameter subject to
27022 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27023 -- to False to suppress the generation of a reference when analyzing
27026 ------------------------
27027 -- Suppress_Reference --
27028 ------------------------
27030 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
27031 Formal
: Entity_Id
;
27034 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27035 Formal
:= Entity
(N
);
27037 -- The formal parameter is subject to pragma Unreferenced. Prevent
27038 -- the generation of references by resetting the Comes_From_Source
27041 if Is_Formal
(Formal
)
27042 and then Has_Pragma_Unreferenced
(Formal
)
27044 Set_Comes_From_Source
(N
, False);
27049 end Suppress_Reference
;
27051 procedure Suppress_References
is
27052 new Traverse_Proc
(Suppress_Reference
);
27056 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
27057 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
27058 Check_Prag
: Node_Id
;
27062 -- Start of processing for Build_Pragma_Check_Equivalent
27065 -- When the pre- or postcondition is inherited, map the formals of the
27066 -- inherited subprogram to those of the current subprogram. In addition,
27067 -- map primitive operations of the parent type into the corresponding
27068 -- primitive operations of the descendant.
27070 if Present
(Inher_Id
) then
27071 pragma Assert
(Present
(Subp_Id
));
27073 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
27075 -- Use generic machinery to copy inherited pragma, as if it were an
27076 -- instantiation, resetting source locations appropriately, so that
27077 -- expressions inside the inherited pragma use chained locations.
27078 -- This is used in particular in GNATprove to locate precisely
27079 -- messages on a given inherited pragma.
27081 Set_Copied_Sloc_For_Inherited_Pragma
27082 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
27083 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27085 -- Build the inherited class-wide condition
27087 Build_Class_Wide_Expression
27088 (Check_Prag
, Subp_Id
, Inher_Id
, Adjust_Sloc
=> True);
27090 -- If not an inherited condition simply copy the original pragma
27093 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27096 -- Mark the pragma as being internally generated and reset the Analyzed
27099 Set_Analyzed
(Check_Prag
, False);
27100 Set_Comes_From_Source
(Check_Prag
, False);
27102 -- The tree of the original pragma may contain references to the
27103 -- formal parameters of the related subprogram. At the same time
27104 -- the corresponding body may mark the formals as unreferenced:
27106 -- procedure Proc (Formal : ...)
27107 -- with Pre => Formal ...;
27109 -- procedure Proc (Formal : ...) is
27110 -- pragma Unreferenced (Formal);
27113 -- This creates problems because all pragma Check equivalents are
27114 -- analyzed at the end of the body declarations. Since all source
27115 -- references have already been accounted for, reset any references
27116 -- to such formals in the generated pragma Check equivalent.
27118 Suppress_References
(Check_Prag
);
27120 if Present
(Corresponding_Aspect
(Prag
)) then
27121 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
27126 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
27127 -- the copied pragma in the newly created pragma, convert the copy into
27128 -- pragma Check by correcting the name and adding a check_kind argument.
27130 if not Keep_Pragma_Id
then
27131 Set_Class_Present
(Check_Prag
, False);
27133 Set_Pragma_Identifier
27134 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
27136 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
27137 Make_Pragma_Argument_Association
(Loc
,
27138 Expression
=> Make_Identifier
(Loc
, Nam
)));
27141 -- Update the error message when the pragma is inherited
27143 if Present
(Inher_Id
) then
27144 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
27146 if Chars
(Msg_Arg
) = Name_Message
then
27147 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
27149 -- Insert "inherited" to improve the error message
27151 if Name_Buffer
(1 .. 8) = "failed p" then
27152 Insert_Str_In_Name_Buffer
("inherited ", 8);
27153 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
27159 end Build_Pragma_Check_Equivalent
;
27161 -----------------------------
27162 -- Check_Applicable_Policy --
27163 -----------------------------
27165 procedure Check_Applicable_Policy
(N
: Node_Id
) is
27169 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
27172 -- No effect if not valid assertion kind name
27174 if not Is_Valid_Assertion_Kind
(Ename
) then
27178 -- Loop through entries in check policy list
27180 PP
:= Opt
.Check_Policy_List
;
27181 while Present
(PP
) loop
27183 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27184 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27188 or else Pnm
= Name_Assertion
27189 or else (Pnm
= Name_Statement_Assertions
27190 and then Nam_In
(Ename
, Name_Assert
,
27191 Name_Assert_And_Cut
,
27193 Name_Loop_Invariant
,
27194 Name_Loop_Variant
))
27196 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
27202 Set_Is_Ignored
(N
, True);
27203 Set_Is_Checked
(N
, False);
27208 Set_Is_Checked
(N
, True);
27209 Set_Is_Ignored
(N
, False);
27211 when Name_Disable
=>
27212 Set_Is_Ignored
(N
, True);
27213 Set_Is_Checked
(N
, False);
27214 Set_Is_Disabled
(N
, True);
27216 -- That should be exhaustive, the null here is a defence
27217 -- against a malformed tree from previous errors.
27226 PP
:= Next_Pragma
(PP
);
27230 -- If there are no specific entries that matched, then we let the
27231 -- setting of assertions govern. Note that this provides the needed
27232 -- compatibility with the RM for the cases of assertion, invariant,
27233 -- precondition, predicate, and postcondition.
27235 if Assertions_Enabled
then
27236 Set_Is_Checked
(N
, True);
27237 Set_Is_Ignored
(N
, False);
27239 Set_Is_Checked
(N
, False);
27240 Set_Is_Ignored
(N
, True);
27242 end Check_Applicable_Policy
;
27244 -------------------------------
27245 -- Check_External_Properties --
27246 -------------------------------
27248 procedure Check_External_Properties
27256 -- All properties enabled
27258 if AR
and AW
and ER
and EW
then
27261 -- Async_Readers + Effective_Writes
27262 -- Async_Readers + Async_Writers + Effective_Writes
27264 elsif AR
and EW
and not ER
then
27267 -- Async_Writers + Effective_Reads
27268 -- Async_Readers + Async_Writers + Effective_Reads
27270 elsif AW
and ER
and not EW
then
27273 -- Async_Readers + Async_Writers
27275 elsif AR
and AW
and not ER
and not EW
then
27280 elsif AR
and not AW
and not ER
and not EW
then
27285 elsif AW
and not AR
and not ER
and not EW
then
27290 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27293 end Check_External_Properties
;
27299 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
27303 -- Loop through entries in check policy list
27305 PP
:= Opt
.Check_Policy_List
;
27306 while Present
(PP
) loop
27308 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27309 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27313 or else (Pnm
= Name_Assertion
27314 and then Is_Valid_Assertion_Kind
(Nam
))
27315 or else (Pnm
= Name_Statement_Assertions
27316 and then Nam_In
(Nam
, Name_Assert
,
27317 Name_Assert_And_Cut
,
27319 Name_Loop_Invariant
,
27320 Name_Loop_Variant
))
27322 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
27331 return Name_Ignore
;
27333 when Name_Disable
=>
27334 return Name_Disable
;
27337 raise Program_Error
;
27341 PP
:= Next_Pragma
(PP
);
27346 -- If there are no specific entries that matched, then we let the
27347 -- setting of assertions govern. Note that this provides the needed
27348 -- compatibility with the RM for the cases of assertion, invariant,
27349 -- precondition, predicate, and postcondition.
27351 if Assertions_Enabled
then
27354 return Name_Ignore
;
27358 ---------------------------
27359 -- Check_Missing_Part_Of --
27360 ---------------------------
27362 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
27363 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
27364 -- Determine whether a package denoted by Pack_Id declares at least one
27367 -----------------------
27368 -- Has_Visible_State --
27369 -----------------------
27371 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
27372 Item_Id
: Entity_Id
;
27375 -- Traverse the entity chain of the package trying to find at least
27376 -- one visible abstract state, variable or a package [instantiation]
27377 -- that declares a visible state.
27379 Item_Id
:= First_Entity
(Pack_Id
);
27380 while Present
(Item_Id
)
27381 and then not In_Private_Part
(Item_Id
)
27383 -- Do not consider internally generated items
27385 if not Comes_From_Source
(Item_Id
) then
27388 -- A visible state has been found
27390 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
27393 -- Recursively peek into nested packages and instantiations
27395 elsif Ekind
(Item_Id
) = E_Package
27396 and then Has_Visible_State
(Item_Id
)
27401 Next_Entity
(Item_Id
);
27405 end Has_Visible_State
;
27409 Pack_Id
: Entity_Id
;
27410 Placement
: State_Space_Kind
;
27412 -- Start of processing for Check_Missing_Part_Of
27415 -- Do not consider abstract states, variables or package instantiations
27416 -- coming from an instance as those always inherit the Part_Of indicator
27417 -- of the instance itself.
27419 if In_Instance
then
27422 -- Do not consider internally generated entities as these can never
27423 -- have a Part_Of indicator.
27425 elsif not Comes_From_Source
(Item_Id
) then
27428 -- Perform these checks only when SPARK_Mode is enabled as they will
27429 -- interfere with standard Ada rules and produce false positives.
27431 elsif SPARK_Mode
/= On
then
27434 -- Do not consider constants, because the compiler cannot accurately
27435 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27436 -- act as a hidden state of a package.
27438 elsif Ekind
(Item_Id
) = E_Constant
then
27442 -- Find where the abstract state, variable or package instantiation
27443 -- lives with respect to the state space.
27445 Find_Placement_In_State_Space
27446 (Item_Id
=> Item_Id
,
27447 Placement
=> Placement
,
27448 Pack_Id
=> Pack_Id
);
27450 -- Items that appear in a non-package construct (subprogram, block, etc)
27451 -- do not require a Part_Of indicator because they can never act as a
27454 if Placement
= Not_In_Package
then
27457 -- An item declared in the body state space of a package always act as a
27458 -- constituent and does not need explicit Part_Of indicator.
27460 elsif Placement
= Body_State_Space
then
27463 -- In general an item declared in the visible state space of a package
27464 -- does not require a Part_Of indicator. The only exception is when the
27465 -- related package is a private child unit in which case Part_Of must
27466 -- denote a state in the parent unit or in one of its descendants.
27468 elsif Placement
= Visible_State_Space
then
27469 if Is_Child_Unit
(Pack_Id
)
27470 and then Is_Private_Descendant
(Pack_Id
)
27472 -- A package instantiation does not need a Part_Of indicator when
27473 -- the related generic template has no visible state.
27475 if Ekind
(Item_Id
) = E_Package
27476 and then Is_Generic_Instance
(Item_Id
)
27477 and then not Has_Visible_State
(Item_Id
)
27481 -- All other cases require Part_Of
27485 ("indicator Part_Of is required in this context "
27486 & "(SPARK RM 7.2.6(3))", Item_Id
);
27487 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27489 ("\& is declared in the visible part of private child "
27490 & "unit %", Item_Id
);
27494 -- When the item appears in the private state space of a packge, it must
27495 -- be a part of some state declared by the said package.
27497 else pragma Assert
(Placement
= Private_State_Space
);
27499 -- The related package does not declare a state, the item cannot act
27500 -- as a Part_Of constituent.
27502 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
27505 -- A package instantiation does not need a Part_Of indicator when the
27506 -- related generic template has no visible state.
27508 elsif Ekind
(Pack_Id
) = E_Package
27509 and then Is_Generic_Instance
(Pack_Id
)
27510 and then not Has_Visible_State
(Pack_Id
)
27514 -- All other cases require Part_Of
27518 ("indicator Part_Of is required in this context "
27519 & "(SPARK RM 7.2.6(2))", Item_Id
);
27520 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27522 ("\& is declared in the private part of package %", Item_Id
);
27525 end Check_Missing_Part_Of
;
27527 ---------------------------------------------------
27528 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27529 ---------------------------------------------------
27531 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27533 Spec_Id
: Entity_Id
)
27536 if Warn_On_Redundant_Constructs
27537 and then Has_Pragma_Inline_Always
(Spec_Id
)
27539 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27541 if From_Aspect_Specification
(Prag
) then
27543 ("aspect % not enforced on inlined subprogram &?r?",
27544 Corresponding_Aspect
(Prag
), Spec_Id
);
27547 ("pragma % not enforced on inlined subprogram &?r?",
27551 end Check_Postcondition_Use_In_Inlined_Subprogram
;
27553 -------------------------------------
27554 -- Check_State_And_Constituent_Use --
27555 -------------------------------------
27557 procedure Check_State_And_Constituent_Use
27558 (States
: Elist_Id
;
27559 Constits
: Elist_Id
;
27562 Constit_Elmt
: Elmt_Id
;
27563 Constit_Id
: Entity_Id
;
27564 State_Id
: Entity_Id
;
27567 -- Nothing to do if there are no states or constituents
27569 if No
(States
) or else No
(Constits
) then
27573 -- Inspect the list of constituents and try to determine whether its
27574 -- encapsulating state is in list States.
27576 Constit_Elmt
:= First_Elmt
(Constits
);
27577 while Present
(Constit_Elmt
) loop
27578 Constit_Id
:= Node
(Constit_Elmt
);
27580 -- Determine whether the constituent is part of an encapsulating
27581 -- state that appears in the same context and if this is the case,
27582 -- emit an error (SPARK RM 7.2.6(7)).
27584 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
27586 if Present
(State_Id
) then
27587 Error_Msg_Name_1
:= Chars
(Constit_Id
);
27589 ("cannot mention state & and its constituent % in the same "
27590 & "context", Context
, State_Id
);
27594 Next_Elmt
(Constit_Elmt
);
27596 end Check_State_And_Constituent_Use
;
27598 ---------------------------------------------
27599 -- Collect_Inherited_Class_Wide_Conditions --
27600 ---------------------------------------------
27602 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
27603 Parent_Subp
: constant Entity_Id
:= Overridden_Operation
(Subp
);
27604 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
27605 In_Spec_Expr
: Boolean;
27606 Installed
: Boolean;
27608 New_Prag
: Node_Id
;
27611 Installed
:= False;
27613 -- Iterate over the contract of the overridden subprogram to find all
27614 -- inherited class-wide pre- and postconditions.
27616 if Present
(Prags
) then
27617 Prag
:= Pre_Post_Conditions
(Prags
);
27619 while Present
(Prag
) loop
27620 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
27621 Name_Precondition
, Name_Postcondition
)
27622 and then Class_Present
(Prag
)
27624 -- The generated pragma must be analyzed in the context of
27625 -- the subprogram, to make its formals visible. In addition,
27626 -- we must inhibit freezing and full analysis because the
27627 -- controlling type of the subprogram is not frozen yet, and
27628 -- may have further primitives.
27630 if not Installed
then
27633 Install_Formals
(Subp
);
27634 In_Spec_Expr
:= In_Spec_Expression
;
27635 In_Spec_Expression
:= True;
27639 Build_Pragma_Check_Equivalent
27640 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
27642 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
27643 Preanalyze
(New_Prag
);
27645 -- Prevent further analysis in subsequent processing of the
27646 -- current list of declarations
27648 Set_Analyzed
(New_Prag
);
27651 Prag
:= Next_Pragma
(Prag
);
27655 In_Spec_Expression
:= In_Spec_Expr
;
27659 end Collect_Inherited_Class_Wide_Conditions
;
27661 ---------------------------------------
27662 -- Collect_Subprogram_Inputs_Outputs --
27663 ---------------------------------------
27665 procedure Collect_Subprogram_Inputs_Outputs
27666 (Subp_Id
: Entity_Id
;
27667 Synthesize
: Boolean := False;
27668 Subp_Inputs
: in out Elist_Id
;
27669 Subp_Outputs
: in out Elist_Id
;
27670 Global_Seen
: out Boolean)
27672 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
27673 -- Collect all relevant items from a dependency clause
27675 procedure Collect_Global_List
27677 Mode
: Name_Id
:= Name_Input
);
27678 -- Collect all relevant items from a global list
27680 -------------------------------
27681 -- Collect_Dependency_Clause --
27682 -------------------------------
27684 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
27685 procedure Collect_Dependency_Item
27687 Is_Input
: Boolean);
27688 -- Add an item to the proper subprogram input or output collection
27690 -----------------------------
27691 -- Collect_Dependency_Item --
27692 -----------------------------
27694 procedure Collect_Dependency_Item
27696 Is_Input
: Boolean)
27701 -- Nothing to collect when the item is null
27703 if Nkind
(Item
) = N_Null
then
27706 -- Ditto for attribute 'Result
27708 elsif Is_Attribute_Result
(Item
) then
27711 -- Multiple items appear as an aggregate
27713 elsif Nkind
(Item
) = N_Aggregate
then
27714 Extra
:= First
(Expressions
(Item
));
27715 while Present
(Extra
) loop
27716 Collect_Dependency_Item
(Extra
, Is_Input
);
27720 -- Otherwise this is a solitary item
27724 Append_New_Elmt
(Item
, Subp_Inputs
);
27726 Append_New_Elmt
(Item
, Subp_Outputs
);
27729 end Collect_Dependency_Item
;
27731 -- Start of processing for Collect_Dependency_Clause
27734 if Nkind
(Clause
) = N_Null
then
27737 -- A dependency cause appears as component association
27739 elsif Nkind
(Clause
) = N_Component_Association
then
27740 Collect_Dependency_Item
27741 (Item
=> Expression
(Clause
),
27744 Collect_Dependency_Item
27745 (Item
=> First
(Choices
(Clause
)),
27746 Is_Input
=> False);
27748 -- To accomodate partial decoration of disabled SPARK features, this
27749 -- routine may be called with illegal input. If this is the case, do
27750 -- not raise Program_Error.
27755 end Collect_Dependency_Clause
;
27757 -------------------------
27758 -- Collect_Global_List --
27759 -------------------------
27761 procedure Collect_Global_List
27763 Mode
: Name_Id
:= Name_Input
)
27765 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
27766 -- Add an item to the proper subprogram input or output collection
27768 -------------------------
27769 -- Collect_Global_Item --
27770 -------------------------
27772 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
27774 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
27775 Append_New_Elmt
(Item
, Subp_Inputs
);
27778 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
27779 Append_New_Elmt
(Item
, Subp_Outputs
);
27781 end Collect_Global_Item
;
27788 -- Start of processing for Collect_Global_List
27791 if Nkind
(List
) = N_Null
then
27794 -- Single global item declaration
27796 elsif Nkind_In
(List
, N_Expanded_Name
,
27798 N_Selected_Component
)
27800 Collect_Global_Item
(List
, Mode
);
27802 -- Simple global list or moded global list declaration
27804 elsif Nkind
(List
) = N_Aggregate
then
27805 if Present
(Expressions
(List
)) then
27806 Item
:= First
(Expressions
(List
));
27807 while Present
(Item
) loop
27808 Collect_Global_Item
(Item
, Mode
);
27813 Assoc
:= First
(Component_Associations
(List
));
27814 while Present
(Assoc
) loop
27815 Collect_Global_List
27816 (List
=> Expression
(Assoc
),
27817 Mode
=> Chars
(First
(Choices
(Assoc
))));
27822 -- To accomodate partial decoration of disabled SPARK features, this
27823 -- routine may be called with illegal input. If this is the case, do
27824 -- not raise Program_Error.
27829 end Collect_Global_List
;
27836 Formal
: Entity_Id
;
27838 Spec_Id
: Entity_Id
;
27839 Subp_Decl
: Node_Id
;
27842 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27845 Global_Seen
:= False;
27847 -- Process all formal parameters of entries, [generic] subprograms, and
27850 if Ekind_In
(Subp_Id
, E_Entry
,
27853 E_Generic_Function
,
27854 E_Generic_Procedure
,
27858 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
27859 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27861 -- Process all [generic] formal parameters
27863 Formal
:= First_Entity
(Spec_Id
);
27864 while Present
(Formal
) loop
27865 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
27866 E_In_Out_Parameter
,
27869 Append_New_Elmt
(Formal
, Subp_Inputs
);
27872 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
27873 E_In_Out_Parameter
,
27876 Append_New_Elmt
(Formal
, Subp_Outputs
);
27878 -- Out parameters can act as inputs when the related type is
27879 -- tagged, unconstrained array, unconstrained record, or record
27880 -- with unconstrained components.
27882 if Ekind
(Formal
) = E_Out_Parameter
27883 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
27885 Append_New_Elmt
(Formal
, Subp_Inputs
);
27889 Next_Entity
(Formal
);
27892 -- Otherwise the input denotes a task type, a task body, or the
27893 -- anonymous object created for a single task type.
27895 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
27896 or else Is_Single_Task_Object
(Subp_Id
)
27898 Subp_Decl
:= Declaration_Node
(Subp_Id
);
27899 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27902 -- When processing an entry, subprogram or task body, look for pragmas
27903 -- Refined_Depends and Refined_Global as they specify the inputs and
27906 if Is_Entry_Body
(Subp_Id
)
27907 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
27909 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
27910 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
27912 -- Subprogram declaration or stand alone body case, look for pragmas
27913 -- Depends and Global
27916 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
27917 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
27920 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27921 -- because it provides finer granularity of inputs and outputs.
27923 if Present
(Global
) then
27924 Global_Seen
:= True;
27925 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
27927 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27928 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27929 -- the inputs and outputs from [Refined_]Depends.
27931 elsif Synthesize
and then Present
(Depends
) then
27932 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
27934 -- Multiple dependency clauses appear as an aggregate
27936 if Nkind
(Clauses
) = N_Aggregate
then
27937 Clause
:= First
(Component_Associations
(Clauses
));
27938 while Present
(Clause
) loop
27939 Collect_Dependency_Clause
(Clause
);
27943 -- Otherwise this is a single dependency clause
27946 Collect_Dependency_Clause
(Clauses
);
27950 -- The current instance of a protected type acts as a formal parameter
27951 -- of mode IN for functions and IN OUT for entries and procedures
27952 -- (SPARK RM 6.1.4).
27954 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
27955 Typ
:= Scope
(Spec_Id
);
27957 -- Use the anonymous object when the type is single protected
27959 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27960 Typ
:= Anonymous_Object
(Typ
);
27963 Append_New_Elmt
(Typ
, Subp_Inputs
);
27965 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
27966 Append_New_Elmt
(Typ
, Subp_Outputs
);
27969 -- The current instance of a task type acts as a formal parameter of
27970 -- mode IN OUT (SPARK RM 6.1.4).
27972 elsif Ekind
(Spec_Id
) = E_Task_Type
then
27975 -- Use the anonymous object when the type is single task
27977 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27978 Typ
:= Anonymous_Object
(Typ
);
27981 Append_New_Elmt
(Typ
, Subp_Inputs
);
27982 Append_New_Elmt
(Typ
, Subp_Outputs
);
27984 elsif Is_Single_Task_Object
(Spec_Id
) then
27985 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
27986 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
27988 end Collect_Subprogram_Inputs_Outputs
;
27990 ---------------------------
27991 -- Contract_Freeze_Error --
27992 ---------------------------
27994 procedure Contract_Freeze_Error
27995 (Contract_Id
: Entity_Id
;
27996 Freeze_Id
: Entity_Id
)
27999 Error_Msg_Name_1
:= Chars
(Contract_Id
);
28000 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28003 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
28005 ("\all contractual items must be declared before body #", Contract_Id
);
28006 end Contract_Freeze_Error
;
28008 ---------------------------------
28009 -- Delay_Config_Pragma_Analyze --
28010 ---------------------------------
28012 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
28014 return Nam_In
(Pragma_Name_Unmapped
(N
),
28015 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
28016 end Delay_Config_Pragma_Analyze
;
28018 -----------------------
28019 -- Duplication_Error --
28020 -----------------------
28022 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
28023 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
28024 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
28027 Error_Msg_Sloc
:= Sloc
(Prev
);
28028 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28030 -- Emit a precise message to distinguish between source pragmas and
28031 -- pragmas generated from aspects. The ordering of the two pragmas is
28035 -- Prag -- duplicate
28037 -- No error is emitted when both pragmas come from aspects because this
28038 -- is already detected by the general aspect analysis mechanism.
28040 if Prag_From_Asp
and Prev_From_Asp
then
28042 elsif Prag_From_Asp
then
28043 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
28044 elsif Prev_From_Asp
then
28045 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
28047 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
28049 end Duplication_Error
;
28051 ------------------------------
28052 -- Find_Encapsulating_State --
28053 ------------------------------
28055 function Find_Encapsulating_State
28056 (States
: Elist_Id
;
28057 Constit_Id
: Entity_Id
) return Entity_Id
28059 State_Id
: Entity_Id
;
28062 -- Since a constituent may be part of a larger constituent set, climb
28063 -- the encapsulating state chain looking for a state that appears in
28066 State_Id
:= Encapsulating_State
(Constit_Id
);
28067 while Present
(State_Id
) loop
28068 if Contains
(States
, State_Id
) then
28072 State_Id
:= Encapsulating_State
(State_Id
);
28076 end Find_Encapsulating_State
;
28078 --------------------------
28079 -- Find_Related_Context --
28080 --------------------------
28082 function Find_Related_Context
28084 Do_Checks
: Boolean := False) return Node_Id
28089 Stmt
:= Prev
(Prag
);
28090 while Present
(Stmt
) loop
28092 -- Skip prior pragmas, but check for duplicates
28094 if Nkind
(Stmt
) = N_Pragma
then
28096 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
28103 -- Skip internally generated code
28105 elsif not Comes_From_Source
(Stmt
) then
28107 -- The anonymous object created for a single concurrent type is a
28108 -- suitable context.
28110 if Nkind
(Stmt
) = N_Object_Declaration
28111 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28116 -- Return the current source construct
28126 end Find_Related_Context
;
28128 --------------------------------------
28129 -- Find_Related_Declaration_Or_Body --
28130 --------------------------------------
28132 function Find_Related_Declaration_Or_Body
28134 Do_Checks
: Boolean := False) return Node_Id
28136 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
28138 procedure Expression_Function_Error
;
28139 -- Emit an error concerning pragma Prag that illegaly applies to an
28140 -- expression function.
28142 -------------------------------
28143 -- Expression_Function_Error --
28144 -------------------------------
28146 procedure Expression_Function_Error
is
28148 Error_Msg_Name_1
:= Prag_Nam
;
28150 -- Emit a precise message to distinguish between source pragmas and
28151 -- pragmas generated from aspects.
28153 if From_Aspect_Specification
(Prag
) then
28155 ("aspect % cannot apply to a stand alone expression function",
28159 ("pragma % cannot apply to a stand alone expression function",
28162 end Expression_Function_Error
;
28166 Context
: constant Node_Id
:= Parent
(Prag
);
28169 Look_For_Body
: constant Boolean :=
28170 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
28171 Name_Refined_Global
,
28172 Name_Refined_Post
);
28173 -- Refinement pragmas must be associated with a subprogram body [stub]
28175 -- Start of processing for Find_Related_Declaration_Or_Body
28178 Stmt
:= Prev
(Prag
);
28179 while Present
(Stmt
) loop
28181 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28182 -- by splitting a complex pre/postcondition are not considered to
28185 if Nkind
(Stmt
) = N_Pragma
then
28187 and then not Split_PPC
(Stmt
)
28188 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
28195 -- Emit an error when a refinement pragma appears on an expression
28196 -- function without a completion.
28199 and then Look_For_Body
28200 and then Nkind
(Stmt
) = N_Subprogram_Declaration
28201 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
28202 and then not Has_Completion
(Defining_Entity
(Stmt
))
28204 Expression_Function_Error
;
28207 -- The refinement pragma applies to a subprogram body stub
28209 elsif Look_For_Body
28210 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
28214 -- Skip internally generated code
28216 elsif not Comes_From_Source
(Stmt
) then
28218 -- The anonymous object created for a single concurrent type is a
28219 -- suitable context.
28221 if Nkind
(Stmt
) = N_Object_Declaration
28222 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28226 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
28228 -- The subprogram declaration is an internally generated spec
28229 -- for an expression function.
28231 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28234 -- The subprogram is actually an instance housed within an
28235 -- anonymous wrapper package.
28237 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28242 -- Return the current construct which is either a subprogram body,
28243 -- a subprogram declaration or is illegal.
28252 -- If we fall through, then the pragma was either the first declaration
28253 -- or it was preceded by other pragmas and no source constructs.
28255 -- The pragma is associated with a library-level subprogram
28257 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
28258 return Unit
(Parent
(Context
));
28260 -- The pragma appears inside the declarations of an entry body
28262 elsif Nkind
(Context
) = N_Entry_Body
then
28265 -- The pragma appears inside the statements of a subprogram body. This
28266 -- placement is the result of subprogram contract expansion.
28268 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
28269 return Parent
(Context
);
28271 -- The pragma appears inside the declarative part of a subprogram body
28273 elsif Nkind
(Context
) = N_Subprogram_Body
then
28276 -- The pragma appears inside the declarative part of a task body
28278 elsif Nkind
(Context
) = N_Task_Body
then
28281 -- The pragma is a byproduct of aspect expansion, return the related
28282 -- context of the original aspect. This case has a lower priority as
28283 -- the above circuitry pinpoints precisely the related context.
28285 elsif Present
(Corresponding_Aspect
(Prag
)) then
28286 return Parent
(Corresponding_Aspect
(Prag
));
28288 -- No candidate subprogram [body] found
28293 end Find_Related_Declaration_Or_Body
;
28295 ----------------------------------
28296 -- Find_Related_Package_Or_Body --
28297 ----------------------------------
28299 function Find_Related_Package_Or_Body
28301 Do_Checks
: Boolean := False) return Node_Id
28303 Context
: constant Node_Id
:= Parent
(Prag
);
28304 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28308 Stmt
:= Prev
(Prag
);
28309 while Present
(Stmt
) loop
28311 -- Skip prior pragmas, but check for duplicates
28313 if Nkind
(Stmt
) = N_Pragma
then
28314 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
28320 -- Skip internally generated code
28322 elsif not Comes_From_Source
(Stmt
) then
28323 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
28325 -- The subprogram declaration is an internally generated spec
28326 -- for an expression function.
28328 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28331 -- The subprogram is actually an instance housed within an
28332 -- anonymous wrapper package.
28334 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28339 -- Return the current source construct which is illegal
28348 -- If we fall through, then the pragma was either the first declaration
28349 -- or it was preceded by other pragmas and no source constructs.
28351 -- The pragma is associated with a package. The immediate context in
28352 -- this case is the specification of the package.
28354 if Nkind
(Context
) = N_Package_Specification
then
28355 return Parent
(Context
);
28357 -- The pragma appears in the declarations of a package body
28359 elsif Nkind
(Context
) = N_Package_Body
then
28362 -- The pragma appears in the statements of a package body
28364 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
28365 and then Nkind
(Parent
(Context
)) = N_Package_Body
28367 return Parent
(Context
);
28369 -- The pragma is a byproduct of aspect expansion, return the related
28370 -- context of the original aspect. This case has a lower priority as
28371 -- the above circuitry pinpoints precisely the related context.
28373 elsif Present
(Corresponding_Aspect
(Prag
)) then
28374 return Parent
(Corresponding_Aspect
(Prag
));
28376 -- No candidate packge [body] found
28381 end Find_Related_Package_Or_Body
;
28387 function Get_Argument
28389 Context_Id
: Entity_Id
:= Empty
) return Node_Id
28391 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
28394 -- Use the expression of the original aspect when compiling for ASIS or
28395 -- when analyzing the template of a generic unit. In both cases the
28396 -- aspect's tree must be decorated to allow for ASIS queries or to save
28397 -- the global references in the generic context.
28399 if From_Aspect_Specification
(Prag
)
28400 and then (ASIS_Mode
or else (Present
(Context_Id
)
28401 and then Is_Generic_Unit
(Context_Id
)))
28403 return Corresponding_Aspect
(Prag
);
28405 -- Otherwise use the expression of the pragma
28407 elsif Present
(Args
) then
28408 return First
(Args
);
28415 -------------------------
28416 -- Get_Base_Subprogram --
28417 -------------------------
28419 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
28420 Result
: Entity_Id
;
28423 -- Follow subprogram renaming chain
28427 if Is_Subprogram
(Result
)
28429 Nkind
(Parent
(Declaration_Node
(Result
))) =
28430 N_Subprogram_Renaming_Declaration
28431 and then Present
(Alias
(Result
))
28433 Result
:= Alias
(Result
);
28437 end Get_Base_Subprogram
;
28439 -----------------------
28440 -- Get_SPARK_Mode_Type --
28441 -----------------------
28443 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
28445 if N
= Name_On
then
28447 elsif N
= Name_Off
then
28450 -- Any other argument is illegal
28453 raise Program_Error
;
28455 end Get_SPARK_Mode_Type
;
28457 ------------------------------------
28458 -- Get_SPARK_Mode_From_Annotation --
28459 ------------------------------------
28461 function Get_SPARK_Mode_From_Annotation
28462 (N
: Node_Id
) return SPARK_Mode_Type
28467 if Nkind
(N
) = N_Aspect_Specification
then
28468 Mode
:= Expression
(N
);
28470 else pragma Assert
(Nkind
(N
) = N_Pragma
);
28471 Mode
:= First
(Pragma_Argument_Associations
(N
));
28473 if Present
(Mode
) then
28474 Mode
:= Get_Pragma_Arg
(Mode
);
28478 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28480 if Present
(Mode
) then
28481 if Nkind
(Mode
) = N_Identifier
then
28482 return Get_SPARK_Mode_Type
(Chars
(Mode
));
28484 -- In case of a malformed aspect or pragma, return the default None
28490 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28495 end Get_SPARK_Mode_From_Annotation
;
28497 ---------------------------
28498 -- Has_Extra_Parentheses --
28499 ---------------------------
28501 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
28505 -- The aggregate should not have an expression list because a clause
28506 -- is always interpreted as a component association. The only way an
28507 -- expression list can sneak in is by adding extra parentheses around
28508 -- the individual clauses:
28510 -- Depends (Output => Input) -- proper form
28511 -- Depends ((Output => Input)) -- extra parentheses
28513 -- Since the extra parentheses are not allowed by the syntax of the
28514 -- pragma, flag them now to avoid emitting misleading errors down the
28517 if Nkind
(Clause
) = N_Aggregate
28518 and then Present
(Expressions
(Clause
))
28520 Expr
:= First
(Expressions
(Clause
));
28521 while Present
(Expr
) loop
28523 -- A dependency clause surrounded by extra parentheses appears
28524 -- as an aggregate of component associations with an optional
28525 -- Paren_Count set.
28527 if Nkind
(Expr
) = N_Aggregate
28528 and then Present
(Component_Associations
(Expr
))
28531 ("dependency clause contains extra parentheses", Expr
);
28533 -- Otherwise the expression is a malformed construct
28536 SPARK_Msg_N
("malformed dependency clause", Expr
);
28546 end Has_Extra_Parentheses
;
28552 procedure Initialize
is
28563 Dummy
:= Dummy
+ 1;
28566 -----------------------------
28567 -- Is_Config_Static_String --
28568 -----------------------------
28570 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28572 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
28573 -- This is an internal recursive function that is just like the outer
28574 -- function except that it adds the string to the name buffer rather
28575 -- than placing the string in the name buffer.
28577 ------------------------------
28578 -- Add_Config_Static_String --
28579 ------------------------------
28581 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28588 if Nkind
(N
) = N_Op_Concat
then
28589 if Add_Config_Static_String
(Left_Opnd
(N
)) then
28590 N
:= Right_Opnd
(N
);
28596 if Nkind
(N
) /= N_String_Literal
then
28597 Error_Msg_N
("string literal expected for pragma argument", N
);
28601 for J
in 1 .. String_Length
(Strval
(N
)) loop
28602 C
:= Get_String_Char
(Strval
(N
), J
);
28604 if not In_Character_Range
(C
) then
28606 ("string literal contains invalid wide character",
28607 Sloc
(N
) + 1 + Source_Ptr
(J
));
28611 Add_Char_To_Name_Buffer
(Get_Character
(C
));
28616 end Add_Config_Static_String
;
28618 -- Start of processing for Is_Config_Static_String
28623 return Add_Config_Static_String
(Arg
);
28624 end Is_Config_Static_String
;
28626 ---------------------
28627 -- Is_CCT_Instance --
28628 ---------------------
28630 function Is_CCT_Instance
28631 (Ref_Id
: Entity_Id
;
28632 Context_Id
: Entity_Id
) return Boolean
28638 -- When the reference denotes a single protected type, the context is
28639 -- either a protected subprogram or its body.
28641 if Is_Single_Protected_Object
(Ref_Id
) then
28642 Typ
:= Scope
(Context_Id
);
28645 Ekind
(Typ
) = E_Protected_Type
28646 and then Present
(Anonymous_Object
(Typ
))
28647 and then Anonymous_Object
(Typ
) = Ref_Id
;
28649 -- When the reference denotes a single task type, the context is either
28650 -- the same type or if inside the body, the anonymous task type.
28652 elsif Is_Single_Task_Object
(Ref_Id
) then
28653 if Ekind
(Context_Id
) = E_Task_Type
then
28655 Present
(Anonymous_Object
(Context_Id
))
28656 and then Anonymous_Object
(Context_Id
) = Ref_Id
;
28658 return Ref_Id
= Context_Id
;
28661 -- Otherwise the reference denotes a protected or a task type. Climb the
28662 -- scope chain looking for an enclosing concurrent type that matches the
28663 -- referenced entity.
28666 pragma Assert
(Ekind_In
(Ref_Id
, E_Protected_Type
, E_Task_Type
));
28668 S
:= Current_Scope
;
28669 while Present
(S
) and then S
/= Standard_Standard
loop
28670 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
)
28671 and then S
= Ref_Id
28681 end Is_CCT_Instance
;
28683 -------------------------------
28684 -- Is_Elaboration_SPARK_Mode --
28685 -------------------------------
28687 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
28690 (Nkind
(N
) = N_Pragma
28691 and then Pragma_Name
(N
) = Name_SPARK_Mode
28692 and then Is_List_Member
(N
));
28694 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28695 -- appears in the statement part of the body.
28698 Present
(Parent
(N
))
28699 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
28700 and then List_Containing
(N
) = Statements
(Parent
(N
))
28701 and then Present
(Parent
(Parent
(N
)))
28702 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
28703 end Is_Elaboration_SPARK_Mode
;
28705 -----------------------
28706 -- Is_Enabled_Pragma --
28707 -----------------------
28709 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
28713 if Present
(Prag
) then
28714 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
28716 if Present
(Arg
) then
28717 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
28719 -- The lack of a Boolean argument automatically enables the pragma
28725 -- The pragma is missing, therefore it is not enabled
28730 end Is_Enabled_Pragma
;
28732 -----------------------------------------
28733 -- Is_Non_Significant_Pragma_Reference --
28734 -----------------------------------------
28736 -- This function makes use of the following static table which indicates
28737 -- whether appearance of some name in a given pragma is to be considered
28738 -- as a reference for the purposes of warnings about unreferenced objects.
28740 -- -1 indicates that appearence in any argument is significant
28741 -- 0 indicates that appearance in any argument is not significant
28742 -- +n indicates that appearance as argument n is significant, but all
28743 -- other arguments are not significant
28744 -- 9n arguments from n on are significant, before n insignificant
28746 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
28747 (Pragma_Abort_Defer
=> -1,
28748 Pragma_Abstract_State
=> -1,
28749 Pragma_Ada_83
=> -1,
28750 Pragma_Ada_95
=> -1,
28751 Pragma_Ada_05
=> -1,
28752 Pragma_Ada_2005
=> -1,
28753 Pragma_Ada_12
=> -1,
28754 Pragma_Ada_2012
=> -1,
28755 Pragma_All_Calls_Remote
=> -1,
28756 Pragma_Allow_Integer_Address
=> -1,
28757 Pragma_Annotate
=> 93,
28758 Pragma_Assert
=> -1,
28759 Pragma_Assert_And_Cut
=> -1,
28760 Pragma_Assertion_Policy
=> 0,
28761 Pragma_Assume
=> -1,
28762 Pragma_Assume_No_Invalid_Values
=> 0,
28763 Pragma_Async_Readers
=> 0,
28764 Pragma_Async_Writers
=> 0,
28765 Pragma_Asynchronous
=> 0,
28766 Pragma_Atomic
=> 0,
28767 Pragma_Atomic_Components
=> 0,
28768 Pragma_Attach_Handler
=> -1,
28769 Pragma_Attribute_Definition
=> 92,
28770 Pragma_Check
=> -1,
28771 Pragma_Check_Float_Overflow
=> 0,
28772 Pragma_Check_Name
=> 0,
28773 Pragma_Check_Policy
=> 0,
28774 Pragma_CPP_Class
=> 0,
28775 Pragma_CPP_Constructor
=> 0,
28776 Pragma_CPP_Virtual
=> 0,
28777 Pragma_CPP_Vtable
=> 0,
28779 Pragma_C_Pass_By_Copy
=> 0,
28780 Pragma_Comment
=> -1,
28781 Pragma_Common_Object
=> 0,
28782 Pragma_Compile_Time_Error
=> -1,
28783 Pragma_Compile_Time_Warning
=> -1,
28784 Pragma_Compiler_Unit
=> -1,
28785 Pragma_Compiler_Unit_Warning
=> -1,
28786 Pragma_Complete_Representation
=> 0,
28787 Pragma_Complex_Representation
=> 0,
28788 Pragma_Component_Alignment
=> 0,
28789 Pragma_Constant_After_Elaboration
=> 0,
28790 Pragma_Contract_Cases
=> -1,
28791 Pragma_Controlled
=> 0,
28792 Pragma_Convention
=> 0,
28793 Pragma_Convention_Identifier
=> 0,
28794 Pragma_Debug
=> -1,
28795 Pragma_Debug_Policy
=> 0,
28796 Pragma_Detect_Blocking
=> 0,
28797 Pragma_Default_Initial_Condition
=> -1,
28798 Pragma_Default_Scalar_Storage_Order
=> 0,
28799 Pragma_Default_Storage_Pool
=> 0,
28800 Pragma_Depends
=> -1,
28801 Pragma_Disable_Atomic_Synchronization
=> 0,
28802 Pragma_Discard_Names
=> 0,
28803 Pragma_Dispatching_Domain
=> -1,
28804 Pragma_Effective_Reads
=> 0,
28805 Pragma_Effective_Writes
=> 0,
28806 Pragma_Elaborate
=> 0,
28807 Pragma_Elaborate_All
=> 0,
28808 Pragma_Elaborate_Body
=> 0,
28809 Pragma_Elaboration_Checks
=> 0,
28810 Pragma_Eliminate
=> 0,
28811 Pragma_Enable_Atomic_Synchronization
=> 0,
28812 Pragma_Export
=> -1,
28813 Pragma_Export_Function
=> -1,
28814 Pragma_Export_Object
=> -1,
28815 Pragma_Export_Procedure
=> -1,
28816 Pragma_Export_Value
=> -1,
28817 Pragma_Export_Valued_Procedure
=> -1,
28818 Pragma_Extend_System
=> -1,
28819 Pragma_Extensions_Allowed
=> 0,
28820 Pragma_Extensions_Visible
=> 0,
28821 Pragma_External
=> -1,
28822 Pragma_Favor_Top_Level
=> 0,
28823 Pragma_External_Name_Casing
=> 0,
28824 Pragma_Fast_Math
=> 0,
28825 Pragma_Finalize_Storage_Only
=> 0,
28827 Pragma_Global
=> -1,
28828 Pragma_Ident
=> -1,
28829 Pragma_Ignore_Pragma
=> 0,
28830 Pragma_Implementation_Defined
=> -1,
28831 Pragma_Implemented
=> -1,
28832 Pragma_Implicit_Packing
=> 0,
28833 Pragma_Import
=> 93,
28834 Pragma_Import_Function
=> 0,
28835 Pragma_Import_Object
=> 0,
28836 Pragma_Import_Procedure
=> 0,
28837 Pragma_Import_Valued_Procedure
=> 0,
28838 Pragma_Independent
=> 0,
28839 Pragma_Independent_Components
=> 0,
28840 Pragma_Initial_Condition
=> -1,
28841 Pragma_Initialize_Scalars
=> 0,
28842 Pragma_Initializes
=> -1,
28843 Pragma_Inline
=> 0,
28844 Pragma_Inline_Always
=> 0,
28845 Pragma_Inline_Generic
=> 0,
28846 Pragma_Inspection_Point
=> -1,
28847 Pragma_Interface
=> 92,
28848 Pragma_Interface_Name
=> 0,
28849 Pragma_Interrupt_Handler
=> -1,
28850 Pragma_Interrupt_Priority
=> -1,
28851 Pragma_Interrupt_State
=> -1,
28852 Pragma_Invariant
=> -1,
28853 Pragma_Keep_Names
=> 0,
28854 Pragma_License
=> 0,
28855 Pragma_Link_With
=> -1,
28856 Pragma_Linker_Alias
=> -1,
28857 Pragma_Linker_Constructor
=> -1,
28858 Pragma_Linker_Destructor
=> -1,
28859 Pragma_Linker_Options
=> -1,
28860 Pragma_Linker_Section
=> 0,
28862 Pragma_Lock_Free
=> 0,
28863 Pragma_Locking_Policy
=> 0,
28864 Pragma_Loop_Invariant
=> -1,
28865 Pragma_Loop_Optimize
=> 0,
28866 Pragma_Loop_Variant
=> -1,
28867 Pragma_Machine_Attribute
=> -1,
28869 Pragma_Main_Storage
=> -1,
28870 Pragma_Max_Queue_Length
=> 0,
28871 Pragma_Memory_Size
=> 0,
28872 Pragma_No_Return
=> 0,
28873 Pragma_No_Body
=> 0,
28874 Pragma_No_Elaboration_Code_All
=> 0,
28875 Pragma_No_Inline
=> 0,
28876 Pragma_No_Run_Time
=> -1,
28877 Pragma_No_Strict_Aliasing
=> -1,
28878 Pragma_No_Tagged_Streams
=> 0,
28879 Pragma_Normalize_Scalars
=> 0,
28880 Pragma_Obsolescent
=> 0,
28881 Pragma_Optimize
=> 0,
28882 Pragma_Optimize_Alignment
=> 0,
28883 Pragma_Overflow_Mode
=> 0,
28884 Pragma_Overriding_Renamings
=> 0,
28885 Pragma_Ordered
=> 0,
28888 Pragma_Part_Of
=> 0,
28889 Pragma_Partition_Elaboration_Policy
=> 0,
28890 Pragma_Passive
=> 0,
28891 Pragma_Persistent_BSS
=> 0,
28892 Pragma_Polling
=> 0,
28893 Pragma_Prefix_Exception_Messages
=> 0,
28895 Pragma_Postcondition
=> -1,
28896 Pragma_Post_Class
=> -1,
28898 Pragma_Precondition
=> -1,
28899 Pragma_Predicate
=> -1,
28900 Pragma_Predicate_Failure
=> -1,
28901 Pragma_Preelaborable_Initialization
=> -1,
28902 Pragma_Preelaborate
=> 0,
28903 Pragma_Pre_Class
=> -1,
28904 Pragma_Priority
=> -1,
28905 Pragma_Priority_Specific_Dispatching
=> 0,
28906 Pragma_Profile
=> 0,
28907 Pragma_Profile_Warnings
=> 0,
28908 Pragma_Propagate_Exceptions
=> 0,
28909 Pragma_Provide_Shift_Operators
=> 0,
28910 Pragma_Psect_Object
=> 0,
28912 Pragma_Pure_Function
=> 0,
28913 Pragma_Queuing_Policy
=> 0,
28914 Pragma_Rational
=> 0,
28915 Pragma_Ravenscar
=> 0,
28916 Pragma_Refined_Depends
=> -1,
28917 Pragma_Refined_Global
=> -1,
28918 Pragma_Refined_Post
=> -1,
28919 Pragma_Refined_State
=> -1,
28920 Pragma_Relative_Deadline
=> 0,
28921 Pragma_Rename_Pragma
=> 0,
28922 Pragma_Remote_Access_Type
=> -1,
28923 Pragma_Remote_Call_Interface
=> -1,
28924 Pragma_Remote_Types
=> -1,
28925 Pragma_Restricted_Run_Time
=> 0,
28926 Pragma_Restriction_Warnings
=> 0,
28927 Pragma_Restrictions
=> 0,
28928 Pragma_Reviewable
=> -1,
28929 Pragma_Secondary_Stack_Size
=> -1,
28930 Pragma_Short_Circuit_And_Or
=> 0,
28931 Pragma_Share_Generic
=> 0,
28932 Pragma_Shared
=> 0,
28933 Pragma_Shared_Passive
=> 0,
28934 Pragma_Short_Descriptors
=> 0,
28935 Pragma_Simple_Storage_Pool_Type
=> 0,
28936 Pragma_Source_File_Name
=> 0,
28937 Pragma_Source_File_Name_Project
=> 0,
28938 Pragma_Source_Reference
=> 0,
28939 Pragma_SPARK_Mode
=> 0,
28940 Pragma_Storage_Size
=> -1,
28941 Pragma_Storage_Unit
=> 0,
28942 Pragma_Static_Elaboration_Desired
=> 0,
28943 Pragma_Stream_Convert
=> 0,
28944 Pragma_Style_Checks
=> 0,
28945 Pragma_Subtitle
=> 0,
28946 Pragma_Suppress
=> 0,
28947 Pragma_Suppress_Exception_Locations
=> 0,
28948 Pragma_Suppress_All
=> 0,
28949 Pragma_Suppress_Debug_Info
=> 0,
28950 Pragma_Suppress_Initialization
=> 0,
28951 Pragma_System_Name
=> 0,
28952 Pragma_Task_Dispatching_Policy
=> 0,
28953 Pragma_Task_Info
=> -1,
28954 Pragma_Task_Name
=> -1,
28955 Pragma_Task_Storage
=> -1,
28956 Pragma_Test_Case
=> -1,
28957 Pragma_Thread_Local_Storage
=> -1,
28958 Pragma_Time_Slice
=> -1,
28960 Pragma_Type_Invariant
=> -1,
28961 Pragma_Type_Invariant_Class
=> -1,
28962 Pragma_Unchecked_Union
=> 0,
28963 Pragma_Unevaluated_Use_Of_Old
=> 0,
28964 Pragma_Unimplemented_Unit
=> 0,
28965 Pragma_Universal_Aliasing
=> 0,
28966 Pragma_Universal_Data
=> 0,
28967 Pragma_Unmodified
=> 0,
28968 Pragma_Unreferenced
=> 0,
28969 Pragma_Unreferenced_Objects
=> 0,
28970 Pragma_Unreserve_All_Interrupts
=> 0,
28971 Pragma_Unsuppress
=> 0,
28972 Pragma_Unused
=> 0,
28973 Pragma_Use_VADS_Size
=> 0,
28974 Pragma_Validity_Checks
=> 0,
28975 Pragma_Volatile
=> 0,
28976 Pragma_Volatile_Components
=> 0,
28977 Pragma_Volatile_Full_Access
=> 0,
28978 Pragma_Volatile_Function
=> 0,
28979 Pragma_Warning_As_Error
=> 0,
28980 Pragma_Warnings
=> 0,
28981 Pragma_Weak_External
=> 0,
28982 Pragma_Wide_Character_Encoding
=> 0,
28983 Unknown_Pragma
=> 0);
28985 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
28991 function Arg_No
return Nat
;
28992 -- Returns an integer showing what argument we are in. A value of
28993 -- zero means we are not in any of the arguments.
28999 function Arg_No
return Nat
is
29004 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
29018 -- Start of processing for Non_Significant_Pragma_Reference
29023 if Nkind
(P
) /= N_Pragma_Argument_Association
then
29027 Id
:= Get_Pragma_Id
(Parent
(P
));
29028 C
:= Sig_Flags
(Id
);
29043 return AN
< (C
- 90);
29049 end Is_Non_Significant_Pragma_Reference
;
29051 ------------------------------
29052 -- Is_Pragma_String_Literal --
29053 ------------------------------
29055 -- This function returns true if the corresponding pragma argument is a
29056 -- static string expression. These are the only cases in which string
29057 -- literals can appear as pragma arguments. We also allow a string literal
29058 -- as the first argument to pragma Assert (although it will of course
29059 -- always generate a type error).
29061 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
29062 Pragn
: constant Node_Id
:= Parent
(Par
);
29063 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
29064 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
29070 N
:= First
(Assoc
);
29077 if Pname
= Name_Assert
then
29080 elsif Pname
= Name_Export
then
29083 elsif Pname
= Name_Ident
then
29086 elsif Pname
= Name_Import
then
29089 elsif Pname
= Name_Interface_Name
then
29092 elsif Pname
= Name_Linker_Alias
then
29095 elsif Pname
= Name_Linker_Section
then
29098 elsif Pname
= Name_Machine_Attribute
then
29101 elsif Pname
= Name_Source_File_Name
then
29104 elsif Pname
= Name_Source_Reference
then
29107 elsif Pname
= Name_Title
then
29110 elsif Pname
= Name_Subtitle
then
29116 end Is_Pragma_String_Literal
;
29118 ---------------------------
29119 -- Is_Private_SPARK_Mode --
29120 ---------------------------
29122 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
29125 (Nkind
(N
) = N_Pragma
29126 and then Pragma_Name
(N
) = Name_SPARK_Mode
29127 and then Is_List_Member
(N
));
29129 -- For pragma SPARK_Mode to be private, it has to appear in the private
29130 -- declarations of a package.
29133 Present
(Parent
(N
))
29134 and then Nkind
(Parent
(N
)) = N_Package_Specification
29135 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
29136 end Is_Private_SPARK_Mode
;
29138 -------------------------------------
29139 -- Is_Unconstrained_Or_Tagged_Item --
29140 -------------------------------------
29142 function Is_Unconstrained_Or_Tagged_Item
29143 (Item
: Entity_Id
) return Boolean
29145 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
29146 -- Determine whether record type Typ has at least one unconstrained
29149 ---------------------------------
29150 -- Has_Unconstrained_Component --
29151 ---------------------------------
29153 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
29157 Comp
:= First_Component
(Typ
);
29158 while Present
(Comp
) loop
29159 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
29163 Next_Component
(Comp
);
29167 end Has_Unconstrained_Component
;
29171 Typ
: constant Entity_Id
:= Etype
(Item
);
29173 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29176 if Is_Tagged_Type
(Typ
) then
29179 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
29182 elsif Is_Record_Type
(Typ
) then
29183 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
29186 return Has_Unconstrained_Component
(Typ
);
29189 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
29195 end Is_Unconstrained_Or_Tagged_Item
;
29197 -----------------------------
29198 -- Is_Valid_Assertion_Kind --
29199 -----------------------------
29201 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
29208 | Name_Assertion_Policy
29209 | Name_Static_Predicate
29210 | Name_Dynamic_Predicate
29215 | Name_Type_Invariant
29216 | Name_uType_Invariant
29220 | Name_Assert_And_Cut
29222 | Name_Contract_Cases
29224 | Name_Default_Initial_Condition
29226 | Name_Initial_Condition
29229 | Name_Loop_Invariant
29230 | Name_Loop_Variant
29231 | Name_Postcondition
29232 | Name_Precondition
29234 | Name_Refined_Post
29235 | Name_Statement_Assertions
29242 end Is_Valid_Assertion_Kind
;
29244 --------------------------------------
29245 -- Process_Compilation_Unit_Pragmas --
29246 --------------------------------------
29248 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
29250 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29251 -- strange because it comes at the end of the unit. Rational has the
29252 -- same name for a pragma, but treats it as a program unit pragma, In
29253 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29254 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29255 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29256 -- the context clause to ensure the correct processing.
29258 if Has_Pragma_Suppress_All
(N
) then
29259 Prepend_To
(Context_Items
(N
),
29260 Make_Pragma
(Sloc
(N
),
29261 Chars
=> Name_Suppress
,
29262 Pragma_Argument_Associations
=> New_List
(
29263 Make_Pragma_Argument_Association
(Sloc
(N
),
29264 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
29267 -- Nothing else to do at the current time
29269 end Process_Compilation_Unit_Pragmas
;
29271 -------------------------------------------
29272 -- Process_Compile_Time_Warning_Or_Error --
29273 -------------------------------------------
29275 procedure Process_Compile_Time_Warning_Or_Error
29279 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
29280 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
29281 Arg2
: constant Node_Id
:= Next
(Arg1
);
29284 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
29286 if Compile_Time_Known_Value
(Arg1x
) then
29287 if Is_True
(Expr_Value
(Arg1x
)) then
29289 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29290 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
29291 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
29292 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
29293 Str_Len
: constant Nat
:= String_Length
(Str
);
29295 Force
: constant Boolean :=
29296 Prag_Id
= Pragma_Compile_Time_Warning
29297 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
29298 and then (Ekind
(Cent
) /= E_Package
29299 or else not In_Private_Part
(Cent
));
29300 -- Set True if this is the warning case, and we are in the
29301 -- visible part of a package spec, or in a subprogram spec,
29302 -- in which case we want to force the client to see the
29303 -- warning, even though it is not in the main unit.
29311 -- Loop through segments of message separated by line feeds.
29312 -- We output these segments as separate messages with
29313 -- continuation marks for all but the first.
29318 Error_Msg_Strlen
:= 0;
29320 -- Loop to copy characters from argument to error message
29324 exit when Ptr
> Str_Len
;
29325 CC
:= Get_String_Char
(Str
, Ptr
);
29328 -- Ignore wide chars ??? else store character
29330 if In_Character_Range
(CC
) then
29331 C
:= Get_Character
(CC
);
29332 exit when C
= ASCII
.LF
;
29333 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
29334 Error_Msg_String
(Error_Msg_Strlen
) := C
;
29338 -- Here with one line ready to go
29340 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
29342 -- If this is a warning in a spec, then we want clients
29343 -- to see the warning, so mark the message with the
29344 -- special sequence !! to force the warning. In the case
29345 -- of a package spec, we do not force this if we are in
29346 -- the private part of the spec.
29349 if Cont
= False then
29350 Error_Msg
("<<~!!", Eloc
);
29353 Error_Msg
("\<<~!!", Eloc
);
29356 -- Error, rather than warning, or in a body, so we do not
29357 -- need to force visibility for client (error will be
29358 -- output in any case, and this is the situation in which
29359 -- we do not want a client to get a warning, since the
29360 -- warning is in the body or the spec private part).
29363 if Cont
= False then
29364 Error_Msg
("<<~", Eloc
);
29367 Error_Msg
("\<<~", Eloc
);
29371 exit when Ptr
> Str_Len
;
29376 end Process_Compile_Time_Warning_Or_Error
;
29378 ------------------------------------
29379 -- Record_Possible_Body_Reference --
29380 ------------------------------------
29382 procedure Record_Possible_Body_Reference
29383 (State_Id
: Entity_Id
;
29387 Spec_Id
: Entity_Id
;
29390 -- Ensure that we are dealing with a reference to a state
29392 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
29394 -- Climb the tree starting from the reference looking for a package body
29395 -- whose spec declares the referenced state. This criteria automatically
29396 -- excludes references in package specs which are legal. Note that it is
29397 -- not wise to emit an error now as the package body may lack pragma
29398 -- Refined_State or the referenced state may not be mentioned in the
29399 -- refinement. This approach avoids the generation of misleading errors.
29402 while Present
(Context
) loop
29403 if Nkind
(Context
) = N_Package_Body
then
29404 Spec_Id
:= Corresponding_Spec
(Context
);
29406 if Present
(Abstract_States
(Spec_Id
))
29407 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
29409 if No
(Body_References
(State_Id
)) then
29410 Set_Body_References
(State_Id
, New_Elmt_List
);
29413 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
29418 Context
:= Parent
(Context
);
29420 end Record_Possible_Body_Reference
;
29422 ------------------------------------------
29423 -- Relocate_Pragmas_To_Anonymous_Object --
29424 ------------------------------------------
29426 procedure Relocate_Pragmas_To_Anonymous_Object
29427 (Typ_Decl
: Node_Id
;
29428 Obj_Decl
: Node_Id
)
29432 Next_Decl
: Node_Id
;
29435 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
29436 Def
:= Protected_Definition
(Typ_Decl
);
29438 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
29439 Def
:= Task_Definition
(Typ_Decl
);
29442 -- The concurrent definition has a visible declaration list. Inspect it
29443 -- and relocate all canidate pragmas.
29445 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
29446 Decl
:= First
(Visible_Declarations
(Def
));
29447 while Present
(Decl
) loop
29449 -- Preserve the following declaration for iteration purposes due
29450 -- to possible relocation of a pragma.
29452 Next_Decl
:= Next
(Decl
);
29454 if Nkind
(Decl
) = N_Pragma
29455 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
29458 Insert_After
(Obj_Decl
, Decl
);
29460 -- Skip internally generated code
29462 elsif not Comes_From_Source
(Decl
) then
29465 -- No candidate pragmas are available for relocation
29474 end Relocate_Pragmas_To_Anonymous_Object
;
29476 ------------------------------
29477 -- Relocate_Pragmas_To_Body --
29478 ------------------------------
29480 procedure Relocate_Pragmas_To_Body
29481 (Subp_Body
: Node_Id
;
29482 Target_Body
: Node_Id
:= Empty
)
29484 procedure Relocate_Pragma
(Prag
: Node_Id
);
29485 -- Remove a single pragma from its current list and add it to the
29486 -- declarations of the proper body (either Subp_Body or Target_Body).
29488 ---------------------
29489 -- Relocate_Pragma --
29490 ---------------------
29492 procedure Relocate_Pragma
(Prag
: Node_Id
) is
29497 -- When subprogram stubs or expression functions are involves, the
29498 -- destination declaration list belongs to the proper body.
29500 if Present
(Target_Body
) then
29501 Target
:= Target_Body
;
29503 Target
:= Subp_Body
;
29506 Decls
:= Declarations
(Target
);
29510 Set_Declarations
(Target
, Decls
);
29513 -- Unhook the pragma from its current list
29516 Prepend
(Prag
, Decls
);
29517 end Relocate_Pragma
;
29521 Body_Id
: constant Entity_Id
:=
29522 Defining_Unit_Name
(Specification
(Subp_Body
));
29523 Next_Stmt
: Node_Id
;
29526 -- Start of processing for Relocate_Pragmas_To_Body
29529 -- Do not process a body that comes from a separate unit as no construct
29530 -- can possibly follow it.
29532 if not Is_List_Member
(Subp_Body
) then
29535 -- Do not relocate pragmas that follow a stub if the stub does not have
29538 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
29539 and then No
(Target_Body
)
29543 -- Do not process internally generated routine _Postconditions
29545 elsif Ekind
(Body_Id
) = E_Procedure
29546 and then Chars
(Body_Id
) = Name_uPostconditions
29551 -- Look at what is following the body. We are interested in certain kind
29552 -- of pragmas (either from source or byproducts of expansion) that can
29553 -- apply to a body [stub].
29555 Stmt
:= Next
(Subp_Body
);
29556 while Present
(Stmt
) loop
29558 -- Preserve the following statement for iteration purposes due to a
29559 -- possible relocation of a pragma.
29561 Next_Stmt
:= Next
(Stmt
);
29563 -- Move a candidate pragma following the body to the declarations of
29566 if Nkind
(Stmt
) = N_Pragma
29567 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
29569 Relocate_Pragma
(Stmt
);
29571 -- Skip internally generated code
29573 elsif not Comes_From_Source
(Stmt
) then
29576 -- No candidate pragmas are available for relocation
29584 end Relocate_Pragmas_To_Body
;
29586 -------------------
29587 -- Resolve_State --
29588 -------------------
29590 procedure Resolve_State
(N
: Node_Id
) is
29595 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29596 Func
:= Entity
(N
);
29598 -- Handle overloading of state names by functions. Traverse the
29599 -- homonym chain looking for an abstract state.
29601 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
29602 State
:= Homonym
(Func
);
29603 while Present
(State
) loop
29605 -- Resolve the overloading by setting the proper entity of the
29606 -- reference to that of the state.
29608 if Ekind
(State
) = E_Abstract_State
then
29609 Set_Etype
(N
, Standard_Void_Type
);
29610 Set_Entity
(N
, State
);
29611 Set_Associated_Node
(N
, State
);
29615 State
:= Homonym
(State
);
29618 -- A function can never act as a state. If the homonym chain does
29619 -- not contain a corresponding state, then something went wrong in
29620 -- the overloading mechanism.
29622 raise Program_Error
;
29627 ----------------------------
29628 -- Rewrite_Assertion_Kind --
29629 ----------------------------
29631 procedure Rewrite_Assertion_Kind
29633 From_Policy
: Boolean := False)
29639 if Nkind
(N
) = N_Attribute_Reference
29640 and then Attribute_Name
(N
) = Name_Class
29641 and then Nkind
(Prefix
(N
)) = N_Identifier
29643 case Chars
(Prefix
(N
)) is
29650 when Name_Type_Invariant
=>
29651 Nam
:= Name_uType_Invariant
;
29653 when Name_Invariant
=>
29654 Nam
:= Name_uInvariant
;
29660 -- Recommend standard use of aspect names Pre/Post
29662 elsif Nkind
(N
) = N_Identifier
29663 and then From_Policy
29664 and then Serious_Errors_Detected
= 0
29665 and then not ASIS_Mode
29667 if Chars
(N
) = Name_Precondition
29668 or else Chars
(N
) = Name_Postcondition
29670 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
29672 ("\use Assertion_Policy and aspect names Pre/Post for "
29673 & "Ada2012 conformance?", N
);
29679 if Nam
/= No_Name
then
29680 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
29682 end Rewrite_Assertion_Kind
;
29690 Dummy
:= Dummy
+ 1;
29693 --------------------------------
29694 -- Set_Encoded_Interface_Name --
29695 --------------------------------
29697 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
29698 Str
: constant String_Id
:= Strval
(S
);
29699 Len
: constant Nat
:= String_Length
(Str
);
29704 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
29707 -- Stores encoded value of character code CC. The encoding we use an
29708 -- underscore followed by four lower case hex digits.
29714 procedure Encode
is
29716 Store_String_Char
(Get_Char_Code
('_'));
29718 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
29720 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
29722 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
29724 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
29727 -- Start of processing for Set_Encoded_Interface_Name
29730 -- If first character is asterisk, this is a link name, and we leave it
29731 -- completely unmodified. We also ignore null strings (the latter case
29732 -- happens only in error cases).
29735 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
29737 Set_Interface_Name
(E
, S
);
29742 CC
:= Get_String_Char
(Str
, J
);
29744 exit when not In_Character_Range
(CC
);
29746 C
:= Get_Character
(CC
);
29748 exit when C
/= '_' and then C
/= '$'
29749 and then C
not in '0' .. '9'
29750 and then C
not in 'a' .. 'z'
29751 and then C
not in 'A' .. 'Z';
29754 Set_Interface_Name
(E
, S
);
29762 -- Here we need to encode. The encoding we use as follows:
29763 -- three underscores + four hex digits (lower case)
29767 for J
in 1 .. String_Length
(Str
) loop
29768 CC
:= Get_String_Char
(Str
, J
);
29770 if not In_Character_Range
(CC
) then
29773 C
:= Get_Character
(CC
);
29775 if C
= '_' or else C
= '$'
29776 or else C
in '0' .. '9'
29777 or else C
in 'a' .. 'z'
29778 or else C
in 'A' .. 'Z'
29780 Store_String_Char
(CC
);
29787 Set_Interface_Name
(E
,
29788 Make_String_Literal
(Sloc
(S
),
29789 Strval
=> End_String
));
29791 end Set_Encoded_Interface_Name
;
29793 ------------------------
29794 -- Set_Elab_Unit_Name --
29795 ------------------------
29797 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
29802 if Nkind
(N
) = N_Identifier
29803 and then Nkind
(With_Item
) = N_Identifier
29805 Set_Entity
(N
, Entity
(With_Item
));
29807 elsif Nkind
(N
) = N_Selected_Component
then
29808 Change_Selected_Component_To_Expanded_Name
(N
);
29809 Set_Entity
(N
, Entity
(With_Item
));
29810 Set_Entity
(Selector_Name
(N
), Entity
(N
));
29812 Pref
:= Prefix
(N
);
29813 Scop
:= Scope
(Entity
(N
));
29814 while Nkind
(Pref
) = N_Selected_Component
loop
29815 Change_Selected_Component_To_Expanded_Name
(Pref
);
29816 Set_Entity
(Selector_Name
(Pref
), Scop
);
29817 Set_Entity
(Pref
, Scop
);
29818 Pref
:= Prefix
(Pref
);
29819 Scop
:= Scope
(Scop
);
29822 Set_Entity
(Pref
, Scop
);
29825 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
29826 end Set_Elab_Unit_Name
;
29828 -------------------
29829 -- Test_Case_Arg --
29830 -------------------
29832 function Test_Case_Arg
29835 From_Aspect
: Boolean := False) return Node_Id
29837 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
29842 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
29847 -- The caller requests the aspect argument
29849 if From_Aspect
then
29850 if Present
(Aspect
)
29851 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
29853 Args
:= Expression
(Aspect
);
29855 -- "Name" and "Mode" may appear without an identifier as a
29856 -- positional association.
29858 if Present
(Expressions
(Args
)) then
29859 Arg
:= First
(Expressions
(Args
));
29861 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29869 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29874 -- Some or all arguments may appear as component associatons
29876 if Present
(Component_Associations
(Args
)) then
29877 Arg
:= First
(Component_Associations
(Args
));
29878 while Present
(Arg
) loop
29879 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
29888 -- Otherwise retrieve the argument directly from the pragma
29891 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29893 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29897 -- Skip argument "Name"
29901 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29905 -- Skip argument "Mode"
29909 -- Arguments "Requires" and "Ensures" are optional and may not be
29912 while Present
(Arg
) loop
29913 if Chars
(Arg
) = Arg_Nam
then