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
13845 elsif not Comes_From_Source
(Stmt
) then
13848 -- The associated private type [extension] has been found, stop
13851 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
13852 N_Private_Type_Declaration
)
13854 Typ
:= Defining_Entity
(Stmt
);
13857 -- The pragma does not apply to a legal construct, issue an
13858 -- error and stop the analysis.
13865 Stmt
:= Prev
(Stmt
);
13868 -- A pragma that applies to a Ghost entity becomes Ghost for the
13869 -- purposes of legality checks and removal of ignored Ghost code.
13871 Mark_Ghost_Pragma
(N
, Typ
);
13873 -- The pragma signals that the type defines its own DIC assertion
13876 Set_Has_Own_DIC
(Typ
);
13878 -- Chain the pragma on the rep item chain for further processing
13880 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
13882 -- Create the declaration of the procedure which verifies the
13883 -- assertion expression of pragma DIC at runtime.
13885 Build_DIC_Procedure_Declaration
(Typ
);
13888 ----------------------------------
13889 -- Default_Scalar_Storage_Order --
13890 ----------------------------------
13892 -- pragma Default_Scalar_Storage_Order
13893 -- (High_Order_First | Low_Order_First);
13895 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
13896 Default
: Character;
13900 Check_Arg_Count
(1);
13902 -- Default_Scalar_Storage_Order can appear as a configuration
13903 -- pragma, or in a declarative part of a package spec.
13905 if not Is_Configuration_Pragma
then
13906 Check_Is_In_Decl_Part_Or_Package_Spec
;
13909 Check_No_Identifiers
;
13910 Check_Arg_Is_One_Of
13911 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
13912 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
13913 Default
:= Fold_Upper
(Name_Buffer
(1));
13915 if not Support_Nondefault_SSO_On_Target
13916 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
13918 if Warn_On_Unrecognized_Pragma
then
13920 ("non-default Scalar_Storage_Order not supported "
13921 & "on target?g?", N
);
13923 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
13926 -- Here set the specified default
13929 Opt
.Default_SSO
:= Default
;
13933 --------------------------
13934 -- Default_Storage_Pool --
13935 --------------------------
13937 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
13939 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
13944 Check_Arg_Count
(1);
13946 -- Default_Storage_Pool can appear as a configuration pragma, or
13947 -- in a declarative part of a package spec.
13949 if not Is_Configuration_Pragma
then
13950 Check_Is_In_Decl_Part_Or_Package_Spec
;
13953 if From_Aspect_Specification
(N
) then
13955 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
13957 if not In_Open_Scopes
(E
) then
13959 ("aspect must apply to package or subprogram", N
);
13964 if Present
(Arg1
) then
13965 Pool
:= Get_Pragma_Arg
(Arg1
);
13967 -- Case of Default_Storage_Pool (null);
13969 if Nkind
(Pool
) = N_Null
then
13972 -- This is an odd case, this is not really an expression,
13973 -- so we don't have a type for it. So just set the type to
13976 Set_Etype
(Pool
, Empty
);
13978 -- Case of Default_Storage_Pool (storage_pool_NAME);
13981 -- If it's a configuration pragma, then the only allowed
13982 -- argument is "null".
13984 if Is_Configuration_Pragma
then
13985 Error_Pragma_Arg
("NULL expected", Arg1
);
13988 -- The expected type for a non-"null" argument is
13989 -- Root_Storage_Pool'Class, and the pool must be a variable.
13991 Analyze_And_Resolve
13992 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
13994 if Is_Variable
(Pool
) then
13996 -- A pragma that applies to a Ghost entity becomes Ghost
13997 -- for the purposes of legality checks and removal of
13998 -- ignored Ghost code.
14000 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14004 ("default storage pool must be a variable", Arg1
);
14008 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14009 -- access type will use this information to set the appropriate
14010 -- attributes of the access type.
14012 Default_Pool
:= Pool
;
14014 end Default_Storage_Pool
;
14020 -- pragma Depends (DEPENDENCY_RELATION);
14022 -- DEPENDENCY_RELATION ::=
14024 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14026 -- DEPENDENCY_CLAUSE ::=
14027 -- OUTPUT_LIST =>[+] INPUT_LIST
14028 -- | NULL_DEPENDENCY_CLAUSE
14030 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14032 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14034 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14036 -- OUTPUT ::= NAME | FUNCTION_RESULT
14039 -- where FUNCTION_RESULT is a function Result attribute_reference
14041 -- Characteristics:
14043 -- * Analysis - The annotation undergoes initial checks to verify
14044 -- the legal placement and context. Secondary checks fully analyze
14045 -- the dependency clauses in:
14047 -- Analyze_Depends_In_Decl_Part
14049 -- * Expansion - None.
14051 -- * Template - The annotation utilizes the generic template of the
14052 -- related subprogram [body] when it is:
14054 -- aspect on subprogram declaration
14055 -- aspect on stand alone subprogram body
14056 -- pragma on stand alone subprogram body
14058 -- The annotation must prepare its own template when it is:
14060 -- pragma on subprogram declaration
14062 -- * Globals - Capture of global references must occur after full
14065 -- * Instance - The annotation is instantiated automatically when
14066 -- the related generic subprogram [body] is instantiated except for
14067 -- the "pragma on subprogram declaration" case. In that scenario
14068 -- the annotation must instantiate itself.
14070 when Pragma_Depends
=> Depends
: declare
14072 Spec_Id
: Entity_Id
;
14073 Subp_Decl
: Node_Id
;
14076 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14080 -- Chain the pragma on the contract for further processing by
14081 -- Analyze_Depends_In_Decl_Part.
14083 Add_Contract_Item
(N
, Spec_Id
);
14085 -- Fully analyze the pragma when it appears inside an entry
14086 -- or subprogram body because it cannot benefit from forward
14089 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14091 N_Subprogram_Body_Stub
)
14093 -- The legality checks of pragmas Depends and Global are
14094 -- affected by the SPARK mode in effect and the volatility
14095 -- of the context. In addition these two pragmas are subject
14096 -- to an inherent order:
14101 -- Analyze all these pragmas in the order outlined above
14103 Analyze_If_Present
(Pragma_SPARK_Mode
);
14104 Analyze_If_Present
(Pragma_Volatile_Function
);
14105 Analyze_If_Present
(Pragma_Global
);
14106 Analyze_Depends_In_Decl_Part
(N
);
14111 ---------------------
14112 -- Detect_Blocking --
14113 ---------------------
14115 -- pragma Detect_Blocking;
14117 when Pragma_Detect_Blocking
=>
14119 Check_Arg_Count
(0);
14120 Check_Valid_Configuration_Pragma
;
14121 Detect_Blocking
:= True;
14123 ------------------------------------
14124 -- Disable_Atomic_Synchronization --
14125 ------------------------------------
14127 -- pragma Disable_Atomic_Synchronization [(Entity)];
14129 when Pragma_Disable_Atomic_Synchronization
=>
14131 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14133 -------------------
14134 -- Discard_Names --
14135 -------------------
14137 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14139 when Pragma_Discard_Names
=> Discard_Names
: declare
14144 Check_Ada_83_Warning
;
14146 -- Deal with configuration pragma case
14148 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14149 Global_Discard_Names
:= True;
14152 -- Otherwise, check correct appropriate context
14155 Check_Is_In_Decl_Part_Or_Package_Spec
;
14157 if Arg_Count
= 0 then
14159 -- If there is no parameter, then from now on this pragma
14160 -- applies to any enumeration, exception or tagged type
14161 -- defined in the current declarative part, and recursively
14162 -- to any nested scope.
14164 Set_Discard_Names
(Current_Scope
);
14168 Check_Arg_Count
(1);
14169 Check_Optional_Identifier
(Arg1
, Name_On
);
14170 Check_Arg_Is_Local_Name
(Arg1
);
14172 E_Id
:= Get_Pragma_Arg
(Arg1
);
14174 if Etype
(E_Id
) = Any_Type
then
14177 E
:= Entity
(E_Id
);
14180 -- A pragma that applies to a Ghost entity becomes Ghost for
14181 -- the purposes of legality checks and removal of ignored
14184 Mark_Ghost_Pragma
(N
, E
);
14186 if (Is_First_Subtype
(E
)
14188 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14189 or else Ekind
(E
) = E_Exception
14191 Set_Discard_Names
(E
);
14192 Record_Rep_Item
(E
, N
);
14196 ("inappropriate entity for pragma%", Arg1
);
14202 ------------------------
14203 -- Dispatching_Domain --
14204 ------------------------
14206 -- pragma Dispatching_Domain (EXPRESSION);
14208 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14209 P
: constant Node_Id
:= Parent
(N
);
14215 Check_No_Identifiers
;
14216 Check_Arg_Count
(1);
14218 -- This pragma is born obsolete, but not the aspect
14220 if not From_Aspect_Specification
(N
) then
14222 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14225 if Nkind
(P
) = N_Task_Definition
then
14226 Arg
:= Get_Pragma_Arg
(Arg1
);
14227 Ent
:= Defining_Identifier
(Parent
(P
));
14229 -- A pragma that applies to a Ghost entity becomes Ghost for
14230 -- the purposes of legality checks and removal of ignored Ghost
14233 Mark_Ghost_Pragma
(N
, Ent
);
14235 -- The expression must be analyzed in the special manner
14236 -- described in "Handling of Default and Per-Object
14237 -- Expressions" in sem.ads.
14239 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14241 -- Check duplicate pragma before we chain the pragma in the Rep
14242 -- Item chain of Ent.
14244 Check_Duplicate_Pragma
(Ent
);
14245 Record_Rep_Item
(Ent
, N
);
14247 -- Anything else is incorrect
14252 end Dispatching_Domain
;
14258 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14260 when Pragma_Elaborate
=> Elaborate
: declare
14265 -- Pragma must be in context items list of a compilation unit
14267 if not Is_In_Context_Clause
then
14271 -- Must be at least one argument
14273 if Arg_Count
= 0 then
14274 Error_Pragma
("pragma% requires at least one argument");
14277 -- In Ada 83 mode, there can be no items following it in the
14278 -- context list except other pragmas and implicit with clauses
14279 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14280 -- placement rule does not apply.
14282 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14284 while Present
(Citem
) loop
14285 if Nkind
(Citem
) = N_Pragma
14286 or else (Nkind
(Citem
) = N_With_Clause
14287 and then Implicit_With
(Citem
))
14292 ("(Ada 83) pragma% must be at end of context clause");
14299 -- Finally, the arguments must all be units mentioned in a with
14300 -- clause in the same context clause. Note we already checked (in
14301 -- Par.Prag) that the arguments are all identifiers or selected
14305 Outer
: while Present
(Arg
) loop
14306 Citem
:= First
(List_Containing
(N
));
14307 Inner
: while Citem
/= N
loop
14308 if Nkind
(Citem
) = N_With_Clause
14309 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14311 Set_Elaborate_Present
(Citem
, True);
14312 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14314 -- With the pragma present, elaboration calls on
14315 -- subprograms from the named unit need no further
14316 -- checks, as long as the pragma appears in the current
14317 -- compilation unit. If the pragma appears in some unit
14318 -- in the context, there might still be a need for an
14319 -- Elaborate_All_Desirable from the current compilation
14320 -- to the named unit, so we keep the check enabled.
14322 if In_Extended_Main_Source_Unit
(N
) then
14324 -- This does not apply in SPARK mode, where we allow
14325 -- pragma Elaborate, but we don't trust it to be right
14326 -- so we will still insist on the Elaborate_All.
14328 if SPARK_Mode
/= On
then
14329 Set_Suppress_Elaboration_Warnings
14330 (Entity
(Name
(Citem
)));
14342 ("argument of pragma% is not withed unit", Arg
);
14348 -- Give a warning if operating in static mode with one of the
14349 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14352 and not Dynamic_Elaboration_Checks
14354 -- pragma Elaborate not allowed in SPARK mode anyway. We
14355 -- already complained about it, no point in generating any
14356 -- further complaint.
14358 and SPARK_Mode
/= On
14361 ("?l?use of pragma Elaborate may not be safe", N
);
14363 ("?l?use pragma Elaborate_All instead if possible", N
);
14367 -------------------
14368 -- Elaborate_All --
14369 -------------------
14371 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14373 when Pragma_Elaborate_All
=> Elaborate_All
: declare
14378 Check_Ada_83_Warning
;
14380 -- Pragma must be in context items list of a compilation unit
14382 if not Is_In_Context_Clause
then
14386 -- Must be at least one argument
14388 if Arg_Count
= 0 then
14389 Error_Pragma
("pragma% requires at least one argument");
14392 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14393 -- have to appear at the end of the context clause, but may
14394 -- appear mixed in with other items, even in Ada 83 mode.
14396 -- Final check: the arguments must all be units mentioned in
14397 -- a with clause in the same context clause. Note that we
14398 -- already checked (in Par.Prag) that all the arguments are
14399 -- either identifiers or selected components.
14402 Outr
: while Present
(Arg
) loop
14403 Citem
:= First
(List_Containing
(N
));
14404 Innr
: while Citem
/= N
loop
14405 if Nkind
(Citem
) = N_With_Clause
14406 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14408 Set_Elaborate_All_Present
(Citem
, True);
14409 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14411 -- Suppress warnings and elaboration checks on the named
14412 -- unit if the pragma is in the current compilation, as
14413 -- for pragma Elaborate.
14415 if In_Extended_Main_Source_Unit
(N
) then
14416 Set_Suppress_Elaboration_Warnings
14417 (Entity
(Name
(Citem
)));
14426 Set_Error_Posted
(N
);
14428 ("argument of pragma% is not withed unit", Arg
);
14435 --------------------
14436 -- Elaborate_Body --
14437 --------------------
14439 -- pragma Elaborate_Body [( library_unit_NAME )];
14441 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
14442 Cunit_Node
: Node_Id
;
14443 Cunit_Ent
: Entity_Id
;
14446 Check_Ada_83_Warning
;
14447 Check_Valid_Library_Unit_Pragma
;
14449 if Nkind
(N
) = N_Null_Statement
then
14453 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
14454 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14456 -- A pragma that applies to a Ghost entity becomes Ghost for the
14457 -- purposes of legality checks and removal of ignored Ghost code.
14459 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
14461 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
14464 Error_Pragma
("pragma% must refer to a spec, not a body");
14466 Set_Body_Required
(Cunit_Node
, True);
14467 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
14469 -- If we are in dynamic elaboration mode, then we suppress
14470 -- elaboration warnings for the unit, since it is definitely
14471 -- fine NOT to do dynamic checks at the first level (and such
14472 -- checks will be suppressed because no elaboration boolean
14473 -- is created for Elaborate_Body packages).
14475 -- But in the static model of elaboration, Elaborate_Body is
14476 -- definitely NOT good enough to ensure elaboration safety on
14477 -- its own, since the body may WITH other units that are not
14478 -- safe from an elaboration point of view, so a client must
14479 -- still do an Elaborate_All on such units.
14481 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14482 -- Elaborate_Body always suppressed elab warnings.
14484 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
14485 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
14488 end Elaborate_Body
;
14490 ------------------------
14491 -- Elaboration_Checks --
14492 ------------------------
14494 -- pragma Elaboration_Checks (Static | Dynamic);
14496 when Pragma_Elaboration_Checks
=>
14498 Check_Arg_Count
(1);
14499 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
14501 -- Set flag accordingly (ignore attempt at dynamic elaboration
14502 -- checks in SPARK mode).
14504 Dynamic_Elaboration_Checks
:=
14505 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
14511 -- pragma Eliminate (
14512 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14513 -- [,[Entity =>] IDENTIFIER |
14514 -- SELECTED_COMPONENT |
14516 -- [, OVERLOADING_RESOLUTION]);
14518 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14521 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14522 -- FUNCTION_PROFILE
14524 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14526 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14527 -- Result_Type => result_SUBTYPE_NAME]
14529 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14530 -- SUBTYPE_NAME ::= STRING_LITERAL
14532 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14533 -- SOURCE_TRACE ::= STRING_LITERAL
14535 when Pragma_Eliminate
=> Eliminate
: declare
14536 Args
: Args_List
(1 .. 5);
14537 Names
: constant Name_List
(1 .. 5) := (
14540 Name_Parameter_Types
,
14542 Name_Source_Location
);
14544 Unit_Name
: Node_Id
renames Args
(1);
14545 Entity
: Node_Id
renames Args
(2);
14546 Parameter_Types
: Node_Id
renames Args
(3);
14547 Result_Type
: Node_Id
renames Args
(4);
14548 Source_Location
: Node_Id
renames Args
(5);
14552 Check_Valid_Configuration_Pragma
;
14553 Gather_Associations
(Names
, Args
);
14555 if No
(Unit_Name
) then
14556 Error_Pragma
("missing Unit_Name argument for pragma%");
14560 and then (Present
(Parameter_Types
)
14562 Present
(Result_Type
)
14564 Present
(Source_Location
))
14566 Error_Pragma
("missing Entity argument for pragma%");
14569 if (Present
(Parameter_Types
)
14571 Present
(Result_Type
))
14573 Present
(Source_Location
)
14576 ("parameter profile and source location cannot be used "
14577 & "together in pragma%");
14580 Process_Eliminate_Pragma
14589 -----------------------------------
14590 -- Enable_Atomic_Synchronization --
14591 -----------------------------------
14593 -- pragma Enable_Atomic_Synchronization [(Entity)];
14595 when Pragma_Enable_Atomic_Synchronization
=>
14597 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
14604 -- [ Convention =>] convention_IDENTIFIER,
14605 -- [ Entity =>] LOCAL_NAME
14606 -- [, [External_Name =>] static_string_EXPRESSION ]
14607 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14609 when Pragma_Export
=> Export
: declare
14611 Def_Id
: Entity_Id
;
14613 pragma Warnings
(Off
, C
);
14616 Check_Ada_83_Warning
;
14620 Name_External_Name
,
14623 Check_At_Least_N_Arguments
(2);
14624 Check_At_Most_N_Arguments
(4);
14626 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14627 -- pragma Export (Entity, "external name");
14629 if Relaxed_RM_Semantics
14630 and then Arg_Count
= 2
14631 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
14634 Def_Id
:= Get_Pragma_Arg
(Arg1
);
14637 if not Is_Entity_Name
(Def_Id
) then
14638 Error_Pragma_Arg
("entity name required", Arg1
);
14641 Def_Id
:= Entity
(Def_Id
);
14642 Set_Exported
(Def_Id
, Arg1
);
14645 Process_Convention
(C
, Def_Id
);
14647 -- A pragma that applies to a Ghost entity becomes Ghost for
14648 -- the purposes of legality checks and removal of ignored Ghost
14651 Mark_Ghost_Pragma
(N
, Def_Id
);
14653 if Ekind
(Def_Id
) /= E_Constant
then
14654 Note_Possible_Modification
14655 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14658 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
);
14659 Set_Exported
(Def_Id
, Arg2
);
14662 -- If the entity is a deferred constant, propagate the information
14663 -- to the full view, because gigi elaborates the full view only.
14665 if Ekind
(Def_Id
) = E_Constant
14666 and then Present
(Full_View
(Def_Id
))
14669 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
14671 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
14672 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
14673 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
14678 ---------------------
14679 -- Export_Function --
14680 ---------------------
14682 -- pragma Export_Function (
14683 -- [Internal =>] LOCAL_NAME
14684 -- [, [External =>] EXTERNAL_SYMBOL]
14685 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14686 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14687 -- [, [Mechanism =>] MECHANISM]
14688 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14690 -- EXTERNAL_SYMBOL ::=
14692 -- | static_string_EXPRESSION
14694 -- PARAMETER_TYPES ::=
14696 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14698 -- TYPE_DESIGNATOR ::=
14700 -- | subtype_Name ' Access
14704 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14706 -- MECHANISM_ASSOCIATION ::=
14707 -- [formal_parameter_NAME =>] MECHANISM_NAME
14709 -- MECHANISM_NAME ::=
14713 when Pragma_Export_Function
=> Export_Function
: declare
14714 Args
: Args_List
(1 .. 6);
14715 Names
: constant Name_List
(1 .. 6) := (
14718 Name_Parameter_Types
,
14721 Name_Result_Mechanism
);
14723 Internal
: Node_Id
renames Args
(1);
14724 External
: Node_Id
renames Args
(2);
14725 Parameter_Types
: Node_Id
renames Args
(3);
14726 Result_Type
: Node_Id
renames Args
(4);
14727 Mechanism
: Node_Id
renames Args
(5);
14728 Result_Mechanism
: Node_Id
renames Args
(6);
14732 Gather_Associations
(Names
, Args
);
14733 Process_Extended_Import_Export_Subprogram_Pragma
(
14734 Arg_Internal
=> Internal
,
14735 Arg_External
=> External
,
14736 Arg_Parameter_Types
=> Parameter_Types
,
14737 Arg_Result_Type
=> Result_Type
,
14738 Arg_Mechanism
=> Mechanism
,
14739 Arg_Result_Mechanism
=> Result_Mechanism
);
14740 end Export_Function
;
14742 -------------------
14743 -- Export_Object --
14744 -------------------
14746 -- pragma Export_Object (
14747 -- [Internal =>] LOCAL_NAME
14748 -- [, [External =>] EXTERNAL_SYMBOL]
14749 -- [, [Size =>] EXTERNAL_SYMBOL]);
14751 -- EXTERNAL_SYMBOL ::=
14753 -- | static_string_EXPRESSION
14755 -- PARAMETER_TYPES ::=
14757 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14759 -- TYPE_DESIGNATOR ::=
14761 -- | subtype_Name ' Access
14765 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14767 -- MECHANISM_ASSOCIATION ::=
14768 -- [formal_parameter_NAME =>] MECHANISM_NAME
14770 -- MECHANISM_NAME ::=
14774 when Pragma_Export_Object
=> Export_Object
: declare
14775 Args
: Args_List
(1 .. 3);
14776 Names
: constant Name_List
(1 .. 3) := (
14781 Internal
: Node_Id
renames Args
(1);
14782 External
: Node_Id
renames Args
(2);
14783 Size
: Node_Id
renames Args
(3);
14787 Gather_Associations
(Names
, Args
);
14788 Process_Extended_Import_Export_Object_Pragma
(
14789 Arg_Internal
=> Internal
,
14790 Arg_External
=> External
,
14794 ----------------------
14795 -- Export_Procedure --
14796 ----------------------
14798 -- pragma Export_Procedure (
14799 -- [Internal =>] LOCAL_NAME
14800 -- [, [External =>] EXTERNAL_SYMBOL]
14801 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14802 -- [, [Mechanism =>] MECHANISM]);
14804 -- EXTERNAL_SYMBOL ::=
14806 -- | static_string_EXPRESSION
14808 -- PARAMETER_TYPES ::=
14810 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14812 -- TYPE_DESIGNATOR ::=
14814 -- | subtype_Name ' Access
14818 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14820 -- MECHANISM_ASSOCIATION ::=
14821 -- [formal_parameter_NAME =>] MECHANISM_NAME
14823 -- MECHANISM_NAME ::=
14827 when Pragma_Export_Procedure
=> Export_Procedure
: declare
14828 Args
: Args_List
(1 .. 4);
14829 Names
: constant Name_List
(1 .. 4) := (
14832 Name_Parameter_Types
,
14835 Internal
: Node_Id
renames Args
(1);
14836 External
: Node_Id
renames Args
(2);
14837 Parameter_Types
: Node_Id
renames Args
(3);
14838 Mechanism
: Node_Id
renames Args
(4);
14842 Gather_Associations
(Names
, Args
);
14843 Process_Extended_Import_Export_Subprogram_Pragma
(
14844 Arg_Internal
=> Internal
,
14845 Arg_External
=> External
,
14846 Arg_Parameter_Types
=> Parameter_Types
,
14847 Arg_Mechanism
=> Mechanism
);
14848 end Export_Procedure
;
14854 -- pragma Export_Value (
14855 -- [Value =>] static_integer_EXPRESSION,
14856 -- [Link_Name =>] static_string_EXPRESSION);
14858 when Pragma_Export_Value
=>
14860 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
14861 Check_Arg_Count
(2);
14863 Check_Optional_Identifier
(Arg1
, Name_Value
);
14864 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
14866 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
14867 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
14869 -----------------------------
14870 -- Export_Valued_Procedure --
14871 -----------------------------
14873 -- pragma Export_Valued_Procedure (
14874 -- [Internal =>] LOCAL_NAME
14875 -- [, [External =>] EXTERNAL_SYMBOL,]
14876 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14877 -- [, [Mechanism =>] MECHANISM]);
14879 -- EXTERNAL_SYMBOL ::=
14881 -- | static_string_EXPRESSION
14883 -- PARAMETER_TYPES ::=
14885 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14887 -- TYPE_DESIGNATOR ::=
14889 -- | subtype_Name ' Access
14893 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14895 -- MECHANISM_ASSOCIATION ::=
14896 -- [formal_parameter_NAME =>] MECHANISM_NAME
14898 -- MECHANISM_NAME ::=
14902 when Pragma_Export_Valued_Procedure
=>
14903 Export_Valued_Procedure
: declare
14904 Args
: Args_List
(1 .. 4);
14905 Names
: constant Name_List
(1 .. 4) := (
14908 Name_Parameter_Types
,
14911 Internal
: Node_Id
renames Args
(1);
14912 External
: Node_Id
renames Args
(2);
14913 Parameter_Types
: Node_Id
renames Args
(3);
14914 Mechanism
: Node_Id
renames Args
(4);
14918 Gather_Associations
(Names
, Args
);
14919 Process_Extended_Import_Export_Subprogram_Pragma
(
14920 Arg_Internal
=> Internal
,
14921 Arg_External
=> External
,
14922 Arg_Parameter_Types
=> Parameter_Types
,
14923 Arg_Mechanism
=> Mechanism
);
14924 end Export_Valued_Procedure
;
14926 -------------------
14927 -- Extend_System --
14928 -------------------
14930 -- pragma Extend_System ([Name =>] Identifier);
14932 when Pragma_Extend_System
=>
14934 Check_Valid_Configuration_Pragma
;
14935 Check_Arg_Count
(1);
14936 Check_Optional_Identifier
(Arg1
, Name_Name
);
14937 Check_Arg_Is_Identifier
(Arg1
);
14939 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14942 and then Name_Buffer
(1 .. 4) = "aux_"
14944 if Present
(System_Extend_Pragma_Arg
) then
14945 if Chars
(Get_Pragma_Arg
(Arg1
)) =
14946 Chars
(Expression
(System_Extend_Pragma_Arg
))
14950 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
14951 Error_Pragma
("pragma% conflicts with that #");
14955 System_Extend_Pragma_Arg
:= Arg1
;
14957 if not GNAT_Mode
then
14958 System_Extend_Unit
:= Arg1
;
14962 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
14965 ------------------------
14966 -- Extensions_Allowed --
14967 ------------------------
14969 -- pragma Extensions_Allowed (ON | OFF);
14971 when Pragma_Extensions_Allowed
=>
14973 Check_Arg_Count
(1);
14974 Check_No_Identifiers
;
14975 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
14977 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
14978 Extensions_Allowed
:= True;
14979 Ada_Version
:= Ada_Version_Type
'Last;
14982 Extensions_Allowed
:= False;
14983 Ada_Version
:= Ada_Version_Explicit
;
14984 Ada_Version_Pragma
:= Empty
;
14987 ------------------------
14988 -- Extensions_Visible --
14989 ------------------------
14991 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
14993 -- Characteristics:
14995 -- * Analysis - The annotation is fully analyzed immediately upon
14996 -- elaboration as its expression must be static.
14998 -- * Expansion - None.
15000 -- * Template - The annotation utilizes the generic template of the
15001 -- related subprogram [body] when it is:
15003 -- aspect on subprogram declaration
15004 -- aspect on stand alone subprogram body
15005 -- pragma on stand alone subprogram body
15007 -- The annotation must prepare its own template when it is:
15009 -- pragma on subprogram declaration
15011 -- * Globals - Capture of global references must occur after full
15014 -- * Instance - The annotation is instantiated automatically when
15015 -- the related generic subprogram [body] is instantiated except for
15016 -- the "pragma on subprogram declaration" case. In that scenario
15017 -- the annotation must instantiate itself.
15019 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15020 Formal
: Entity_Id
;
15021 Has_OK_Formal
: Boolean := False;
15022 Spec_Id
: Entity_Id
;
15023 Subp_Decl
: Node_Id
;
15027 Check_No_Identifiers
;
15028 Check_At_Most_N_Arguments
(1);
15031 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15033 -- Abstract subprogram declaration
15035 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15038 -- Generic subprogram declaration
15040 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15043 -- Body acts as spec
15045 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15046 and then No
(Corresponding_Spec
(Subp_Decl
))
15050 -- Body stub acts as spec
15052 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15053 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15057 -- Subprogram declaration
15059 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15062 -- Otherwise the pragma is associated with an illegal construct
15065 Error_Pragma
("pragma % must apply to a subprogram");
15069 -- Mark the pragma as Ghost if the related subprogram is also
15070 -- Ghost. This also ensures that any expansion performed further
15071 -- below will produce Ghost nodes.
15073 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15074 Mark_Ghost_Pragma
(N
, Spec_Id
);
15076 -- Chain the pragma on the contract for completeness
15078 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15080 -- The legality checks of pragma Extension_Visible are affected
15081 -- by the SPARK mode in effect. Analyze all pragmas in specific
15084 Analyze_If_Present
(Pragma_SPARK_Mode
);
15086 -- Examine the formals of the related subprogram
15088 Formal
:= First_Formal
(Spec_Id
);
15089 while Present
(Formal
) loop
15091 -- At least one of the formals is of a specific tagged type,
15092 -- the pragma is legal.
15094 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15095 Has_OK_Formal
:= True;
15098 -- A generic subprogram with at least one formal of a private
15099 -- type ensures the legality of the pragma because the actual
15100 -- may be specifically tagged. Note that this is verified by
15101 -- the check above at instantiation time.
15103 elsif Is_Private_Type
(Etype
(Formal
))
15104 and then Is_Generic_Type
(Etype
(Formal
))
15106 Has_OK_Formal
:= True;
15110 Next_Formal
(Formal
);
15113 if not Has_OK_Formal
then
15114 Error_Msg_Name_1
:= Pname
;
15115 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15117 ("\subprogram & lacks parameter of specific tagged or "
15118 & "generic private type", N
, Spec_Id
);
15123 -- Analyze the Boolean expression (if any)
15125 if Present
(Arg1
) then
15126 Check_Static_Boolean_Expression
15127 (Expression
(Get_Argument
(N
, Spec_Id
)));
15129 end Extensions_Visible
;
15135 -- pragma External (
15136 -- [ Convention =>] convention_IDENTIFIER,
15137 -- [ Entity =>] LOCAL_NAME
15138 -- [, [External_Name =>] static_string_EXPRESSION ]
15139 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15141 when Pragma_External
=> External
: declare
15144 pragma Warnings
(Off
, C
);
15151 Name_External_Name
,
15153 Check_At_Least_N_Arguments
(2);
15154 Check_At_Most_N_Arguments
(4);
15155 Process_Convention
(C
, E
);
15157 -- A pragma that applies to a Ghost entity becomes Ghost for the
15158 -- purposes of legality checks and removal of ignored Ghost code.
15160 Mark_Ghost_Pragma
(N
, E
);
15162 Note_Possible_Modification
15163 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15164 Process_Interface_Name
(E
, Arg3
, Arg4
);
15165 Set_Exported
(E
, Arg2
);
15168 --------------------------
15169 -- External_Name_Casing --
15170 --------------------------
15172 -- pragma External_Name_Casing (
15173 -- UPPERCASE | LOWERCASE
15174 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15176 when Pragma_External_Name_Casing
=>
15178 Check_No_Identifiers
;
15180 if Arg_Count
= 2 then
15181 Check_Arg_Is_One_Of
15182 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15184 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15186 Opt
.External_Name_Exp_Casing
:= As_Is
;
15188 when Name_Uppercase
=>
15189 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15191 when Name_Lowercase
=>
15192 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15199 Check_Arg_Count
(1);
15202 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15204 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15205 when Name_Uppercase
=>
15206 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15208 when Name_Lowercase
=>
15209 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15219 -- pragma Fast_Math;
15221 when Pragma_Fast_Math
=>
15223 Check_No_Identifiers
;
15224 Check_Valid_Configuration_Pragma
;
15227 --------------------------
15228 -- Favor_Top_Level --
15229 --------------------------
15231 -- pragma Favor_Top_Level (type_NAME);
15233 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15238 Check_No_Identifiers
;
15239 Check_Arg_Count
(1);
15240 Check_Arg_Is_Local_Name
(Arg1
);
15241 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15243 -- A pragma that applies to a Ghost entity becomes Ghost for the
15244 -- purposes of legality checks and removal of ignored Ghost code.
15246 Mark_Ghost_Pragma
(N
, Typ
);
15248 -- If it's an access-to-subprogram type (in particular, not a
15249 -- subtype), set the flag on that type.
15251 if Is_Access_Subprogram_Type
(Typ
) then
15252 Set_Can_Use_Internal_Rep
(Typ
, False);
15254 -- Otherwise it's an error (name denotes the wrong sort of entity)
15258 ("access-to-subprogram type expected",
15259 Get_Pragma_Arg
(Arg1
));
15261 end Favor_Top_Level
;
15263 ---------------------------
15264 -- Finalize_Storage_Only --
15265 ---------------------------
15267 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15269 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15270 Assoc
: constant Node_Id
:= Arg1
;
15271 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15276 Check_No_Identifiers
;
15277 Check_Arg_Count
(1);
15278 Check_Arg_Is_Local_Name
(Arg1
);
15280 Find_Type
(Type_Id
);
15281 Typ
:= Entity
(Type_Id
);
15284 or else Rep_Item_Too_Early
(Typ
, N
)
15288 Typ
:= Underlying_Type
(Typ
);
15291 if not Is_Controlled
(Typ
) then
15292 Error_Pragma
("pragma% must specify controlled type");
15295 Check_First_Subtype
(Arg1
);
15297 if Finalize_Storage_Only
(Typ
) then
15298 Error_Pragma
("duplicate pragma%, only one allowed");
15300 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15301 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15303 end Finalize_Storage
;
15309 -- pragma Ghost [ (boolean_EXPRESSION) ];
15311 when Pragma_Ghost
=> Ghost
: declare
15315 Orig_Stmt
: Node_Id
;
15316 Prev_Id
: Entity_Id
;
15321 Check_No_Identifiers
;
15322 Check_At_Most_N_Arguments
(1);
15326 while Present
(Stmt
) loop
15328 -- Skip prior pragmas, but check for duplicates
15330 if Nkind
(Stmt
) = N_Pragma
then
15331 if Pragma_Name
(Stmt
) = Pname
then
15332 Error_Msg_Name_1
:= Pname
;
15333 Error_Msg_Sloc
:= Sloc
(Stmt
);
15334 Error_Msg_N
("pragma % duplicates pragma declared#", N
);
15337 -- Task unit declared without a definition cannot be subject to
15338 -- pragma Ghost (SPARK RM 6.9(19)).
15340 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15341 N_Task_Type_Declaration
)
15343 Error_Pragma
("pragma % cannot apply to a task type");
15346 -- Skip internally generated code
15348 elsif not Comes_From_Source
(Stmt
) then
15349 Orig_Stmt
:= Original_Node
(Stmt
);
15351 -- When pragma Ghost applies to an untagged derivation, the
15352 -- derivation is transformed into a [sub]type declaration.
15354 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15355 N_Subtype_Declaration
)
15356 and then Comes_From_Source
(Orig_Stmt
)
15357 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15358 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15359 N_Derived_Type_Definition
15361 Id
:= Defining_Entity
(Stmt
);
15364 -- When pragma Ghost applies to an object declaration which
15365 -- is initialized by means of a function call that returns
15366 -- on the secondary stack, the object declaration becomes a
15369 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
15370 and then Comes_From_Source
(Orig_Stmt
)
15371 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
15373 Id
:= Defining_Entity
(Stmt
);
15376 -- When pragma Ghost applies to an expression function, the
15377 -- expression function is transformed into a subprogram.
15379 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
15380 and then Comes_From_Source
(Orig_Stmt
)
15381 and then Nkind
(Orig_Stmt
) = N_Expression_Function
15383 Id
:= Defining_Entity
(Stmt
);
15387 -- The pragma applies to a legal construct, stop the traversal
15389 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
15390 N_Full_Type_Declaration
,
15391 N_Generic_Subprogram_Declaration
,
15392 N_Object_Declaration
,
15393 N_Private_Extension_Declaration
,
15394 N_Private_Type_Declaration
,
15395 N_Subprogram_Declaration
,
15396 N_Subtype_Declaration
)
15398 Id
:= Defining_Entity
(Stmt
);
15401 -- The pragma does not apply to a legal construct, issue an
15402 -- error and stop the analysis.
15406 ("pragma % must apply to an object, package, subprogram "
15411 Stmt
:= Prev
(Stmt
);
15414 Context
:= Parent
(N
);
15416 -- Handle compilation units
15418 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
15419 Context
:= Unit
(Parent
(Context
));
15422 -- Protected and task types cannot be subject to pragma Ghost
15423 -- (SPARK RM 6.9(19)).
15425 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
15427 Error_Pragma
("pragma % cannot apply to a protected type");
15430 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
15431 Error_Pragma
("pragma % cannot apply to a task type");
15437 -- When pragma Ghost is associated with a [generic] package, it
15438 -- appears in the visible declarations.
15440 if Nkind
(Context
) = N_Package_Specification
15441 and then Present
(Visible_Declarations
(Context
))
15442 and then List_Containing
(N
) = Visible_Declarations
(Context
)
15444 Id
:= Defining_Entity
(Context
);
15446 -- Pragma Ghost applies to a stand alone subprogram body
15448 elsif Nkind
(Context
) = N_Subprogram_Body
15449 and then No
(Corresponding_Spec
(Context
))
15451 Id
:= Defining_Entity
(Context
);
15453 -- Pragma Ghost applies to a subprogram declaration that acts
15454 -- as a compilation unit.
15456 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
15457 Id
:= Defining_Entity
(Context
);
15463 ("pragma % must apply to an object, package, subprogram or "
15468 -- Handle completions of types and constants that are subject to
15471 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
15472 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
15474 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
15475 Error_Msg_Name_1
:= Pname
;
15477 -- The full declaration of a deferred constant cannot be
15478 -- subject to pragma Ghost unless the deferred declaration
15479 -- is also Ghost (SPARK RM 6.9(9)).
15481 if Ekind
(Prev_Id
) = E_Constant
then
15482 Error_Msg_Name_1
:= Pname
;
15483 Error_Msg_NE
(Fix_Error
15484 ("pragma % must apply to declaration of deferred "
15485 & "constant &"), N
, Id
);
15488 -- Pragma Ghost may appear on the full view of an incomplete
15489 -- type because the incomplete declaration lacks aspects and
15490 -- cannot be subject to pragma Ghost.
15492 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
15495 -- The full declaration of a type cannot be subject to
15496 -- pragma Ghost unless the partial view is also Ghost
15497 -- (SPARK RM 6.9(9)).
15500 Error_Msg_NE
(Fix_Error
15501 ("pragma % must apply to partial view of type &"),
15507 -- A synchronized object cannot be subject to pragma Ghost
15508 -- (SPARK RM 6.9(19)).
15510 elsif Ekind
(Id
) = E_Variable
then
15511 if Is_Protected_Type
(Etype
(Id
)) then
15512 Error_Pragma
("pragma % cannot apply to a protected object");
15515 elsif Is_Task_Type
(Etype
(Id
)) then
15516 Error_Pragma
("pragma % cannot apply to a task object");
15521 -- Analyze the Boolean expression (if any)
15523 if Present
(Arg1
) then
15524 Expr
:= Get_Pragma_Arg
(Arg1
);
15526 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
15528 if Is_OK_Static_Expression
(Expr
) then
15530 -- "Ghostness" cannot be turned off once enabled within a
15531 -- region (SPARK RM 6.9(6)).
15533 if Is_False
(Expr_Value
(Expr
))
15534 and then Ghost_Mode
> None
15537 ("pragma % with value False cannot appear in enabled "
15542 -- Otherwie the expression is not static
15546 ("expression of pragma % must be static", Expr
);
15551 Set_Is_Ghost_Entity
(Id
);
15558 -- pragma Global (GLOBAL_SPECIFICATION);
15560 -- GLOBAL_SPECIFICATION ::=
15563 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15565 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15567 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15568 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15569 -- GLOBAL_ITEM ::= NAME
15571 -- Characteristics:
15573 -- * Analysis - The annotation undergoes initial checks to verify
15574 -- the legal placement and context. Secondary checks fully analyze
15575 -- the dependency clauses in:
15577 -- Analyze_Global_In_Decl_Part
15579 -- * Expansion - None.
15581 -- * Template - The annotation utilizes the generic template of the
15582 -- related subprogram [body] when it is:
15584 -- aspect on subprogram declaration
15585 -- aspect on stand alone subprogram body
15586 -- pragma on stand alone subprogram body
15588 -- The annotation must prepare its own template when it is:
15590 -- pragma on subprogram declaration
15592 -- * Globals - Capture of global references must occur after full
15595 -- * Instance - The annotation is instantiated automatically when
15596 -- the related generic subprogram [body] is instantiated except for
15597 -- the "pragma on subprogram declaration" case. In that scenario
15598 -- the annotation must instantiate itself.
15600 when Pragma_Global
=> Global
: declare
15602 Spec_Id
: Entity_Id
;
15603 Subp_Decl
: Node_Id
;
15606 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15610 -- Chain the pragma on the contract for further processing by
15611 -- Analyze_Global_In_Decl_Part.
15613 Add_Contract_Item
(N
, Spec_Id
);
15615 -- Fully analyze the pragma when it appears inside an entry
15616 -- or subprogram body because it cannot benefit from forward
15619 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15621 N_Subprogram_Body_Stub
)
15623 -- The legality checks of pragmas Depends and Global are
15624 -- affected by the SPARK mode in effect and the volatility
15625 -- of the context. In addition these two pragmas are subject
15626 -- to an inherent order:
15631 -- Analyze all these pragmas in the order outlined above
15633 Analyze_If_Present
(Pragma_SPARK_Mode
);
15634 Analyze_If_Present
(Pragma_Volatile_Function
);
15635 Analyze_Global_In_Decl_Part
(N
);
15636 Analyze_If_Present
(Pragma_Depends
);
15645 -- pragma Ident (static_string_EXPRESSION)
15647 -- Note: pragma Comment shares this processing. Pragma Ident is
15648 -- identical in effect to pragma Commment.
15650 when Pragma_Comment
15658 Check_Arg_Count
(1);
15659 Check_No_Identifiers
;
15660 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15663 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
15670 GP
:= Parent
(Parent
(N
));
15672 if Nkind_In
(GP
, N_Package_Declaration
,
15673 N_Generic_Package_Declaration
)
15678 -- If we have a compilation unit, then record the ident value,
15679 -- checking for improper duplication.
15681 if Nkind
(GP
) = N_Compilation_Unit
then
15682 CS
:= Ident_String
(Current_Sem_Unit
);
15684 if Present
(CS
) then
15686 -- If we have multiple instances, concatenate them, but
15687 -- not in ASIS, where we want the original tree.
15689 if not ASIS_Mode
then
15690 Start_String
(Strval
(CS
));
15691 Store_String_Char
(' ');
15692 Store_String_Chars
(Strval
(Str
));
15693 Set_Strval
(CS
, End_String
);
15697 Set_Ident_String
(Current_Sem_Unit
, Str
);
15700 -- For subunits, we just ignore the Ident, since in GNAT these
15701 -- are not separate object files, and hence not separate units
15702 -- in the unit table.
15704 elsif Nkind
(GP
) = N_Subunit
then
15710 -------------------
15711 -- Ignore_Pragma --
15712 -------------------
15714 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15716 -- Entirely handled in the parser, nothing to do here
15718 when Pragma_Ignore_Pragma
=>
15721 ----------------------------
15722 -- Implementation_Defined --
15723 ----------------------------
15725 -- pragma Implementation_Defined (LOCAL_NAME);
15727 -- Marks previously declared entity as implementation defined. For
15728 -- an overloaded entity, applies to the most recent homonym.
15730 -- pragma Implementation_Defined;
15732 -- The form with no arguments appears anywhere within a scope, most
15733 -- typically a package spec, and indicates that all entities that are
15734 -- defined within the package spec are Implementation_Defined.
15736 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15741 Check_No_Identifiers
;
15743 -- Form with no arguments
15745 if Arg_Count
= 0 then
15746 Set_Is_Implementation_Defined
(Current_Scope
);
15748 -- Form with one argument
15751 Check_Arg_Count
(1);
15752 Check_Arg_Is_Local_Name
(Arg1
);
15753 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15754 Set_Is_Implementation_Defined
(Ent
);
15756 end Implementation_Defined
;
15762 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15764 -- IMPLEMENTATION_KIND ::=
15765 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15767 -- "By_Any" and "Optional" are treated as synonyms in order to
15768 -- support Ada 2012 aspect Synchronization.
15770 when Pragma_Implemented
=> Implemented
: declare
15771 Proc_Id
: Entity_Id
;
15776 Check_Arg_Count
(2);
15777 Check_No_Identifiers
;
15778 Check_Arg_Is_Identifier
(Arg1
);
15779 Check_Arg_Is_Local_Name
(Arg1
);
15780 Check_Arg_Is_One_Of
(Arg2
,
15783 Name_By_Protected_Procedure
,
15786 -- Extract the name of the local procedure
15788 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15790 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15791 -- primitive procedure of a synchronized tagged type.
15793 if Ekind
(Proc_Id
) = E_Procedure
15794 and then Is_Primitive
(Proc_Id
)
15795 and then Present
(First_Formal
(Proc_Id
))
15797 Typ
:= Etype
(First_Formal
(Proc_Id
));
15799 if Is_Tagged_Type
(Typ
)
15802 -- Check for a protected, a synchronized or a task interface
15804 ((Is_Interface
(Typ
)
15805 and then Is_Synchronized_Interface
(Typ
))
15807 -- Check for a protected type or a task type that implements
15811 (Is_Concurrent_Record_Type
(Typ
)
15812 and then Present
(Interfaces
(Typ
)))
15814 -- In analysis-only mode, examine original protected type
15817 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
15818 and then Present
(Interface_List
(Parent
(Typ
))))
15820 -- Check for a private record extension with keyword
15824 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
15825 E_Record_Subtype_With_Private
)
15826 and then Synchronized_Present
(Parent
(Typ
))))
15831 ("controlling formal must be of synchronized tagged type",
15836 -- Procedures declared inside a protected type must be accepted
15838 elsif Ekind
(Proc_Id
) = E_Procedure
15839 and then Is_Protected_Type
(Scope
(Proc_Id
))
15843 -- The first argument is not a primitive procedure
15847 ("pragma % must be applied to a primitive procedure", Arg1
);
15851 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
15852 -- By_Protected_Procedure to the primitive procedure of a task
15855 if Chars
(Arg2
) = Name_By_Protected_Procedure
15856 and then Is_Interface
(Typ
)
15857 and then Is_Task_Interface
(Typ
)
15860 ("implementation kind By_Protected_Procedure cannot be "
15861 & "applied to a task interface primitive", Arg2
);
15865 Record_Rep_Item
(Proc_Id
, N
);
15868 ----------------------
15869 -- Implicit_Packing --
15870 ----------------------
15872 -- pragma Implicit_Packing;
15874 when Pragma_Implicit_Packing
=>
15876 Check_Arg_Count
(0);
15877 Implicit_Packing
:= True;
15884 -- [Convention =>] convention_IDENTIFIER,
15885 -- [Entity =>] LOCAL_NAME
15886 -- [, [External_Name =>] static_string_EXPRESSION ]
15887 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15889 when Pragma_Import
=>
15890 Check_Ada_83_Warning
;
15894 Name_External_Name
,
15897 Check_At_Least_N_Arguments
(2);
15898 Check_At_Most_N_Arguments
(4);
15899 Process_Import_Or_Interface
;
15901 ---------------------
15902 -- Import_Function --
15903 ---------------------
15905 -- pragma Import_Function (
15906 -- [Internal =>] LOCAL_NAME,
15907 -- [, [External =>] EXTERNAL_SYMBOL]
15908 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15909 -- [, [Result_Type =>] SUBTYPE_MARK]
15910 -- [, [Mechanism =>] MECHANISM]
15911 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
15913 -- EXTERNAL_SYMBOL ::=
15915 -- | static_string_EXPRESSION
15917 -- PARAMETER_TYPES ::=
15919 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15921 -- TYPE_DESIGNATOR ::=
15923 -- | subtype_Name ' Access
15927 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15929 -- MECHANISM_ASSOCIATION ::=
15930 -- [formal_parameter_NAME =>] MECHANISM_NAME
15932 -- MECHANISM_NAME ::=
15936 when Pragma_Import_Function
=> Import_Function
: declare
15937 Args
: Args_List
(1 .. 6);
15938 Names
: constant Name_List
(1 .. 6) := (
15941 Name_Parameter_Types
,
15944 Name_Result_Mechanism
);
15946 Internal
: Node_Id
renames Args
(1);
15947 External
: Node_Id
renames Args
(2);
15948 Parameter_Types
: Node_Id
renames Args
(3);
15949 Result_Type
: Node_Id
renames Args
(4);
15950 Mechanism
: Node_Id
renames Args
(5);
15951 Result_Mechanism
: Node_Id
renames Args
(6);
15955 Gather_Associations
(Names
, Args
);
15956 Process_Extended_Import_Export_Subprogram_Pragma
(
15957 Arg_Internal
=> Internal
,
15958 Arg_External
=> External
,
15959 Arg_Parameter_Types
=> Parameter_Types
,
15960 Arg_Result_Type
=> Result_Type
,
15961 Arg_Mechanism
=> Mechanism
,
15962 Arg_Result_Mechanism
=> Result_Mechanism
);
15963 end Import_Function
;
15965 -------------------
15966 -- Import_Object --
15967 -------------------
15969 -- pragma Import_Object (
15970 -- [Internal =>] LOCAL_NAME
15971 -- [, [External =>] EXTERNAL_SYMBOL]
15972 -- [, [Size =>] EXTERNAL_SYMBOL]);
15974 -- EXTERNAL_SYMBOL ::=
15976 -- | static_string_EXPRESSION
15978 when Pragma_Import_Object
=> Import_Object
: declare
15979 Args
: Args_List
(1 .. 3);
15980 Names
: constant Name_List
(1 .. 3) := (
15985 Internal
: Node_Id
renames Args
(1);
15986 External
: Node_Id
renames Args
(2);
15987 Size
: Node_Id
renames Args
(3);
15991 Gather_Associations
(Names
, Args
);
15992 Process_Extended_Import_Export_Object_Pragma
(
15993 Arg_Internal
=> Internal
,
15994 Arg_External
=> External
,
15998 ----------------------
15999 -- Import_Procedure --
16000 ----------------------
16002 -- pragma Import_Procedure (
16003 -- [Internal =>] LOCAL_NAME
16004 -- [, [External =>] EXTERNAL_SYMBOL]
16005 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16006 -- [, [Mechanism =>] MECHANISM]);
16008 -- EXTERNAL_SYMBOL ::=
16010 -- | static_string_EXPRESSION
16012 -- PARAMETER_TYPES ::=
16014 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16016 -- TYPE_DESIGNATOR ::=
16018 -- | subtype_Name ' Access
16022 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16024 -- MECHANISM_ASSOCIATION ::=
16025 -- [formal_parameter_NAME =>] MECHANISM_NAME
16027 -- MECHANISM_NAME ::=
16031 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16032 Args
: Args_List
(1 .. 4);
16033 Names
: constant Name_List
(1 .. 4) := (
16036 Name_Parameter_Types
,
16039 Internal
: Node_Id
renames Args
(1);
16040 External
: Node_Id
renames Args
(2);
16041 Parameter_Types
: Node_Id
renames Args
(3);
16042 Mechanism
: Node_Id
renames Args
(4);
16046 Gather_Associations
(Names
, Args
);
16047 Process_Extended_Import_Export_Subprogram_Pragma
(
16048 Arg_Internal
=> Internal
,
16049 Arg_External
=> External
,
16050 Arg_Parameter_Types
=> Parameter_Types
,
16051 Arg_Mechanism
=> Mechanism
);
16052 end Import_Procedure
;
16054 -----------------------------
16055 -- Import_Valued_Procedure --
16056 -----------------------------
16058 -- pragma Import_Valued_Procedure (
16059 -- [Internal =>] LOCAL_NAME
16060 -- [, [External =>] EXTERNAL_SYMBOL]
16061 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16062 -- [, [Mechanism =>] MECHANISM]);
16064 -- EXTERNAL_SYMBOL ::=
16066 -- | static_string_EXPRESSION
16068 -- PARAMETER_TYPES ::=
16070 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16072 -- TYPE_DESIGNATOR ::=
16074 -- | subtype_Name ' Access
16078 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16080 -- MECHANISM_ASSOCIATION ::=
16081 -- [formal_parameter_NAME =>] MECHANISM_NAME
16083 -- MECHANISM_NAME ::=
16087 when Pragma_Import_Valued_Procedure
=>
16088 Import_Valued_Procedure
: declare
16089 Args
: Args_List
(1 .. 4);
16090 Names
: constant Name_List
(1 .. 4) := (
16093 Name_Parameter_Types
,
16096 Internal
: Node_Id
renames Args
(1);
16097 External
: Node_Id
renames Args
(2);
16098 Parameter_Types
: Node_Id
renames Args
(3);
16099 Mechanism
: Node_Id
renames Args
(4);
16103 Gather_Associations
(Names
, Args
);
16104 Process_Extended_Import_Export_Subprogram_Pragma
(
16105 Arg_Internal
=> Internal
,
16106 Arg_External
=> External
,
16107 Arg_Parameter_Types
=> Parameter_Types
,
16108 Arg_Mechanism
=> Mechanism
);
16109 end Import_Valued_Procedure
;
16115 -- pragma Independent (LOCAL_NAME);
16117 when Pragma_Independent
=>
16118 Process_Atomic_Independent_Shared_Volatile
;
16120 ----------------------------
16121 -- Independent_Components --
16122 ----------------------------
16124 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16126 when Pragma_Independent_Components
=> Independent_Components
: declare
16134 Check_Ada_83_Warning
;
16136 Check_No_Identifiers
;
16137 Check_Arg_Count
(1);
16138 Check_Arg_Is_Local_Name
(Arg1
);
16139 E_Id
:= Get_Pragma_Arg
(Arg1
);
16141 if Etype
(E_Id
) = Any_Type
then
16145 E
:= Entity
(E_Id
);
16147 -- A pragma that applies to a Ghost entity becomes Ghost for the
16148 -- purposes of legality checks and removal of ignored Ghost code.
16150 Mark_Ghost_Pragma
(N
, E
);
16152 -- Check duplicate before we chain ourselves
16154 Check_Duplicate_Pragma
(E
);
16156 -- Check appropriate entity
16158 if Rep_Item_Too_Early
(E
, N
)
16160 Rep_Item_Too_Late
(E
, N
)
16165 D
:= Declaration_Node
(E
);
16168 -- The flag is set on the base type, or on the object
16170 if K
= N_Full_Type_Declaration
16171 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16173 Set_Has_Independent_Components
(Base_Type
(E
));
16174 Record_Independence_Check
(N
, Base_Type
(E
));
16176 -- For record type, set all components independent
16178 if Is_Record_Type
(E
) then
16179 C
:= First_Component
(E
);
16180 while Present
(C
) loop
16181 Set_Is_Independent
(C
);
16182 Next_Component
(C
);
16186 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16187 and then Nkind
(D
) = N_Object_Declaration
16188 and then Nkind
(Object_Definition
(D
)) =
16189 N_Constrained_Array_Definition
16191 Set_Has_Independent_Components
(E
);
16192 Record_Independence_Check
(N
, E
);
16195 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16197 end Independent_Components
;
16199 -----------------------
16200 -- Initial_Condition --
16201 -----------------------
16203 -- pragma Initial_Condition (boolean_EXPRESSION);
16205 -- Characteristics:
16207 -- * Analysis - The annotation undergoes initial checks to verify
16208 -- the legal placement and context. Secondary checks preanalyze the
16211 -- Analyze_Initial_Condition_In_Decl_Part
16213 -- * Expansion - The annotation is expanded during the expansion of
16214 -- the package body whose declaration is subject to the annotation
16217 -- Expand_Pragma_Initial_Condition
16219 -- * Template - The annotation utilizes the generic template of the
16220 -- related package declaration.
16222 -- * Globals - Capture of global references must occur after full
16225 -- * Instance - The annotation is instantiated automatically when
16226 -- the related generic package is instantiated.
16228 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16229 Pack_Decl
: Node_Id
;
16230 Pack_Id
: Entity_Id
;
16234 Check_No_Identifiers
;
16235 Check_Arg_Count
(1);
16237 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16239 -- Ensure the proper placement of the pragma. Initial_Condition
16240 -- must be associated with a package declaration.
16242 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16243 N_Package_Declaration
)
16247 -- Otherwise the pragma is associated with an illegal context
16254 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16256 -- A pragma that applies to a Ghost entity becomes Ghost for the
16257 -- purposes of legality checks and removal of ignored Ghost code.
16259 Mark_Ghost_Pragma
(N
, Pack_Id
);
16261 -- Chain the pragma on the contract for further processing by
16262 -- Analyze_Initial_Condition_In_Decl_Part.
16264 Add_Contract_Item
(N
, Pack_Id
);
16266 -- The legality checks of pragmas Abstract_State, Initializes, and
16267 -- Initial_Condition are affected by the SPARK mode in effect. In
16268 -- addition, these three pragmas are subject to an inherent order:
16270 -- 1) Abstract_State
16272 -- 3) Initial_Condition
16274 -- Analyze all these pragmas in the order outlined above
16276 Analyze_If_Present
(Pragma_SPARK_Mode
);
16277 Analyze_If_Present
(Pragma_Abstract_State
);
16278 Analyze_If_Present
(Pragma_Initializes
);
16279 end Initial_Condition
;
16281 ------------------------
16282 -- Initialize_Scalars --
16283 ------------------------
16285 -- pragma Initialize_Scalars;
16287 when Pragma_Initialize_Scalars
=>
16289 Check_Arg_Count
(0);
16290 Check_Valid_Configuration_Pragma
;
16291 Check_Restriction
(No_Initialize_Scalars
, N
);
16293 -- Initialize_Scalars creates false positives in CodePeer, and
16294 -- incorrect negative results in GNATprove mode, so ignore this
16295 -- pragma in these modes.
16297 if not Restriction_Active
(No_Initialize_Scalars
)
16298 and then not (CodePeer_Mode
or GNATprove_Mode
)
16300 Init_Or_Norm_Scalars
:= True;
16301 Initialize_Scalars
:= True;
16308 -- pragma Initializes (INITIALIZATION_LIST);
16310 -- INITIALIZATION_LIST ::=
16312 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16314 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16319 -- | (INPUT {, INPUT})
16323 -- Characteristics:
16325 -- * Analysis - The annotation undergoes initial checks to verify
16326 -- the legal placement and context. Secondary checks preanalyze the
16329 -- Analyze_Initializes_In_Decl_Part
16331 -- * Expansion - None.
16333 -- * Template - The annotation utilizes the generic template of the
16334 -- related package declaration.
16336 -- * Globals - Capture of global references must occur after full
16339 -- * Instance - The annotation is instantiated automatically when
16340 -- the related generic package is instantiated.
16342 when Pragma_Initializes
=> Initializes
: declare
16343 Pack_Decl
: Node_Id
;
16344 Pack_Id
: Entity_Id
;
16348 Check_No_Identifiers
;
16349 Check_Arg_Count
(1);
16351 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16353 -- Ensure the proper placement of the pragma. Initializes must be
16354 -- associated with a package declaration.
16356 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16357 N_Package_Declaration
)
16361 -- Otherwise the pragma is associated with an illegal construc
16368 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16370 -- A pragma that applies to a Ghost entity becomes Ghost for the
16371 -- purposes of legality checks and removal of ignored Ghost code.
16373 Mark_Ghost_Pragma
(N
, Pack_Id
);
16374 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
16376 -- Chain the pragma on the contract for further processing by
16377 -- Analyze_Initializes_In_Decl_Part.
16379 Add_Contract_Item
(N
, Pack_Id
);
16381 -- The legality checks of pragmas Abstract_State, Initializes, and
16382 -- Initial_Condition are affected by the SPARK mode in effect. In
16383 -- addition, these three pragmas are subject to an inherent order:
16385 -- 1) Abstract_State
16387 -- 3) Initial_Condition
16389 -- Analyze all these pragmas in the order outlined above
16391 Analyze_If_Present
(Pragma_SPARK_Mode
);
16392 Analyze_If_Present
(Pragma_Abstract_State
);
16393 Analyze_If_Present
(Pragma_Initial_Condition
);
16400 -- pragma Inline ( NAME {, NAME} );
16402 when Pragma_Inline
=>
16404 -- Pragma always active unless in GNATprove mode. It is disabled
16405 -- in GNATprove mode because frontend inlining is applied
16406 -- independently of pragmas Inline and Inline_Always for
16407 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16410 if not GNATprove_Mode
then
16412 -- Inline status is Enabled if option -gnatn is specified.
16413 -- However this status determines only the value of the
16414 -- Is_Inlined flag on the subprogram and does not prevent
16415 -- the pragma itself from being recorded for later use,
16416 -- in particular for a later modification of Is_Inlined
16417 -- independently of the -gnatn option.
16419 -- In other words, if -gnatn is specified for a unit, then
16420 -- all Inline pragmas processed for the compilation of this
16421 -- unit, including those in the spec of other units, are
16422 -- activated, so subprograms will be inlined across units.
16424 -- If -gnatn is not specified, no Inline pragma is activated
16425 -- here, which means that subprograms will not be inlined
16426 -- across units. The Is_Inlined flag will nevertheless be
16427 -- set later when bodies are analyzed, so subprograms will
16428 -- be inlined within the unit.
16430 if Inline_Active
then
16431 Process_Inline
(Enabled
);
16433 Process_Inline
(Disabled
);
16437 -------------------
16438 -- Inline_Always --
16439 -------------------
16441 -- pragma Inline_Always ( NAME {, NAME} );
16443 when Pragma_Inline_Always
=>
16446 -- Pragma always active unless in CodePeer mode or GNATprove
16447 -- mode. It is disabled in CodePeer mode because inlining is
16448 -- not helpful, and enabling it caused walk order issues. It
16449 -- is disabled in GNATprove mode because frontend inlining is
16450 -- applied independently of pragmas Inline and Inline_Always for
16451 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16454 if not CodePeer_Mode
and not GNATprove_Mode
then
16455 Process_Inline
(Enabled
);
16458 --------------------
16459 -- Inline_Generic --
16460 --------------------
16462 -- pragma Inline_Generic (NAME {, NAME});
16464 when Pragma_Inline_Generic
=>
16466 Process_Generic_List
;
16468 ----------------------
16469 -- Inspection_Point --
16470 ----------------------
16472 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16474 when Pragma_Inspection_Point
=> Inspection_Point
: declare
16481 if Arg_Count
> 0 then
16484 Exp
:= Get_Pragma_Arg
(Arg
);
16487 if not Is_Entity_Name
(Exp
)
16488 or else not Is_Object
(Entity
(Exp
))
16490 Error_Pragma_Arg
("object name required", Arg
);
16494 exit when No
(Arg
);
16497 end Inspection_Point
;
16503 -- pragma Interface (
16504 -- [ Convention =>] convention_IDENTIFIER,
16505 -- [ Entity =>] LOCAL_NAME
16506 -- [, [External_Name =>] static_string_EXPRESSION ]
16507 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16509 when Pragma_Interface
=>
16514 Name_External_Name
,
16516 Check_At_Least_N_Arguments
(2);
16517 Check_At_Most_N_Arguments
(4);
16518 Process_Import_Or_Interface
;
16520 -- In Ada 2005, the permission to use Interface (a reserved word)
16521 -- as a pragma name is considered an obsolescent feature, and this
16522 -- pragma was already obsolescent in Ada 95.
16524 if Ada_Version
>= Ada_95
then
16526 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16528 if Warn_On_Obsolescent_Feature
then
16530 ("pragma Interface is an obsolescent feature?j?", N
);
16532 ("|use pragma Import instead?j?", N
);
16536 --------------------
16537 -- Interface_Name --
16538 --------------------
16540 -- pragma Interface_Name (
16541 -- [ Entity =>] LOCAL_NAME
16542 -- [,[External_Name =>] static_string_EXPRESSION ]
16543 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16545 when Pragma_Interface_Name
=> Interface_Name
: declare
16547 Def_Id
: Entity_Id
;
16548 Hom_Id
: Entity_Id
;
16554 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
16555 Check_At_Least_N_Arguments
(2);
16556 Check_At_Most_N_Arguments
(3);
16557 Id
:= Get_Pragma_Arg
(Arg1
);
16560 -- This is obsolete from Ada 95 on, but it is an implementation
16561 -- defined pragma, so we do not consider that it violates the
16562 -- restriction (No_Obsolescent_Features).
16564 if Ada_Version
>= Ada_95
then
16565 if Warn_On_Obsolescent_Feature
then
16567 ("pragma Interface_Name is an obsolescent feature?j?", N
);
16569 ("|use pragma Import instead?j?", N
);
16573 if not Is_Entity_Name
(Id
) then
16575 ("first argument for pragma% must be entity name", Arg1
);
16576 elsif Etype
(Id
) = Any_Type
then
16579 Def_Id
:= Entity
(Id
);
16582 -- Special DEC-compatible processing for the object case, forces
16583 -- object to be imported.
16585 if Ekind
(Def_Id
) = E_Variable
then
16586 Kill_Size_Check_Code
(Def_Id
);
16587 Note_Possible_Modification
(Id
, Sure
=> False);
16589 -- Initialization is not allowed for imported variable
16591 if Present
(Expression
(Parent
(Def_Id
)))
16592 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
16594 Error_Msg_Sloc
:= Sloc
(Def_Id
);
16596 ("no initialization allowed for declaration of& #",
16600 -- For compatibility, support VADS usage of providing both
16601 -- pragmas Interface and Interface_Name to obtain the effect
16602 -- of a single Import pragma.
16604 if Is_Imported
(Def_Id
)
16605 and then Present
(First_Rep_Item
(Def_Id
))
16606 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
16607 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
16612 Set_Imported
(Def_Id
);
16615 Set_Is_Public
(Def_Id
);
16616 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16619 -- Otherwise must be subprogram
16621 elsif not Is_Subprogram
(Def_Id
) then
16623 ("argument of pragma% is not subprogram", Arg1
);
16626 Check_At_Most_N_Arguments
(3);
16630 -- Loop through homonyms
16633 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
16635 if Is_Imported
(Def_Id
) then
16636 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
);
16640 exit when From_Aspect_Specification
(N
);
16641 Hom_Id
:= Homonym
(Hom_Id
);
16643 exit when No
(Hom_Id
)
16644 or else Scope
(Hom_Id
) /= Current_Scope
;
16649 ("argument of pragma% is not imported subprogram",
16653 end Interface_Name
;
16655 -----------------------
16656 -- Interrupt_Handler --
16657 -----------------------
16659 -- pragma Interrupt_Handler (handler_NAME);
16661 when Pragma_Interrupt_Handler
=>
16662 Check_Ada_83_Warning
;
16663 Check_Arg_Count
(1);
16664 Check_No_Identifiers
;
16666 if No_Run_Time_Mode
then
16667 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
16669 Check_Interrupt_Or_Attach_Handler
;
16670 Process_Interrupt_Or_Attach_Handler
;
16673 ------------------------
16674 -- Interrupt_Priority --
16675 ------------------------
16677 -- pragma Interrupt_Priority [(EXPRESSION)];
16679 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
16680 P
: constant Node_Id
:= Parent
(N
);
16685 Check_Ada_83_Warning
;
16687 if Arg_Count
/= 0 then
16688 Arg
:= Get_Pragma_Arg
(Arg1
);
16689 Check_Arg_Count
(1);
16690 Check_No_Identifiers
;
16692 -- The expression must be analyzed in the special manner
16693 -- described in "Handling of Default and Per-Object
16694 -- Expressions" in sem.ads.
16696 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
16699 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
16704 Ent
:= Defining_Identifier
(Parent
(P
));
16706 -- Check duplicate pragma before we chain the pragma in the Rep
16707 -- Item chain of Ent.
16709 Check_Duplicate_Pragma
(Ent
);
16710 Record_Rep_Item
(Ent
, N
);
16712 -- Check the No_Task_At_Interrupt_Priority restriction
16714 if Nkind
(P
) = N_Task_Definition
then
16715 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16718 end Interrupt_Priority
;
16720 ---------------------
16721 -- Interrupt_State --
16722 ---------------------
16724 -- pragma Interrupt_State (
16725 -- [Name =>] INTERRUPT_ID,
16726 -- [State =>] INTERRUPT_STATE);
16728 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16729 -- INTERRUPT_STATE => System | Runtime | User
16731 -- Note: if the interrupt id is given as an identifier, then it must
16732 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16733 -- given as a static integer expression which must be in the range of
16734 -- Ada.Interrupts.Interrupt_ID.
16736 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16737 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16738 -- This is the entity Ada.Interrupts.Interrupt_ID;
16740 State_Type
: Character;
16741 -- Set to 's'/'r'/'u' for System/Runtime/User
16744 -- Index to entry in Interrupt_States table
16747 -- Value of interrupt
16749 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16750 -- The first argument to the pragma
16752 Int_Ent
: Entity_Id
;
16753 -- Interrupt entity in Ada.Interrupts.Names
16757 Check_Arg_Order
((Name_Name
, Name_State
));
16758 Check_Arg_Count
(2);
16760 Check_Optional_Identifier
(Arg1
, Name_Name
);
16761 Check_Optional_Identifier
(Arg2
, Name_State
);
16762 Check_Arg_Is_Identifier
(Arg2
);
16764 -- First argument is identifier
16766 if Nkind
(Arg1X
) = N_Identifier
then
16768 -- Search list of names in Ada.Interrupts.Names
16770 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16772 if No
(Int_Ent
) then
16773 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16775 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16776 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16780 Next_Entity
(Int_Ent
);
16783 -- First argument is not an identifier, so it must be a static
16784 -- expression of type Ada.Interrupts.Interrupt_ID.
16787 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16788 Int_Val
:= Expr_Value
(Arg1X
);
16790 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16792 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
16795 ("value not in range of type "
16796 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
16802 case Chars
(Get_Pragma_Arg
(Arg2
)) is
16803 when Name_Runtime
=> State_Type
:= 'r';
16804 when Name_System
=> State_Type
:= 's';
16805 when Name_User
=> State_Type
:= 'u';
16808 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
16811 -- Check if entry is already stored
16813 IST_Num
:= Interrupt_States
.First
;
16815 -- If entry not found, add it
16817 if IST_Num
> Interrupt_States
.Last
then
16818 Interrupt_States
.Append
16819 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
16820 Interrupt_State
=> State_Type
,
16821 Pragma_Loc
=> Loc
));
16824 -- Case of entry for the same entry
16826 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
16829 -- If state matches, done, no need to make redundant entry
16832 State_Type
= Interrupt_States
.Table
(IST_Num
).
16835 -- Otherwise if state does not match, error
16838 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
16840 ("state conflicts with that given #", Arg2
);
16844 IST_Num
:= IST_Num
+ 1;
16846 end Interrupt_State
;
16852 -- pragma Invariant
16853 -- ([Entity =>] type_LOCAL_NAME,
16854 -- [Check =>] EXPRESSION
16855 -- [,[Message =>] String_Expression]);
16857 when Pragma_Invariant
=> Invariant
: declare
16864 Check_At_Least_N_Arguments
(2);
16865 Check_At_Most_N_Arguments
(3);
16866 Check_Optional_Identifier
(Arg1
, Name_Entity
);
16867 Check_Optional_Identifier
(Arg2
, Name_Check
);
16869 if Arg_Count
= 3 then
16870 Check_Optional_Identifier
(Arg3
, Name_Message
);
16871 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
16874 Check_Arg_Is_Local_Name
(Arg1
);
16876 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
16877 Find_Type
(Typ_Arg
);
16878 Typ
:= Entity
(Typ_Arg
);
16880 -- Nothing to do of the related type is erroneous in some way
16882 if Typ
= Any_Type
then
16885 -- AI12-0041: Invariants are allowed in interface types
16887 elsif Is_Interface
(Typ
) then
16890 -- An invariant must apply to a private type, or appear in the
16891 -- private part of a package spec and apply to a completion.
16892 -- a class-wide invariant can only appear on a private declaration
16893 -- or private extension, not a completion.
16895 -- A [class-wide] invariant may be associated a [limited] private
16896 -- type or a private extension.
16898 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
16900 E_Record_Type_With_Private
)
16904 -- A non-class-wide invariant may be associated with the full view
16905 -- of a [limited] private type or a private extension.
16907 elsif Has_Private_Declaration
(Typ
)
16908 and then not Class_Present
(N
)
16912 -- A class-wide invariant may appear on the partial view only
16914 elsif Class_Present
(N
) then
16916 ("pragma % only allowed for private type", Arg1
);
16919 -- A regular invariant may appear on both views
16923 ("pragma % only allowed for private type or corresponding "
16924 & "full view", Arg1
);
16928 -- An invariant associated with an abstract type (this includes
16929 -- interfaces) must be class-wide.
16931 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
16933 ("pragma % not allowed for abstract type", Arg1
);
16937 -- A pragma that applies to a Ghost entity becomes Ghost for the
16938 -- purposes of legality checks and removal of ignored Ghost code.
16940 Mark_Ghost_Pragma
(N
, Typ
);
16942 -- The pragma defines a type-specific invariant, the type is said
16943 -- to have invariants of its "own".
16945 Set_Has_Own_Invariants
(Typ
);
16947 -- If the invariant is class-wide, then it can be inherited by
16948 -- derived or interface implementing types. The type is said to
16949 -- have "inheritable" invariants.
16951 if Class_Present
(N
) then
16952 Set_Has_Inheritable_Invariants
(Typ
);
16955 -- Chain the pragma on to the rep item chain, for processing when
16956 -- the type is frozen.
16958 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
16960 -- Create the declaration of the invariant procedure which will
16961 -- verify the invariant at run-time. Note that interfaces do not
16962 -- carry such a declaration.
16964 Build_Invariant_Procedure_Declaration
(Typ
);
16971 -- pragma Keep_Names ([On => ] LOCAL_NAME);
16973 when Pragma_Keep_Names
=> Keep_Names
: declare
16978 Check_Arg_Count
(1);
16979 Check_Optional_Identifier
(Arg1
, Name_On
);
16980 Check_Arg_Is_Local_Name
(Arg1
);
16982 Arg
:= Get_Pragma_Arg
(Arg1
);
16985 if Etype
(Arg
) = Any_Type
then
16989 if not Is_Entity_Name
(Arg
)
16990 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
16993 ("pragma% requires a local enumeration type", Arg1
);
16996 Set_Discard_Names
(Entity
(Arg
), False);
17003 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17005 when Pragma_License
=>
17008 -- Do not analyze pragma any further in CodePeer mode, to avoid
17009 -- extraneous errors in this implementation-dependent pragma,
17010 -- which has a different profile on other compilers.
17012 if CodePeer_Mode
then
17016 Check_Arg_Count
(1);
17017 Check_No_Identifiers
;
17018 Check_Valid_Configuration_Pragma
;
17019 Check_Arg_Is_Identifier
(Arg1
);
17022 Sind
: constant Source_File_Index
:=
17023 Source_Index
(Current_Sem_Unit
);
17026 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17028 Set_License
(Sind
, GPL
);
17030 when Name_Modified_GPL
=>
17031 Set_License
(Sind
, Modified_GPL
);
17033 when Name_Restricted
=>
17034 Set_License
(Sind
, Restricted
);
17036 when Name_Unrestricted
=>
17037 Set_License
(Sind
, Unrestricted
);
17040 Error_Pragma_Arg
("invalid license name", Arg1
);
17048 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17050 when Pragma_Link_With
=> Link_With
: declare
17056 if Operating_Mode
= Generate_Code
17057 and then In_Extended_Main_Source_Unit
(N
)
17059 Check_At_Least_N_Arguments
(1);
17060 Check_No_Identifiers
;
17061 Check_Is_In_Decl_Part_Or_Package_Spec
;
17062 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17066 while Present
(Arg
) loop
17067 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17069 -- Store argument, converting sequences of spaces to a
17070 -- single null character (this is one of the differences
17071 -- in processing between Link_With and Linker_Options).
17073 Arg_Store
: declare
17074 C
: constant Char_Code
:= Get_Char_Code
(' ');
17075 S
: constant String_Id
:=
17076 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17077 L
: constant Nat
:= String_Length
(S
);
17080 procedure Skip_Spaces
;
17081 -- Advance F past any spaces
17087 procedure Skip_Spaces
is
17089 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17094 -- Start of processing for Arg_Store
17097 Skip_Spaces
; -- skip leading spaces
17099 -- Loop through characters, changing any embedded
17100 -- sequence of spaces to a single null character (this
17101 -- is how Link_With/Linker_Options differ)
17104 if Get_String_Char
(S
, F
) = C
then
17107 Store_String_Char
(ASCII
.NUL
);
17110 Store_String_Char
(Get_String_Char
(S
, F
));
17118 if Present
(Arg
) then
17119 Store_String_Char
(ASCII
.NUL
);
17123 Store_Linker_Option_String
(End_String
);
17131 -- pragma Linker_Alias (
17132 -- [Entity =>] LOCAL_NAME
17133 -- [Target =>] static_string_EXPRESSION);
17135 when Pragma_Linker_Alias
=>
17137 Check_Arg_Order
((Name_Entity
, Name_Target
));
17138 Check_Arg_Count
(2);
17139 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17140 Check_Optional_Identifier
(Arg2
, Name_Target
);
17141 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17142 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17144 -- The only processing required is to link this item on to the
17145 -- list of rep items for the given entity. This is accomplished
17146 -- by the call to Rep_Item_Too_Late (when no error is detected
17147 -- and False is returned).
17149 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17152 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17155 ------------------------
17156 -- Linker_Constructor --
17157 ------------------------
17159 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17161 -- Code is shared with Linker_Destructor
17163 -----------------------
17164 -- Linker_Destructor --
17165 -----------------------
17167 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17169 when Pragma_Linker_Constructor
17170 | Pragma_Linker_Destructor
17172 Linker_Constructor
: declare
17178 Check_Arg_Count
(1);
17179 Check_No_Identifiers
;
17180 Check_Arg_Is_Local_Name
(Arg1
);
17181 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17183 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17185 if not Is_Library_Level_Entity
(Proc
) then
17187 ("argument for pragma% must be library level entity", Arg1
);
17190 -- The only processing required is to link this item on to the
17191 -- list of rep items for the given entity. This is accomplished
17192 -- by the call to Rep_Item_Too_Late (when no error is detected
17193 -- and False is returned).
17195 if Rep_Item_Too_Late
(Proc
, N
) then
17198 Set_Has_Gigi_Rep_Item
(Proc
);
17200 end Linker_Constructor
;
17202 --------------------
17203 -- Linker_Options --
17204 --------------------
17206 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17208 when Pragma_Linker_Options
=> Linker_Options
: declare
17212 Check_Ada_83_Warning
;
17213 Check_No_Identifiers
;
17214 Check_Arg_Count
(1);
17215 Check_Is_In_Decl_Part_Or_Package_Spec
;
17216 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17217 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17220 while Present
(Arg
) loop
17221 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17222 Store_String_Char
(ASCII
.NUL
);
17224 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17228 if Operating_Mode
= Generate_Code
17229 and then In_Extended_Main_Source_Unit
(N
)
17231 Store_Linker_Option_String
(End_String
);
17233 end Linker_Options
;
17235 --------------------
17236 -- Linker_Section --
17237 --------------------
17239 -- pragma Linker_Section (
17240 -- [Entity =>] LOCAL_NAME
17241 -- [Section =>] static_string_EXPRESSION);
17243 when Pragma_Linker_Section
=> Linker_Section
: declare
17248 Ghost_Error_Posted
: Boolean := False;
17249 -- Flag set when an error concerning the illegal mix of Ghost and
17250 -- non-Ghost subprograms is emitted.
17252 Ghost_Id
: Entity_Id
:= Empty
;
17253 -- The entity of the first Ghost subprogram encountered while
17254 -- processing the arguments of the pragma.
17258 Check_Arg_Order
((Name_Entity
, Name_Section
));
17259 Check_Arg_Count
(2);
17260 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17261 Check_Optional_Identifier
(Arg2
, Name_Section
);
17262 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17263 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17265 -- Check kind of entity
17267 Arg
:= Get_Pragma_Arg
(Arg1
);
17268 Ent
:= Entity
(Arg
);
17270 case Ekind
(Ent
) is
17272 -- Objects (constants and variables) and types. For these cases
17273 -- all we need to do is to set the Linker_Section_pragma field,
17274 -- checking that we do not have a duplicate.
17280 LPE
:= Linker_Section_Pragma
(Ent
);
17282 if Present
(LPE
) then
17283 Error_Msg_Sloc
:= Sloc
(LPE
);
17285 ("Linker_Section already specified for &#", Arg1
, Ent
);
17288 Set_Linker_Section_Pragma
(Ent
, N
);
17290 -- A pragma that applies to a Ghost entity becomes Ghost for
17291 -- the purposes of legality checks and removal of ignored
17294 Mark_Ghost_Pragma
(N
, Ent
);
17298 when Subprogram_Kind
=>
17300 -- Aspect case, entity already set
17302 if From_Aspect_Specification
(N
) then
17303 Set_Linker_Section_Pragma
17304 (Entity
(Corresponding_Aspect
(N
)), N
);
17306 -- Pragma case, we must climb the homonym chain, but skip
17307 -- any for which the linker section is already set.
17311 if No
(Linker_Section_Pragma
(Ent
)) then
17312 Set_Linker_Section_Pragma
(Ent
, N
);
17314 -- A pragma that applies to a Ghost entity becomes
17315 -- Ghost for the purposes of legality checks and
17316 -- removal of ignored Ghost code.
17318 Mark_Ghost_Pragma
(N
, Ent
);
17320 -- Capture the entity of the first Ghost subprogram
17321 -- being processed for error detection purposes.
17323 if Is_Ghost_Entity
(Ent
) then
17324 if No
(Ghost_Id
) then
17328 -- Otherwise the subprogram is non-Ghost. It is
17329 -- illegal to mix references to Ghost and non-Ghost
17330 -- entities (SPARK RM 6.9).
17332 elsif Present
(Ghost_Id
)
17333 and then not Ghost_Error_Posted
17335 Ghost_Error_Posted
:= True;
17337 Error_Msg_Name_1
:= Pname
;
17339 ("pragma % cannot mention ghost and "
17340 & "non-ghost subprograms", N
);
17342 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17344 ("\& # declared as ghost", N
, Ghost_Id
);
17346 Error_Msg_Sloc
:= Sloc
(Ent
);
17348 ("\& # declared as non-ghost", N
, Ent
);
17352 Ent
:= Homonym
(Ent
);
17354 or else Scope
(Ent
) /= Current_Scope
;
17358 -- All other cases are illegal
17362 ("pragma% applies only to objects, subprograms, and types",
17365 end Linker_Section
;
17371 -- pragma List (On | Off)
17373 -- There is nothing to do here, since we did all the processing for
17374 -- this pragma in Par.Prag (so that it works properly even in syntax
17377 when Pragma_List
=>
17384 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17386 when Pragma_Lock_Free
=> Lock_Free
: declare
17387 P
: constant Node_Id
:= Parent
(N
);
17393 Check_No_Identifiers
;
17394 Check_At_Most_N_Arguments
(1);
17396 -- Protected definition case
17398 if Nkind
(P
) = N_Protected_Definition
then
17399 Ent
:= Defining_Identifier
(Parent
(P
));
17403 if Arg_Count
= 1 then
17404 Arg
:= Get_Pragma_Arg
(Arg1
);
17405 Val
:= Is_True
(Static_Boolean
(Arg
));
17407 -- No arguments (expression is considered to be True)
17413 -- Check duplicate pragma before we chain the pragma in the Rep
17414 -- Item chain of Ent.
17416 Check_Duplicate_Pragma
(Ent
);
17417 Record_Rep_Item
(Ent
, N
);
17418 Set_Uses_Lock_Free
(Ent
, Val
);
17420 -- Anything else is incorrect placement
17427 --------------------
17428 -- Locking_Policy --
17429 --------------------
17431 -- pragma Locking_Policy (policy_IDENTIFIER);
17433 when Pragma_Locking_Policy
=> declare
17434 subtype LP_Range
is Name_Id
17435 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
17440 Check_Ada_83_Warning
;
17441 Check_Arg_Count
(1);
17442 Check_No_Identifiers
;
17443 Check_Arg_Is_Locking_Policy
(Arg1
);
17444 Check_Valid_Configuration_Pragma
;
17445 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17448 when Name_Ceiling_Locking
=> LP
:= 'C';
17449 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
17450 when Name_Inheritance_Locking
=> LP
:= 'I';
17453 if Locking_Policy
/= ' '
17454 and then Locking_Policy
/= LP
17456 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17457 Error_Pragma
("locking policy incompatible with policy#");
17459 -- Set new policy, but always preserve System_Location since we
17460 -- like the error message with the run time name.
17463 Locking_Policy
:= LP
;
17465 if Locking_Policy_Sloc
/= System_Location
then
17466 Locking_Policy_Sloc
:= Loc
;
17471 -------------------
17472 -- Loop_Optimize --
17473 -------------------
17475 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17477 -- OPTIMIZATION_HINT ::=
17478 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17480 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
17485 Check_At_Least_N_Arguments
(1);
17486 Check_No_Identifiers
;
17488 Hint
:= First
(Pragma_Argument_Associations
(N
));
17489 while Present
(Hint
) loop
17490 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
17498 Check_Loop_Pragma_Placement
;
17505 -- pragma Loop_Variant
17506 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17508 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17510 -- CHANGE_DIRECTION ::= Increases | Decreases
17512 when Pragma_Loop_Variant
=> Loop_Variant
: declare
17517 Check_At_Least_N_Arguments
(1);
17518 Check_Loop_Pragma_Placement
;
17520 -- Process all increasing / decreasing expressions
17522 Variant
:= First
(Pragma_Argument_Associations
(N
));
17523 while Present
(Variant
) loop
17524 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
17527 Error_Pragma_Arg
("wrong change modifier", Variant
);
17530 Preanalyze_Assert_Expression
17531 (Expression
(Variant
), Any_Discrete
);
17537 -----------------------
17538 -- Machine_Attribute --
17539 -----------------------
17541 -- pragma Machine_Attribute (
17542 -- [Entity =>] LOCAL_NAME,
17543 -- [Attribute_Name =>] static_string_EXPRESSION
17544 -- [, [Info =>] static_EXPRESSION] );
17546 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
17547 Def_Id
: Entity_Id
;
17551 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
17553 if Arg_Count
= 3 then
17554 Check_Optional_Identifier
(Arg3
, Name_Info
);
17555 Check_Arg_Is_OK_Static_Expression
(Arg3
);
17557 Check_Arg_Count
(2);
17560 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17561 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
17562 Check_Arg_Is_Local_Name
(Arg1
);
17563 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17564 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17566 if Is_Access_Type
(Def_Id
) then
17567 Def_Id
:= Designated_Type
(Def_Id
);
17570 if Rep_Item_Too_Early
(Def_Id
, N
) then
17574 Def_Id
:= Underlying_Type
(Def_Id
);
17576 -- The only processing required is to link this item on to the
17577 -- list of rep items for the given entity. This is accomplished
17578 -- by the call to Rep_Item_Too_Late (when no error is detected
17579 -- and False is returned).
17581 if Rep_Item_Too_Late
(Def_Id
, N
) then
17584 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17586 end Machine_Attribute
;
17593 -- (MAIN_OPTION [, MAIN_OPTION]);
17596 -- [STACK_SIZE =>] static_integer_EXPRESSION
17597 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17598 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17600 when Pragma_Main
=> Main
: declare
17601 Args
: Args_List
(1 .. 3);
17602 Names
: constant Name_List
(1 .. 3) := (
17604 Name_Task_Stack_Size_Default
,
17605 Name_Time_Slicing_Enabled
);
17611 Gather_Associations
(Names
, Args
);
17613 for J
in 1 .. 2 loop
17614 if Present
(Args
(J
)) then
17615 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17619 if Present
(Args
(3)) then
17620 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
17624 while Present
(Nod
) loop
17625 if Nkind
(Nod
) = N_Pragma
17626 and then Pragma_Name
(Nod
) = Name_Main
17628 Error_Msg_Name_1
:= Pname
;
17629 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17640 -- pragma Main_Storage
17641 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17643 -- MAIN_STORAGE_OPTION ::=
17644 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17645 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17647 when Pragma_Main_Storage
=> Main_Storage
: declare
17648 Args
: Args_List
(1 .. 2);
17649 Names
: constant Name_List
(1 .. 2) := (
17650 Name_Working_Storage
,
17657 Gather_Associations
(Names
, Args
);
17659 for J
in 1 .. 2 loop
17660 if Present
(Args
(J
)) then
17661 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17665 Check_In_Main_Program
;
17668 while Present
(Nod
) loop
17669 if Nkind
(Nod
) = N_Pragma
17670 and then Pragma_Name
(Nod
) = Name_Main_Storage
17672 Error_Msg_Name_1
:= Pname
;
17673 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17680 ----------------------
17681 -- Max_Queue_Length --
17682 ----------------------
17684 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
17686 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
17688 Entry_Decl
: Node_Id
;
17689 Entry_Id
: Entity_Id
;
17694 Check_Arg_Count
(1);
17697 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
17699 -- Entry declaration
17701 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
17703 -- Entry illegally within a task
17705 if Nkind
(Parent
(N
)) = N_Task_Definition
then
17706 Error_Pragma
("pragma % cannot apply to task entries");
17710 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
17712 -- Otherwise the pragma is associated with an illegal construct
17715 Error_Pragma
("pragma % must apply to a protected entry");
17719 -- Mark the pragma as Ghost if the related subprogram is also
17720 -- Ghost. This also ensures that any expansion performed further
17721 -- below will produce Ghost nodes.
17723 Mark_Ghost_Pragma
(N
, Entry_Id
);
17725 -- Analyze the Integer expression
17727 Arg
:= Get_Pragma_Arg
(Arg1
);
17728 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
17730 Val
:= Expr_Value
(Arg
);
17734 ("argument for pragma% must be positive", Arg1
);
17736 elsif not UI_Is_In_Int_Range
(Val
) then
17738 ("argument for pragma% out of range of Integer", Arg1
);
17742 -- Manually substitute the expression value of the pragma argument
17743 -- if it's not an integer literal because this is not taken care
17744 -- of automatically elsewhere.
17746 if Nkind
(Arg
) /= N_Integer_Literal
then
17747 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
17750 Record_Rep_Item
(Entry_Id
, N
);
17751 end Max_Queue_Length
;
17757 -- pragma Memory_Size (NUMERIC_LITERAL)
17759 when Pragma_Memory_Size
=>
17762 -- Memory size is simply ignored
17764 Check_No_Identifiers
;
17765 Check_Arg_Count
(1);
17766 Check_Arg_Is_Integer_Literal
(Arg1
);
17774 -- The only correct use of this pragma is on its own in a file, in
17775 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17776 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17777 -- check for a file containing nothing but a No_Body pragma). If we
17778 -- attempt to process it during normal semantics processing, it means
17779 -- it was misplaced.
17781 when Pragma_No_Body
=>
17785 -----------------------------
17786 -- No_Elaboration_Code_All --
17787 -----------------------------
17789 -- pragma No_Elaboration_Code_All;
17791 when Pragma_No_Elaboration_Code_All
=>
17793 Check_Valid_Library_Unit_Pragma
;
17795 if Nkind
(N
) = N_Null_Statement
then
17799 -- Must appear for a spec or generic spec
17801 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
17802 N_Generic_Package_Declaration
,
17803 N_Generic_Subprogram_Declaration
,
17804 N_Package_Declaration
,
17805 N_Subprogram_Declaration
)
17809 ("pragma% can only occur for package "
17810 & "or subprogram spec"));
17813 -- Set flag in unit table
17815 Set_No_Elab_Code_All
(Current_Sem_Unit
);
17817 -- Set restriction No_Elaboration_Code if this is the main unit
17819 if Current_Sem_Unit
= Main_Unit
then
17820 Set_Restriction
(No_Elaboration_Code
, N
);
17823 -- If we are in the main unit or in an extended main source unit,
17824 -- then we also add it to the configuration restrictions so that
17825 -- it will apply to all units in the extended main source.
17827 if Current_Sem_Unit
= Main_Unit
17828 or else In_Extended_Main_Source_Unit
(N
)
17830 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
17833 -- If in main extended unit, activate transitive with test
17835 if In_Extended_Main_Source_Unit
(N
) then
17836 Opt
.No_Elab_Code_All_Pragma
:= N
;
17843 -- pragma No_Inline ( NAME {, NAME} );
17845 when Pragma_No_Inline
=>
17847 Process_Inline
(Suppressed
);
17853 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
17855 when Pragma_No_Return
=> No_Return
: declare
17861 Ghost_Error_Posted
: Boolean := False;
17862 -- Flag set when an error concerning the illegal mix of Ghost and
17863 -- non-Ghost subprograms is emitted.
17865 Ghost_Id
: Entity_Id
:= Empty
;
17866 -- The entity of the first Ghost procedure encountered while
17867 -- processing the arguments of the pragma.
17871 Check_At_Least_N_Arguments
(1);
17873 -- Loop through arguments of pragma
17876 while Present
(Arg
) loop
17877 Check_Arg_Is_Local_Name
(Arg
);
17878 Id
:= Get_Pragma_Arg
(Arg
);
17881 if not Is_Entity_Name
(Id
) then
17882 Error_Pragma_Arg
("entity name required", Arg
);
17885 if Etype
(Id
) = Any_Type
then
17889 -- Loop to find matching procedures
17895 and then Scope
(E
) = Current_Scope
17897 if Ekind_In
(E
, E_Procedure
, E_Generic_Procedure
) then
17900 -- A pragma that applies to a Ghost entity becomes Ghost
17901 -- for the purposes of legality checks and removal of
17902 -- ignored Ghost code.
17904 Mark_Ghost_Pragma
(N
, E
);
17906 -- Capture the entity of the first Ghost procedure being
17907 -- processed for error detection purposes.
17909 if Is_Ghost_Entity
(E
) then
17910 if No
(Ghost_Id
) then
17914 -- Otherwise the subprogram is non-Ghost. It is illegal
17915 -- to mix references to Ghost and non-Ghost entities
17918 elsif Present
(Ghost_Id
)
17919 and then not Ghost_Error_Posted
17921 Ghost_Error_Posted
:= True;
17923 Error_Msg_Name_1
:= Pname
;
17925 ("pragma % cannot mention ghost and non-ghost "
17926 & "procedures", N
);
17928 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17929 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
17931 Error_Msg_Sloc
:= Sloc
(E
);
17932 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
17935 -- Set flag on any alias as well
17937 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
17938 Set_No_Return
(Alias
(E
));
17944 exit when From_Aspect_Specification
(N
);
17948 -- If entity in not in current scope it may be the enclosing
17949 -- suprogram body to which the aspect applies.
17952 if Entity
(Id
) = Current_Scope
17953 and then From_Aspect_Specification
(N
)
17955 Set_No_Return
(Entity
(Id
));
17957 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
17969 -- pragma No_Run_Time;
17971 -- Note: this pragma is retained for backwards compatibility. See
17972 -- body of Rtsfind for full details on its handling.
17974 when Pragma_No_Run_Time
=>
17976 Check_Valid_Configuration_Pragma
;
17977 Check_Arg_Count
(0);
17979 -- Remove backward compatibility if Build_Type is FSF or GPL and
17980 -- generate a warning.
17983 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
17986 Error_Pragma
("pragma% is ignored, has no effect??");
17988 No_Run_Time_Mode
:= True;
17989 Configurable_Run_Time_Mode
:= True;
17991 -- Set Duration to 32 bits if word size is 32
17993 if Ttypes
.System_Word_Size
= 32 then
17994 Duration_32_Bits_On_Target
:= True;
17997 -- Set appropriate restrictions
17999 Set_Restriction
(No_Finalization
, N
);
18000 Set_Restriction
(No_Exception_Handlers
, N
);
18001 Set_Restriction
(Max_Tasks
, N
, 0);
18002 Set_Restriction
(No_Tasking
, N
);
18006 -----------------------
18007 -- No_Tagged_Streams --
18008 -----------------------
18010 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18012 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
18018 Check_At_Most_N_Arguments
(1);
18020 -- One argument case
18022 if Arg_Count
= 1 then
18023 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18024 Check_Arg_Is_Local_Name
(Arg1
);
18025 E_Id
:= Get_Pragma_Arg
(Arg1
);
18027 if Etype
(E_Id
) = Any_Type
then
18031 E
:= Entity
(E_Id
);
18033 Check_Duplicate_Pragma
(E
);
18035 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
18037 ("argument for pragma% must be root tagged type", Arg1
);
18040 if Rep_Item_Too_Early
(E
, N
)
18042 Rep_Item_Too_Late
(E
, N
)
18046 Set_No_Tagged_Streams_Pragma
(E
, N
);
18049 -- Zero argument case
18052 Check_Is_In_Decl_Part_Or_Package_Spec
;
18053 No_Tagged_Streams
:= N
;
18055 end No_Tagged_Strms
;
18057 ------------------------
18058 -- No_Strict_Aliasing --
18059 ------------------------
18061 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18063 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
18068 Check_At_Most_N_Arguments
(1);
18070 if Arg_Count
= 0 then
18071 Check_Valid_Configuration_Pragma
;
18072 Opt
.No_Strict_Aliasing
:= True;
18075 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18076 Check_Arg_Is_Local_Name
(Arg1
);
18077 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18079 if E_Id
= Any_Type
then
18081 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
18082 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
18085 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
18087 end No_Strict_Aliasing
;
18089 -----------------------
18090 -- Normalize_Scalars --
18091 -----------------------
18093 -- pragma Normalize_Scalars;
18095 when Pragma_Normalize_Scalars
=>
18096 Check_Ada_83_Warning
;
18097 Check_Arg_Count
(0);
18098 Check_Valid_Configuration_Pragma
;
18100 -- Normalize_Scalars creates false positives in CodePeer, and
18101 -- incorrect negative results in GNATprove mode, so ignore this
18102 -- pragma in these modes.
18104 if not (CodePeer_Mode
or GNATprove_Mode
) then
18105 Normalize_Scalars
:= True;
18106 Init_Or_Norm_Scalars
:= True;
18113 -- pragma Obsolescent;
18115 -- pragma Obsolescent (
18116 -- [Message =>] static_string_EXPRESSION
18117 -- [,[Version =>] Ada_05]]);
18119 -- pragma Obsolescent (
18120 -- [Entity =>] NAME
18121 -- [,[Message =>] static_string_EXPRESSION
18122 -- [,[Version =>] Ada_05]] );
18124 when Pragma_Obsolescent
=> Obsolescent
: declare
18128 procedure Set_Obsolescent
(E
: Entity_Id
);
18129 -- Given an entity Ent, mark it as obsolescent if appropriate
18131 ---------------------
18132 -- Set_Obsolescent --
18133 ---------------------
18135 procedure Set_Obsolescent
(E
: Entity_Id
) is
18144 -- A pragma that applies to a Ghost entity becomes Ghost for
18145 -- the purposes of legality checks and removal of ignored Ghost
18148 Mark_Ghost_Pragma
(N
, E
);
18150 -- Entity name was given
18152 if Present
(Ename
) then
18154 -- If entity name matches, we are fine. Save entity in
18155 -- pragma argument, for ASIS use.
18157 if Chars
(Ename
) = Chars
(Ent
) then
18158 Set_Entity
(Ename
, Ent
);
18159 Generate_Reference
(Ent
, Ename
);
18161 -- If entity name does not match, only possibility is an
18162 -- enumeration literal from an enumeration type declaration.
18164 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
18166 ("pragma % entity name does not match declaration");
18169 Ent
:= First_Literal
(E
);
18173 ("pragma % entity name does not match any "
18174 & "enumeration literal");
18176 elsif Chars
(Ent
) = Chars
(Ename
) then
18177 Set_Entity
(Ename
, Ent
);
18178 Generate_Reference
(Ent
, Ename
);
18182 Ent
:= Next_Literal
(Ent
);
18188 -- Ent points to entity to be marked
18190 if Arg_Count
>= 1 then
18192 -- Deal with static string argument
18194 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18195 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
18197 for J
in 1 .. String_Length
(S
) loop
18198 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
18200 ("pragma% argument does not allow wide characters",
18205 Obsolescent_Warnings
.Append
18206 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
18208 -- Check for Ada_05 parameter
18210 if Arg_Count
/= 1 then
18211 Check_Arg_Count
(2);
18214 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
18217 Check_Arg_Is_Identifier
(Argx
);
18219 if Chars
(Argx
) /= Name_Ada_05
then
18220 Error_Msg_Name_2
:= Name_Ada_05
;
18222 ("only allowed argument for pragma% is %", Argx
);
18225 if Ada_Version_Explicit
< Ada_2005
18226 or else not Warn_On_Ada_2005_Compatibility
18234 -- Set flag if pragma active
18237 Set_Is_Obsolescent
(Ent
);
18241 end Set_Obsolescent
;
18243 -- Start of processing for pragma Obsolescent
18248 Check_At_Most_N_Arguments
(3);
18250 -- See if first argument specifies an entity name
18254 (Chars
(Arg1
) = Name_Entity
18256 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
18258 N_Operator_Symbol
))
18260 Ename
:= Get_Pragma_Arg
(Arg1
);
18262 -- Eliminate first argument, so we can share processing
18266 Arg_Count
:= Arg_Count
- 1;
18268 -- No Entity name argument given
18274 if Arg_Count
>= 1 then
18275 Check_Optional_Identifier
(Arg1
, Name_Message
);
18277 if Arg_Count
= 2 then
18278 Check_Optional_Identifier
(Arg2
, Name_Version
);
18282 -- Get immediately preceding declaration
18285 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
18289 -- Cases where we do not follow anything other than another pragma
18293 -- First case: library level compilation unit declaration with
18294 -- the pragma immediately following the declaration.
18296 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
18298 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
18301 -- Case 2: library unit placement for package
18305 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
18307 if Is_Package_Or_Generic_Package
(Ent
) then
18308 Set_Obsolescent
(Ent
);
18314 -- Cases where we must follow a declaration, including an
18315 -- abstract subprogram declaration, which is not in the
18316 -- other node subtypes.
18319 if Nkind
(Decl
) not in N_Declaration
18320 and then Nkind
(Decl
) not in N_Later_Decl_Item
18321 and then Nkind
(Decl
) not in N_Generic_Declaration
18322 and then Nkind
(Decl
) not in N_Renaming_Declaration
18323 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
18326 ("pragma% misplaced, "
18327 & "must immediately follow a declaration");
18330 Set_Obsolescent
(Defining_Entity
(Decl
));
18340 -- pragma Optimize (Time | Space | Off);
18342 -- The actual check for optimize is done in Gigi. Note that this
18343 -- pragma does not actually change the optimization setting, it
18344 -- simply checks that it is consistent with the pragma.
18346 when Pragma_Optimize
=>
18347 Check_No_Identifiers
;
18348 Check_Arg_Count
(1);
18349 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
18351 ------------------------
18352 -- Optimize_Alignment --
18353 ------------------------
18355 -- pragma Optimize_Alignment (Time | Space | Off);
18357 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
18359 Check_No_Identifiers
;
18360 Check_Arg_Count
(1);
18361 Check_Valid_Configuration_Pragma
;
18364 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
18367 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
18368 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
18369 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
18372 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
18376 -- Set indication that mode is set locally. If we are in fact in a
18377 -- configuration pragma file, this setting is harmless since the
18378 -- switch will get reset anyway at the start of each unit.
18380 Optimize_Alignment_Local
:= True;
18381 end Optimize_Alignment
;
18387 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18389 when Pragma_Ordered
=> Ordered
: declare
18390 Assoc
: constant Node_Id
:= Arg1
;
18396 Check_No_Identifiers
;
18397 Check_Arg_Count
(1);
18398 Check_Arg_Is_Local_Name
(Arg1
);
18400 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18401 Find_Type
(Type_Id
);
18402 Typ
:= Entity
(Type_Id
);
18404 if Typ
= Any_Type
then
18407 Typ
:= Underlying_Type
(Typ
);
18410 if not Is_Enumeration_Type
(Typ
) then
18411 Error_Pragma
("pragma% must specify enumeration type");
18414 Check_First_Subtype
(Arg1
);
18415 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
18418 -------------------
18419 -- Overflow_Mode --
18420 -------------------
18422 -- pragma Overflow_Mode
18423 -- ([General => ] MODE [, [Assertions => ] MODE]);
18425 -- MODE := STRICT | MINIMIZED | ELIMINATED
18427 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18428 -- since System.Bignums makes this assumption. This is true of nearly
18429 -- all (all?) targets.
18431 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
18432 function Get_Overflow_Mode
18434 Arg
: Node_Id
) return Overflow_Mode_Type
;
18435 -- Function to process one pragma argument, Arg. If an identifier
18436 -- is present, it must be Name. Mode type is returned if a valid
18437 -- argument exists, otherwise an error is signalled.
18439 -----------------------
18440 -- Get_Overflow_Mode --
18441 -----------------------
18443 function Get_Overflow_Mode
18445 Arg
: Node_Id
) return Overflow_Mode_Type
18447 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
18450 Check_Optional_Identifier
(Arg
, Name
);
18451 Check_Arg_Is_Identifier
(Argx
);
18453 if Chars
(Argx
) = Name_Strict
then
18456 elsif Chars
(Argx
) = Name_Minimized
then
18459 elsif Chars
(Argx
) = Name_Eliminated
then
18460 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
18462 ("Eliminated not implemented on this target", Argx
);
18468 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
18470 end Get_Overflow_Mode
;
18472 -- Start of processing for Overflow_Mode
18476 Check_At_Least_N_Arguments
(1);
18477 Check_At_Most_N_Arguments
(2);
18479 -- Process first argument
18481 Scope_Suppress
.Overflow_Mode_General
:=
18482 Get_Overflow_Mode
(Name_General
, Arg1
);
18484 -- Case of only one argument
18486 if Arg_Count
= 1 then
18487 Scope_Suppress
.Overflow_Mode_Assertions
:=
18488 Scope_Suppress
.Overflow_Mode_General
;
18490 -- Case of two arguments present
18493 Scope_Suppress
.Overflow_Mode_Assertions
:=
18494 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
18498 --------------------------
18499 -- Overriding Renamings --
18500 --------------------------
18502 -- pragma Overriding_Renamings;
18504 when Pragma_Overriding_Renamings
=>
18506 Check_Arg_Count
(0);
18507 Check_Valid_Configuration_Pragma
;
18508 Overriding_Renamings
:= True;
18514 -- pragma Pack (first_subtype_LOCAL_NAME);
18516 when Pragma_Pack
=> Pack
: declare
18517 Assoc
: constant Node_Id
:= Arg1
;
18519 Ignore
: Boolean := False;
18524 Check_No_Identifiers
;
18525 Check_Arg_Count
(1);
18526 Check_Arg_Is_Local_Name
(Arg1
);
18527 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18529 if not Is_Entity_Name
(Type_Id
)
18530 or else not Is_Type
(Entity
(Type_Id
))
18533 ("argument for pragma% must be type or subtype", Arg1
);
18536 Find_Type
(Type_Id
);
18537 Typ
:= Entity
(Type_Id
);
18540 or else Rep_Item_Too_Early
(Typ
, N
)
18544 Typ
:= Underlying_Type
(Typ
);
18547 -- A pragma that applies to a Ghost entity becomes Ghost for the
18548 -- purposes of legality checks and removal of ignored Ghost code.
18550 Mark_Ghost_Pragma
(N
, Typ
);
18552 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
18553 Error_Pragma
("pragma% must specify array or record type");
18556 Check_First_Subtype
(Arg1
);
18557 Check_Duplicate_Pragma
(Typ
);
18561 if Is_Array_Type
(Typ
) then
18562 Ctyp
:= Component_Type
(Typ
);
18564 -- Ignore pack that does nothing
18566 if Known_Static_Esize
(Ctyp
)
18567 and then Known_Static_RM_Size
(Ctyp
)
18568 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
18569 and then Addressable
(Esize
(Ctyp
))
18574 -- Process OK pragma Pack. Note that if there is a separate
18575 -- component clause present, the Pack will be cancelled. This
18576 -- processing is in Freeze.
18578 if not Rep_Item_Too_Late
(Typ
, N
) then
18580 -- In CodePeer mode, we do not need complex front-end
18581 -- expansions related to pragma Pack, so disable handling
18584 if CodePeer_Mode
then
18587 -- Normal case where we do the pack action
18591 Set_Is_Packed
(Base_Type
(Typ
));
18592 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18595 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18599 -- For record types, the pack is always effective
18601 else pragma Assert
(Is_Record_Type
(Typ
));
18602 if not Rep_Item_Too_Late
(Typ
, N
) then
18603 Set_Is_Packed
(Base_Type
(Typ
));
18604 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18605 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18616 -- There is nothing to do here, since we did all the processing for
18617 -- this pragma in Par.Prag (so that it works properly even in syntax
18620 when Pragma_Page
=>
18627 -- pragma Part_Of (ABSTRACT_STATE);
18629 -- ABSTRACT_STATE ::= NAME
18631 when Pragma_Part_Of
=> Part_Of
: declare
18632 procedure Propagate_Part_Of
18633 (Pack_Id
: Entity_Id
;
18634 State_Id
: Entity_Id
;
18635 Instance
: Node_Id
);
18636 -- Propagate the Part_Of indicator to all abstract states and
18637 -- objects declared in the visible state space of a package
18638 -- denoted by Pack_Id. State_Id is the encapsulating state.
18639 -- Instance is the package instantiation node.
18641 -----------------------
18642 -- Propagate_Part_Of --
18643 -----------------------
18645 procedure Propagate_Part_Of
18646 (Pack_Id
: Entity_Id
;
18647 State_Id
: Entity_Id
;
18648 Instance
: Node_Id
)
18650 Has_Item
: Boolean := False;
18651 -- Flag set when the visible state space contains at least one
18652 -- abstract state or variable.
18654 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
18655 -- Propagate the Part_Of indicator to all abstract states and
18656 -- objects declared in the visible state space of a package
18657 -- denoted by Pack_Id.
18659 -----------------------
18660 -- Propagate_Part_Of --
18661 -----------------------
18663 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
18664 Constits
: Elist_Id
;
18665 Item_Id
: Entity_Id
;
18668 -- Traverse the entity chain of the package and set relevant
18669 -- attributes of abstract states and objects declared in the
18670 -- visible state space of the package.
18672 Item_Id
:= First_Entity
(Pack_Id
);
18673 while Present
(Item_Id
)
18674 and then not In_Private_Part
(Item_Id
)
18676 -- Do not consider internally generated items
18678 if not Comes_From_Source
(Item_Id
) then
18681 -- The Part_Of indicator turns an abstract state or an
18682 -- object into a constituent of the encapsulating state.
18684 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
18689 Constits
:= Part_Of_Constituents
(State_Id
);
18691 if No
(Constits
) then
18692 Constits
:= New_Elmt_List
;
18693 Set_Part_Of_Constituents
(State_Id
, Constits
);
18696 Append_Elmt
(Item_Id
, Constits
);
18697 Set_Encapsulating_State
(Item_Id
, State_Id
);
18699 -- Recursively handle nested packages and instantiations
18701 elsif Ekind
(Item_Id
) = E_Package
then
18702 Propagate_Part_Of
(Item_Id
);
18705 Next_Entity
(Item_Id
);
18707 end Propagate_Part_Of
;
18709 -- Start of processing for Propagate_Part_Of
18712 Propagate_Part_Of
(Pack_Id
);
18714 -- Detect a package instantiation that is subject to a Part_Of
18715 -- indicator, but has no visible state.
18717 if not Has_Item
then
18719 ("package instantiation & has Part_Of indicator but "
18720 & "lacks visible state", Instance
, Pack_Id
);
18722 end Propagate_Part_Of
;
18726 Constits
: Elist_Id
;
18728 Encap_Id
: Entity_Id
;
18729 Item_Id
: Entity_Id
;
18733 -- Start of processing for Part_Of
18737 Check_No_Identifiers
;
18738 Check_Arg_Count
(1);
18740 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
18742 -- Object declaration
18744 if Nkind
(Stmt
) = N_Object_Declaration
then
18747 -- Package instantiation
18749 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
18752 -- Single concurrent type declaration
18754 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
18757 -- Otherwise the pragma is associated with an illegal construct
18764 -- Extract the entity of the related object declaration or package
18765 -- instantiation. In the case of the instantiation, use the entity
18766 -- of the instance spec.
18768 if Nkind
(Stmt
) = N_Package_Instantiation
then
18769 Stmt
:= Instance_Spec
(Stmt
);
18772 Item_Id
:= Defining_Entity
(Stmt
);
18774 -- A pragma that applies to a Ghost entity becomes Ghost for the
18775 -- purposes of legality checks and removal of ignored Ghost code.
18777 Mark_Ghost_Pragma
(N
, Item_Id
);
18779 -- Chain the pragma on the contract for further processing by
18780 -- Analyze_Part_Of_In_Decl_Part or for completeness.
18782 Add_Contract_Item
(N
, Item_Id
);
18784 -- A variable may act as constituent of a single concurrent type
18785 -- which in turn could be declared after the variable. Due to this
18786 -- discrepancy, the full analysis of indicator Part_Of is delayed
18787 -- until the end of the enclosing declarative region (see routine
18788 -- Analyze_Part_Of_In_Decl_Part).
18790 if Ekind
(Item_Id
) = E_Variable
then
18793 -- Otherwise indicator Part_Of applies to a constant or a package
18797 Encap
:= Get_Pragma_Arg
(Arg1
);
18799 -- Detect any discrepancies between the placement of the
18800 -- constant or package instantiation with respect to state
18801 -- space and the encapsulating state.
18805 Item_Id
=> Item_Id
,
18807 Encap_Id
=> Encap_Id
,
18811 pragma Assert
(Present
(Encap_Id
));
18813 if Ekind
(Item_Id
) = E_Constant
then
18814 Constits
:= Part_Of_Constituents
(Encap_Id
);
18816 if No
(Constits
) then
18817 Constits
:= New_Elmt_List
;
18818 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
18821 Append_Elmt
(Item_Id
, Constits
);
18822 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
18824 -- Propagate the Part_Of indicator to the visible state
18825 -- space of the package instantiation.
18829 (Pack_Id
=> Item_Id
,
18830 State_Id
=> Encap_Id
,
18837 ----------------------------------
18838 -- Partition_Elaboration_Policy --
18839 ----------------------------------
18841 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
18843 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
18844 subtype PEP_Range
is Name_Id
18845 range First_Partition_Elaboration_Policy_Name
18846 .. Last_Partition_Elaboration_Policy_Name
;
18847 PEP_Val
: PEP_Range
;
18852 Check_Arg_Count
(1);
18853 Check_No_Identifiers
;
18854 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
18855 Check_Valid_Configuration_Pragma
;
18856 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
18859 when Name_Concurrent
=> PEP
:= 'C';
18860 when Name_Sequential
=> PEP
:= 'S';
18863 if Partition_Elaboration_Policy
/= ' '
18864 and then Partition_Elaboration_Policy
/= PEP
18866 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
18868 ("partition elaboration policy incompatible with policy#");
18870 -- Set new policy, but always preserve System_Location since we
18871 -- like the error message with the run time name.
18874 Partition_Elaboration_Policy
:= PEP
;
18876 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
18877 Partition_Elaboration_Policy_Sloc
:= Loc
;
18886 -- pragma Passive [(PASSIVE_FORM)];
18888 -- PASSIVE_FORM ::= Semaphore | No
18890 when Pragma_Passive
=>
18893 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
18894 Error_Pragma
("pragma% must be within task definition");
18897 if Arg_Count
/= 0 then
18898 Check_Arg_Count
(1);
18899 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
18902 ----------------------------------
18903 -- Preelaborable_Initialization --
18904 ----------------------------------
18906 -- pragma Preelaborable_Initialization (DIRECT_NAME);
18908 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
18913 Check_Arg_Count
(1);
18914 Check_No_Identifiers
;
18915 Check_Arg_Is_Identifier
(Arg1
);
18916 Check_Arg_Is_Local_Name
(Arg1
);
18917 Check_First_Subtype
(Arg1
);
18918 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
18920 -- A pragma that applies to a Ghost entity becomes Ghost for the
18921 -- purposes of legality checks and removal of ignored Ghost code.
18923 Mark_Ghost_Pragma
(N
, Ent
);
18925 -- The pragma may come from an aspect on a private declaration,
18926 -- even if the freeze point at which this is analyzed in the
18927 -- private part after the full view.
18929 if Has_Private_Declaration
(Ent
)
18930 and then From_Aspect_Specification
(N
)
18934 -- Check appropriate type argument
18936 elsif Is_Private_Type
(Ent
)
18937 or else Is_Protected_Type
(Ent
)
18938 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
18940 -- AI05-0028: The pragma applies to all composite types. Note
18941 -- that we apply this binding interpretation to earlier versions
18942 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
18943 -- choice since there are other compilers that do the same.
18945 or else Is_Composite_Type
(Ent
)
18951 ("pragma % can only be applied to private, formal derived, "
18952 & "protected, or composite type", Arg1
);
18955 -- Give an error if the pragma is applied to a protected type that
18956 -- does not qualify (due to having entries, or due to components
18957 -- that do not qualify).
18959 if Is_Protected_Type
(Ent
)
18960 and then not Has_Preelaborable_Initialization
(Ent
)
18963 ("protected type & does not have preelaborable "
18964 & "initialization", Ent
);
18966 -- Otherwise mark the type as definitely having preelaborable
18970 Set_Known_To_Have_Preelab_Init
(Ent
);
18973 if Has_Pragma_Preelab_Init
(Ent
)
18974 and then Warn_On_Redundant_Constructs
18976 Error_Pragma
("?r?duplicate pragma%!");
18978 Set_Has_Pragma_Preelab_Init
(Ent
);
18982 --------------------
18983 -- Persistent_BSS --
18984 --------------------
18986 -- pragma Persistent_BSS [(object_NAME)];
18988 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
18995 Check_At_Most_N_Arguments
(1);
18997 -- Case of application to specific object (one argument)
18999 if Arg_Count
= 1 then
19000 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19002 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
19004 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
19007 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
19010 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19012 -- A pragma that applies to a Ghost entity becomes Ghost for
19013 -- the purposes of legality checks and removal of ignored Ghost
19016 Mark_Ghost_Pragma
(N
, Ent
);
19018 -- Check for duplication before inserting in list of
19019 -- representation items.
19021 Check_Duplicate_Pragma
(Ent
);
19023 if Rep_Item_Too_Late
(Ent
, N
) then
19027 Decl
:= Parent
(Ent
);
19029 if Present
(Expression
(Decl
)) then
19031 ("object for pragma% cannot have initialization", Arg1
);
19034 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
19036 ("object type for pragma% is not potentially persistent",
19041 Make_Linker_Section_Pragma
19042 (Ent
, Sloc
(N
), ".persistent.bss");
19043 Insert_After
(N
, Prag
);
19046 -- Case of use as configuration pragma with no arguments
19049 Check_Valid_Configuration_Pragma
;
19050 Persistent_BSS_Mode
:= True;
19052 end Persistent_BSS
;
19054 --------------------
19055 -- Rename_Pragma --
19056 --------------------
19058 -- pragma Rename_Pragma (
19059 -- [New_Name =>] IDENTIFIER,
19060 -- [Renamed =>] pragma_IDENTIFIER);
19062 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
19063 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19064 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19068 Check_Valid_Configuration_Pragma
;
19069 Check_Arg_Count
(2);
19070 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
19071 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
19073 if Nkind
(New_Name
) /= N_Identifier
then
19074 Error_Pragma_Arg
("identifier expected", Arg1
);
19077 if Nkind
(Old_Name
) /= N_Identifier
then
19078 Error_Pragma_Arg
("identifier expected", Arg2
);
19081 -- The New_Name arg should not be an existing pragma (but we allow
19082 -- it; it's just a warning). The Old_Name arg must be an existing
19085 if Is_Pragma_Name
(Chars
(New_Name
)) then
19086 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
19089 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
19090 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
19093 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
19100 -- pragma Polling (ON | OFF);
19102 when Pragma_Polling
=>
19104 Check_Arg_Count
(1);
19105 Check_No_Identifiers
;
19106 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19107 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
19109 -----------------------------------
19110 -- Post/Post_Class/Postcondition --
19111 -----------------------------------
19113 -- pragma Post (Boolean_EXPRESSION);
19114 -- pragma Post_Class (Boolean_EXPRESSION);
19115 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19116 -- [,[Message =>] String_EXPRESSION]);
19118 -- Characteristics:
19120 -- * Analysis - The annotation undergoes initial checks to verify
19121 -- the legal placement and context. Secondary checks preanalyze the
19124 -- Analyze_Pre_Post_Condition_In_Decl_Part
19126 -- * Expansion - The annotation is expanded during the expansion of
19127 -- the related subprogram [body] contract as performed in:
19129 -- Expand_Subprogram_Contract
19131 -- * Template - The annotation utilizes the generic template of the
19132 -- related subprogram [body] when it is:
19134 -- aspect on subprogram declaration
19135 -- aspect on stand alone subprogram body
19136 -- pragma on stand alone subprogram body
19138 -- The annotation must prepare its own template when it is:
19140 -- pragma on subprogram declaration
19142 -- * Globals - Capture of global references must occur after full
19145 -- * Instance - The annotation is instantiated automatically when
19146 -- the related generic subprogram [body] is instantiated except for
19147 -- the "pragma on subprogram declaration" case. In that scenario
19148 -- the annotation must instantiate itself.
19151 | Pragma_Post_Class
19152 | Pragma_Postcondition
19154 Analyze_Pre_Post_Condition
;
19156 --------------------------------
19157 -- Pre/Pre_Class/Precondition --
19158 --------------------------------
19160 -- pragma Pre (Boolean_EXPRESSION);
19161 -- pragma Pre_Class (Boolean_EXPRESSION);
19162 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19163 -- [,[Message =>] String_EXPRESSION]);
19165 -- Characteristics:
19167 -- * Analysis - The annotation undergoes initial checks to verify
19168 -- the legal placement and context. Secondary checks preanalyze the
19171 -- Analyze_Pre_Post_Condition_In_Decl_Part
19173 -- * Expansion - The annotation is expanded during the expansion of
19174 -- the related subprogram [body] contract as performed in:
19176 -- Expand_Subprogram_Contract
19178 -- * Template - The annotation utilizes the generic template of the
19179 -- related subprogram [body] when it is:
19181 -- aspect on subprogram declaration
19182 -- aspect on stand alone subprogram body
19183 -- pragma on stand alone subprogram body
19185 -- The annotation must prepare its own template when it is:
19187 -- pragma on subprogram declaration
19189 -- * Globals - Capture of global references must occur after full
19192 -- * Instance - The annotation is instantiated automatically when
19193 -- the related generic subprogram [body] is instantiated except for
19194 -- the "pragma on subprogram declaration" case. In that scenario
19195 -- the annotation must instantiate itself.
19199 | Pragma_Precondition
19201 Analyze_Pre_Post_Condition
;
19207 -- pragma Predicate
19208 -- ([Entity =>] type_LOCAL_NAME,
19209 -- [Check =>] boolean_EXPRESSION);
19211 when Pragma_Predicate
=> Predicate
: declare
19218 Check_Arg_Count
(2);
19219 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19220 Check_Optional_Identifier
(Arg2
, Name_Check
);
19222 Check_Arg_Is_Local_Name
(Arg1
);
19224 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19225 Find_Type
(Type_Id
);
19226 Typ
:= Entity
(Type_Id
);
19228 if Typ
= Any_Type
then
19232 -- A pragma that applies to a Ghost entity becomes Ghost for the
19233 -- purposes of legality checks and removal of ignored Ghost code.
19235 Mark_Ghost_Pragma
(N
, Typ
);
19237 -- The remaining processing is simply to link the pragma on to
19238 -- the rep item chain, for processing when the type is frozen.
19239 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19240 -- mark the type as having predicates.
19242 -- If the current policy for predicate checking is Ignore mark the
19243 -- subtype accordingly. In the case of predicates we consider them
19244 -- enabled unless Ignore is specified (either directly or with a
19245 -- general Assertion_Policy pragma) to preserve existing warnings.
19247 Set_Has_Predicates
(Typ
);
19248 Set_Predicates_Ignored
(Typ
,
19249 Present
(Check_Policy_List
)
19251 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
19252 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19255 -----------------------
19256 -- Predicate_Failure --
19257 -----------------------
19259 -- pragma Predicate_Failure
19260 -- ([Entity =>] type_LOCAL_NAME,
19261 -- [Message =>] string_EXPRESSION);
19263 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
19270 Check_Arg_Count
(2);
19271 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19272 Check_Optional_Identifier
(Arg2
, Name_Message
);
19274 Check_Arg_Is_Local_Name
(Arg1
);
19276 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19277 Find_Type
(Type_Id
);
19278 Typ
:= Entity
(Type_Id
);
19280 if Typ
= Any_Type
then
19284 -- A pragma that applies to a Ghost entity becomes Ghost for the
19285 -- purposes of legality checks and removal of ignored Ghost code.
19287 Mark_Ghost_Pragma
(N
, Typ
);
19289 -- The remaining processing is simply to link the pragma on to
19290 -- the rep item chain, for processing when the type is frozen.
19291 -- This is accomplished by a call to Rep_Item_Too_Late.
19293 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19294 end Predicate_Failure
;
19300 -- pragma Preelaborate [(library_unit_NAME)];
19302 -- Set the flag Is_Preelaborated of program unit name entity
19304 when Pragma_Preelaborate
=> Preelaborate
: declare
19305 Pa
: constant Node_Id
:= Parent
(N
);
19306 Pk
: constant Node_Kind
:= Nkind
(Pa
);
19310 Check_Ada_83_Warning
;
19311 Check_Valid_Library_Unit_Pragma
;
19313 if Nkind
(N
) = N_Null_Statement
then
19317 Ent
:= Find_Lib_Unit_Name
;
19319 -- A pragma that applies to a Ghost entity becomes Ghost for the
19320 -- purposes of legality checks and removal of ignored Ghost code.
19322 Mark_Ghost_Pragma
(N
, Ent
);
19323 Check_Duplicate_Pragma
(Ent
);
19325 -- This filters out pragmas inside generic parents that show up
19326 -- inside instantiations. Pragmas that come from aspects in the
19327 -- unit are not ignored.
19329 if Present
(Ent
) then
19330 if Pk
= N_Package_Specification
19331 and then Present
(Generic_Parent
(Pa
))
19332 and then not From_Aspect_Specification
(N
)
19337 if not Debug_Flag_U
then
19338 Set_Is_Preelaborated
(Ent
);
19339 Set_Suppress_Elaboration_Warnings
(Ent
);
19345 -------------------------------
19346 -- Prefix_Exception_Messages --
19347 -------------------------------
19349 -- pragma Prefix_Exception_Messages;
19351 when Pragma_Prefix_Exception_Messages
=>
19353 Check_Valid_Configuration_Pragma
;
19354 Check_Arg_Count
(0);
19355 Prefix_Exception_Messages
:= True;
19361 -- pragma Priority (EXPRESSION);
19363 when Pragma_Priority
=> Priority
: declare
19364 P
: constant Node_Id
:= Parent
(N
);
19369 Check_No_Identifiers
;
19370 Check_Arg_Count
(1);
19374 if Nkind
(P
) = N_Subprogram_Body
then
19375 Check_In_Main_Program
;
19377 Ent
:= Defining_Unit_Name
(Specification
(P
));
19379 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
19380 Ent
:= Defining_Identifier
(Ent
);
19383 Arg
:= Get_Pragma_Arg
(Arg1
);
19384 Analyze_And_Resolve
(Arg
, Standard_Integer
);
19388 if not Is_OK_Static_Expression
(Arg
) then
19389 Flag_Non_Static_Expr
19390 ("main subprogram priority is not static!", Arg
);
19393 -- If constraint error, then we already signalled an error
19395 elsif Raises_Constraint_Error
(Arg
) then
19398 -- Otherwise check in range except if Relaxed_RM_Semantics
19399 -- where we ignore the value if out of range.
19402 if not Relaxed_RM_Semantics
19403 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
19406 ("main subprogram priority is out of range", Arg1
);
19409 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
19413 -- Load an arbitrary entity from System.Tasking.Stages or
19414 -- System.Tasking.Restricted.Stages (depending on the
19415 -- supported profile) to make sure that one of these packages
19416 -- is implicitly with'ed, since we need to have the tasking
19417 -- run time active for the pragma Priority to have any effect.
19418 -- Previously we with'ed the package System.Tasking, but this
19419 -- package does not trigger the required initialization of the
19420 -- run-time library.
19423 Discard
: Entity_Id
;
19424 pragma Warnings
(Off
, Discard
);
19426 if Restricted_Profile
then
19427 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
19429 Discard
:= RTE
(RE_Activate_Tasks
);
19433 -- Task or Protected, must be of type Integer
19435 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
19436 Arg
:= Get_Pragma_Arg
(Arg1
);
19437 Ent
:= Defining_Identifier
(Parent
(P
));
19439 -- The expression must be analyzed in the special manner
19440 -- described in "Handling of Default and Per-Object
19441 -- Expressions" in sem.ads.
19443 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
19445 if not Is_OK_Static_Expression
(Arg
) then
19446 Check_Restriction
(Static_Priorities
, Arg
);
19449 -- Anything else is incorrect
19455 -- Check duplicate pragma before we chain the pragma in the Rep
19456 -- Item chain of Ent.
19458 Check_Duplicate_Pragma
(Ent
);
19459 Record_Rep_Item
(Ent
, N
);
19462 -----------------------------------
19463 -- Priority_Specific_Dispatching --
19464 -----------------------------------
19466 -- pragma Priority_Specific_Dispatching (
19467 -- policy_IDENTIFIER,
19468 -- first_priority_EXPRESSION,
19469 -- last_priority_EXPRESSION);
19471 when Pragma_Priority_Specific_Dispatching
=>
19472 Priority_Specific_Dispatching
: declare
19473 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
19474 -- This is the entity System.Any_Priority;
19477 Lower_Bound
: Node_Id
;
19478 Upper_Bound
: Node_Id
;
19484 Check_Arg_Count
(3);
19485 Check_No_Identifiers
;
19486 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19487 Check_Valid_Configuration_Pragma
;
19488 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19489 DP
:= Fold_Upper
(Name_Buffer
(1));
19491 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
19492 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
19493 Lower_Val
:= Expr_Value
(Lower_Bound
);
19495 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
19496 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
19497 Upper_Val
:= Expr_Value
(Upper_Bound
);
19499 -- It is not allowed to use Task_Dispatching_Policy and
19500 -- Priority_Specific_Dispatching in the same partition.
19502 if Task_Dispatching_Policy
/= ' ' then
19503 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19505 ("pragma% incompatible with Task_Dispatching_Policy#");
19507 -- Check lower bound in range
19509 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19511 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19514 ("first_priority is out of range", Arg2
);
19516 -- Check upper bound in range
19518 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19520 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19523 ("last_priority is out of range", Arg3
);
19525 -- Check that the priority range is valid
19527 elsif Lower_Val
> Upper_Val
then
19529 ("last_priority_expression must be greater than or equal to "
19530 & "first_priority_expression");
19532 -- Store the new policy, but always preserve System_Location since
19533 -- we like the error message with the run-time name.
19536 -- Check overlapping in the priority ranges specified in other
19537 -- Priority_Specific_Dispatching pragmas within the same
19538 -- partition. We can only check those we know about.
19541 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
19543 if Specific_Dispatching
.Table
(J
).First_Priority
in
19544 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19545 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
19546 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19549 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
19551 ("priority range overlaps with "
19552 & "Priority_Specific_Dispatching#");
19556 -- The use of Priority_Specific_Dispatching is incompatible
19557 -- with Task_Dispatching_Policy.
19559 if Task_Dispatching_Policy
/= ' ' then
19560 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19562 ("Priority_Specific_Dispatching incompatible "
19563 & "with Task_Dispatching_Policy#");
19566 -- The use of Priority_Specific_Dispatching forces ceiling
19569 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
19570 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19572 ("Priority_Specific_Dispatching incompatible "
19573 & "with Locking_Policy#");
19575 -- Set the Ceiling_Locking policy, but preserve System_Location
19576 -- since we like the error message with the run time name.
19579 Locking_Policy
:= 'C';
19581 if Locking_Policy_Sloc
/= System_Location
then
19582 Locking_Policy_Sloc
:= Loc
;
19586 -- Add entry in the table
19588 Specific_Dispatching
.Append
19589 ((Dispatching_Policy
=> DP
,
19590 First_Priority
=> UI_To_Int
(Lower_Val
),
19591 Last_Priority
=> UI_To_Int
(Upper_Val
),
19592 Pragma_Loc
=> Loc
));
19594 end Priority_Specific_Dispatching
;
19600 -- pragma Profile (profile_IDENTIFIER);
19602 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19604 when Pragma_Profile
=>
19606 Check_Arg_Count
(1);
19607 Check_Valid_Configuration_Pragma
;
19608 Check_No_Identifiers
;
19611 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19614 if Chars
(Argx
) = Name_Ravenscar
then
19615 Set_Ravenscar_Profile
(Ravenscar
, N
);
19617 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
19618 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
19620 elsif Chars
(Argx
) = Name_Restricted
then
19621 Set_Profile_Restrictions
19623 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19625 elsif Chars
(Argx
) = Name_Rational
then
19626 Set_Rational_Profile
;
19628 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19629 Set_Profile_Restrictions
19630 (No_Implementation_Extensions
,
19631 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19634 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19638 ----------------------
19639 -- Profile_Warnings --
19640 ----------------------
19642 -- pragma Profile_Warnings (profile_IDENTIFIER);
19644 -- profile_IDENTIFIER => Restricted | Ravenscar
19646 when Pragma_Profile_Warnings
=>
19648 Check_Arg_Count
(1);
19649 Check_Valid_Configuration_Pragma
;
19650 Check_No_Identifiers
;
19653 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19656 if Chars
(Argx
) = Name_Ravenscar
then
19657 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
19659 elsif Chars
(Argx
) = Name_Restricted
then
19660 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
19662 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19663 Set_Profile_Restrictions
19664 (No_Implementation_Extensions
, N
, Warn
=> True);
19667 Error_Pragma_Arg
("& is not a valid profile", Argx
);
19671 --------------------------
19672 -- Propagate_Exceptions --
19673 --------------------------
19675 -- pragma Propagate_Exceptions;
19677 -- Note: this pragma is obsolete and has no effect
19679 when Pragma_Propagate_Exceptions
=>
19681 Check_Arg_Count
(0);
19683 if Warn_On_Obsolescent_Feature
then
19685 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
19686 "and has no effect?j?", N
);
19689 -----------------------------
19690 -- Provide_Shift_Operators --
19691 -----------------------------
19693 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
19695 when Pragma_Provide_Shift_Operators
=>
19696 Provide_Shift_Operators
: declare
19699 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
19700 -- Insert declaration and pragma Instrinsic for named shift op
19702 ----------------------------
19703 -- Declare_Shift_Operator --
19704 ----------------------------
19706 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
19712 Make_Subprogram_Declaration
(Loc
,
19713 Make_Function_Specification
(Loc
,
19714 Defining_Unit_Name
=>
19715 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
19717 Result_Definition
=>
19718 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
19720 Parameter_Specifications
=> New_List
(
19721 Make_Parameter_Specification
(Loc
,
19722 Defining_Identifier
=>
19723 Make_Defining_Identifier
(Loc
, Name_Value
),
19725 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
19727 Make_Parameter_Specification
(Loc
,
19728 Defining_Identifier
=>
19729 Make_Defining_Identifier
(Loc
, Name_Amount
),
19731 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
19735 Chars
=> Name_Import
,
19736 Pragma_Argument_Associations
=> New_List
(
19737 Make_Pragma_Argument_Association
(Loc
,
19738 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
19739 Make_Pragma_Argument_Association
(Loc
,
19740 Expression
=> Make_Identifier
(Loc
, Nam
))));
19742 Insert_After
(N
, Import
);
19743 Insert_After
(N
, Func
);
19744 end Declare_Shift_Operator
;
19746 -- Start of processing for Provide_Shift_Operators
19750 Check_Arg_Count
(1);
19751 Check_Arg_Is_Local_Name
(Arg1
);
19753 Arg1
:= Get_Pragma_Arg
(Arg1
);
19755 -- We must have an entity name
19757 if not Is_Entity_Name
(Arg1
) then
19759 ("pragma % must apply to integer first subtype", Arg1
);
19762 -- If no Entity, means there was a prior error so ignore
19764 if Present
(Entity
(Arg1
)) then
19765 Ent
:= Entity
(Arg1
);
19767 -- Apply error checks
19769 if not Is_First_Subtype
(Ent
) then
19771 ("cannot apply pragma %",
19772 "\& is not a first subtype",
19775 elsif not Is_Integer_Type
(Ent
) then
19777 ("cannot apply pragma %",
19778 "\& is not an integer type",
19781 elsif Has_Shift_Operator
(Ent
) then
19783 ("cannot apply pragma %",
19784 "\& already has declared shift operators",
19787 elsif Is_Frozen
(Ent
) then
19789 ("pragma % appears too late",
19790 "\& is already frozen",
19794 -- Now declare the operators. We do this during analysis rather
19795 -- than expansion, since we want the operators available if we
19796 -- are operating in -gnatc or ASIS mode.
19798 Declare_Shift_Operator
(Name_Rotate_Left
);
19799 Declare_Shift_Operator
(Name_Rotate_Right
);
19800 Declare_Shift_Operator
(Name_Shift_Left
);
19801 Declare_Shift_Operator
(Name_Shift_Right
);
19802 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
19804 end Provide_Shift_Operators
;
19810 -- pragma Psect_Object (
19811 -- [Internal =>] LOCAL_NAME,
19812 -- [, [External =>] EXTERNAL_SYMBOL]
19813 -- [, [Size =>] EXTERNAL_SYMBOL]);
19815 when Pragma_Common_Object
19816 | Pragma_Psect_Object
19818 Psect_Object
: declare
19819 Args
: Args_List
(1 .. 3);
19820 Names
: constant Name_List
(1 .. 3) := (
19825 Internal
: Node_Id
renames Args
(1);
19826 External
: Node_Id
renames Args
(2);
19827 Size
: Node_Id
renames Args
(3);
19829 Def_Id
: Entity_Id
;
19831 procedure Check_Arg
(Arg
: Node_Id
);
19832 -- Checks that argument is either a string literal or an
19833 -- identifier, and posts error message if not.
19839 procedure Check_Arg
(Arg
: Node_Id
) is
19841 if not Nkind_In
(Original_Node
(Arg
),
19846 ("inappropriate argument for pragma %", Arg
);
19850 -- Start of processing for Common_Object/Psect_Object
19854 Gather_Associations
(Names
, Args
);
19855 Process_Extended_Import_Export_Internal_Arg
(Internal
);
19857 Def_Id
:= Entity
(Internal
);
19859 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
19861 ("pragma% must designate an object", Internal
);
19864 Check_Arg
(Internal
);
19866 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
19868 ("cannot use pragma% for imported/exported object",
19872 if Is_Concurrent_Type
(Etype
(Internal
)) then
19874 ("cannot specify pragma % for task/protected object",
19878 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
19880 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
19882 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
19885 if Ekind
(Def_Id
) = E_Constant
then
19887 ("cannot specify pragma % for a constant", Internal
);
19890 if Is_Record_Type
(Etype
(Internal
)) then
19896 Ent
:= First_Entity
(Etype
(Internal
));
19897 while Present
(Ent
) loop
19898 Decl
:= Declaration_Node
(Ent
);
19900 if Ekind
(Ent
) = E_Component
19901 and then Nkind
(Decl
) = N_Component_Declaration
19902 and then Present
(Expression
(Decl
))
19903 and then Warn_On_Export_Import
19906 ("?x?object for pragma % has defaults", Internal
);
19916 if Present
(Size
) then
19920 if Present
(External
) then
19921 Check_Arg_Is_External_Name
(External
);
19924 -- If all error tests pass, link pragma on to the rep item chain
19926 Record_Rep_Item
(Def_Id
, N
);
19933 -- pragma Pure [(library_unit_NAME)];
19935 when Pragma_Pure
=> Pure
: declare
19939 Check_Ada_83_Warning
;
19941 -- If the pragma comes from a subprogram instantiation, nothing to
19942 -- check, this can happen at any level of nesting.
19944 if Is_Wrapper_Package
(Current_Scope
) then
19947 Check_Valid_Library_Unit_Pragma
;
19950 if Nkind
(N
) = N_Null_Statement
then
19954 Ent
:= Find_Lib_Unit_Name
;
19956 -- A pragma that applies to a Ghost entity becomes Ghost for the
19957 -- purposes of legality checks and removal of ignored Ghost code.
19959 Mark_Ghost_Pragma
(N
, Ent
);
19961 if not Debug_Flag_U
then
19963 Set_Has_Pragma_Pure
(Ent
);
19964 Set_Suppress_Elaboration_Warnings
(Ent
);
19968 -------------------
19969 -- Pure_Function --
19970 -------------------
19972 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
19974 when Pragma_Pure_Function
=> Pure_Function
: declare
19975 Def_Id
: Entity_Id
;
19978 Effective
: Boolean := False;
19982 Check_Arg_Count
(1);
19983 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19984 Check_Arg_Is_Local_Name
(Arg1
);
19985 E_Id
:= Get_Pragma_Arg
(Arg1
);
19987 if Error_Posted
(E_Id
) then
19991 -- Loop through homonyms (overloadings) of referenced entity
19993 E
:= Entity
(E_Id
);
19995 -- A pragma that applies to a Ghost entity becomes Ghost for the
19996 -- purposes of legality checks and removal of ignored Ghost code.
19998 Mark_Ghost_Pragma
(N
, E
);
20000 if Present
(E
) then
20002 Def_Id
:= Get_Base_Subprogram
(E
);
20004 if not Ekind_In
(Def_Id
, E_Function
,
20005 E_Generic_Function
,
20009 ("pragma% requires a function name", Arg1
);
20012 Set_Is_Pure
(Def_Id
);
20014 if not Has_Pragma_Pure_Function
(Def_Id
) then
20015 Set_Has_Pragma_Pure_Function
(Def_Id
);
20019 exit when From_Aspect_Specification
(N
);
20021 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
20025 and then Warn_On_Redundant_Constructs
20028 ("pragma Pure_Function on& is redundant?r?",
20034 --------------------
20035 -- Queuing_Policy --
20036 --------------------
20038 -- pragma Queuing_Policy (policy_IDENTIFIER);
20040 when Pragma_Queuing_Policy
=> declare
20044 Check_Ada_83_Warning
;
20045 Check_Arg_Count
(1);
20046 Check_No_Identifiers
;
20047 Check_Arg_Is_Queuing_Policy
(Arg1
);
20048 Check_Valid_Configuration_Pragma
;
20049 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20050 QP
:= Fold_Upper
(Name_Buffer
(1));
20052 if Queuing_Policy
/= ' '
20053 and then Queuing_Policy
/= QP
20055 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
20056 Error_Pragma
("queuing policy incompatible with policy#");
20058 -- Set new policy, but always preserve System_Location since we
20059 -- like the error message with the run time name.
20062 Queuing_Policy
:= QP
;
20064 if Queuing_Policy_Sloc
/= System_Location
then
20065 Queuing_Policy_Sloc
:= Loc
;
20074 -- pragma Rational, for compatibility with foreign compiler
20076 when Pragma_Rational
=>
20077 Set_Rational_Profile
;
20079 ---------------------
20080 -- Refined_Depends --
20081 ---------------------
20083 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20085 -- DEPENDENCY_RELATION ::=
20087 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20089 -- DEPENDENCY_CLAUSE ::=
20090 -- OUTPUT_LIST =>[+] INPUT_LIST
20091 -- | NULL_DEPENDENCY_CLAUSE
20093 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20095 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20097 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20099 -- OUTPUT ::= NAME | FUNCTION_RESULT
20102 -- where FUNCTION_RESULT is a function Result attribute_reference
20104 -- Characteristics:
20106 -- * Analysis - The annotation undergoes initial checks to verify
20107 -- the legal placement and context. Secondary checks fully analyze
20108 -- the dependency clauses/global list in:
20110 -- Analyze_Refined_Depends_In_Decl_Part
20112 -- * Expansion - None.
20114 -- * Template - The annotation utilizes the generic template of the
20115 -- related subprogram body.
20117 -- * Globals - Capture of global references must occur after full
20120 -- * Instance - The annotation is instantiated automatically when
20121 -- the related generic subprogram body is instantiated.
20123 when Pragma_Refined_Depends
=> Refined_Depends
: declare
20124 Body_Id
: Entity_Id
;
20126 Spec_Id
: Entity_Id
;
20129 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20133 -- Chain the pragma on the contract for further processing by
20134 -- Analyze_Refined_Depends_In_Decl_Part.
20136 Add_Contract_Item
(N
, Body_Id
);
20138 -- The legality checks of pragmas Refined_Depends and
20139 -- Refined_Global are affected by the SPARK mode in effect and
20140 -- the volatility of the context. In addition these two pragmas
20141 -- are subject to an inherent order:
20143 -- 1) Refined_Global
20144 -- 2) Refined_Depends
20146 -- Analyze all these pragmas in the order outlined above
20148 Analyze_If_Present
(Pragma_SPARK_Mode
);
20149 Analyze_If_Present
(Pragma_Volatile_Function
);
20150 Analyze_If_Present
(Pragma_Refined_Global
);
20151 Analyze_Refined_Depends_In_Decl_Part
(N
);
20153 end Refined_Depends
;
20155 --------------------
20156 -- Refined_Global --
20157 --------------------
20159 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20161 -- GLOBAL_SPECIFICATION ::=
20164 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20166 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20168 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20169 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20170 -- GLOBAL_ITEM ::= NAME
20172 -- Characteristics:
20174 -- * Analysis - The annotation undergoes initial checks to verify
20175 -- the legal placement and context. Secondary checks fully analyze
20176 -- the dependency clauses/global list in:
20178 -- Analyze_Refined_Global_In_Decl_Part
20180 -- * Expansion - None.
20182 -- * Template - The annotation utilizes the generic template of the
20183 -- related subprogram body.
20185 -- * Globals - Capture of global references must occur after full
20188 -- * Instance - The annotation is instantiated automatically when
20189 -- the related generic subprogram body is instantiated.
20191 when Pragma_Refined_Global
=> Refined_Global
: declare
20192 Body_Id
: Entity_Id
;
20194 Spec_Id
: Entity_Id
;
20197 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20201 -- Chain the pragma on the contract for further processing by
20202 -- Analyze_Refined_Global_In_Decl_Part.
20204 Add_Contract_Item
(N
, Body_Id
);
20206 -- The legality checks of pragmas Refined_Depends and
20207 -- Refined_Global are affected by the SPARK mode in effect and
20208 -- the volatility of the context. In addition these two pragmas
20209 -- are subject to an inherent order:
20211 -- 1) Refined_Global
20212 -- 2) Refined_Depends
20214 -- Analyze all these pragmas in the order outlined above
20216 Analyze_If_Present
(Pragma_SPARK_Mode
);
20217 Analyze_If_Present
(Pragma_Volatile_Function
);
20218 Analyze_Refined_Global_In_Decl_Part
(N
);
20219 Analyze_If_Present
(Pragma_Refined_Depends
);
20221 end Refined_Global
;
20227 -- pragma Refined_Post (boolean_EXPRESSION);
20229 -- Characteristics:
20231 -- * Analysis - The annotation is fully analyzed immediately upon
20232 -- elaboration as it cannot forward reference entities.
20234 -- * Expansion - The annotation is expanded during the expansion of
20235 -- the related subprogram body contract as performed in:
20237 -- Expand_Subprogram_Contract
20239 -- * Template - The annotation utilizes the generic template of the
20240 -- related subprogram body.
20242 -- * Globals - Capture of global references must occur after full
20245 -- * Instance - The annotation is instantiated automatically when
20246 -- the related generic subprogram body is instantiated.
20248 when Pragma_Refined_Post
=> Refined_Post
: declare
20249 Body_Id
: Entity_Id
;
20251 Spec_Id
: Entity_Id
;
20254 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20256 -- Fully analyze the pragma when it appears inside a subprogram
20257 -- body because it cannot benefit from forward references.
20261 -- Chain the pragma on the contract for completeness
20263 Add_Contract_Item
(N
, Body_Id
);
20265 -- The legality checks of pragma Refined_Post are affected by
20266 -- the SPARK mode in effect and the volatility of the context.
20267 -- Analyze all pragmas in a specific order.
20269 Analyze_If_Present
(Pragma_SPARK_Mode
);
20270 Analyze_If_Present
(Pragma_Volatile_Function
);
20271 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
20273 -- Currently it is not possible to inline pre/postconditions on
20274 -- a subprogram subject to pragma Inline_Always.
20276 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
20280 -------------------
20281 -- Refined_State --
20282 -------------------
20284 -- pragma Refined_State (REFINEMENT_LIST);
20286 -- REFINEMENT_LIST ::=
20287 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20289 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20291 -- CONSTITUENT_LIST ::=
20294 -- | (CONSTITUENT {, CONSTITUENT})
20296 -- CONSTITUENT ::= object_NAME | state_NAME
20298 -- Characteristics:
20300 -- * Analysis - The annotation undergoes initial checks to verify
20301 -- the legal placement and context. Secondary checks preanalyze the
20302 -- refinement clauses in:
20304 -- Analyze_Refined_State_In_Decl_Part
20306 -- * Expansion - None.
20308 -- * Template - The annotation utilizes the template of the related
20311 -- * Globals - Capture of global references must occur after full
20314 -- * Instance - The annotation is instantiated automatically when
20315 -- the related generic package body is instantiated.
20317 when Pragma_Refined_State
=> Refined_State
: declare
20318 Pack_Decl
: Node_Id
;
20319 Spec_Id
: Entity_Id
;
20323 Check_No_Identifiers
;
20324 Check_Arg_Count
(1);
20326 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
20328 -- Ensure the proper placement of the pragma. Refined states must
20329 -- be associated with a package body.
20331 if Nkind
(Pack_Decl
) = N_Package_Body
then
20334 -- Otherwise the pragma is associated with an illegal construct
20341 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
20343 -- A pragma that applies to a Ghost entity becomes Ghost for the
20344 -- purposes of legality checks and removal of ignored Ghost code.
20346 Mark_Ghost_Pragma
(N
, Spec_Id
);
20348 -- Chain the pragma on the contract for further processing by
20349 -- Analyze_Refined_State_In_Decl_Part.
20351 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
20353 -- The legality checks of pragma Refined_State are affected by the
20354 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20356 Analyze_If_Present
(Pragma_SPARK_Mode
);
20358 -- State refinement is allowed only when the corresponding package
20359 -- declaration has non-null pragma Abstract_State. Refinement not
20360 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20362 if SPARK_Mode
/= Off
20364 (No
(Abstract_States
(Spec_Id
))
20365 or else Has_Null_Abstract_State
(Spec_Id
))
20368 ("useless refinement, package & does not define abstract "
20369 & "states", N
, Spec_Id
);
20374 -----------------------
20375 -- Relative_Deadline --
20376 -----------------------
20378 -- pragma Relative_Deadline (time_span_EXPRESSION);
20380 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
20381 P
: constant Node_Id
:= Parent
(N
);
20386 Check_No_Identifiers
;
20387 Check_Arg_Count
(1);
20389 Arg
:= Get_Pragma_Arg
(Arg1
);
20391 -- The expression must be analyzed in the special manner described
20392 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20394 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
20398 if Nkind
(P
) = N_Subprogram_Body
then
20399 Check_In_Main_Program
;
20401 -- Only Task and subprogram cases allowed
20403 elsif Nkind
(P
) /= N_Task_Definition
then
20407 -- Check duplicate pragma before we set the corresponding flag
20409 if Has_Relative_Deadline_Pragma
(P
) then
20410 Error_Pragma
("duplicate pragma% not allowed");
20413 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20414 -- Relative_Deadline pragma node cannot be inserted in the Rep
20415 -- Item chain of Ent since it is rewritten by the expander as a
20416 -- procedure call statement that will break the chain.
20418 Set_Has_Relative_Deadline_Pragma
(P
);
20419 end Relative_Deadline
;
20421 ------------------------
20422 -- Remote_Access_Type --
20423 ------------------------
20425 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20427 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
20432 Check_Arg_Count
(1);
20433 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20434 Check_Arg_Is_Local_Name
(Arg1
);
20436 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
20438 -- A pragma that applies to a Ghost entity becomes Ghost for the
20439 -- purposes of legality checks and removal of ignored Ghost code.
20441 Mark_Ghost_Pragma
(N
, E
);
20443 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
20444 and then Ekind
(E
) = E_General_Access_Type
20445 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
20446 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
20448 and then Is_Valid_Remote_Object_Type
20449 (Root_Type
(Directly_Designated_Type
(E
)))
20451 Set_Is_Remote_Types
(E
);
20455 ("pragma% applies only to formal access-to-class-wide types",
20458 end Remote_Access_Type
;
20460 ---------------------------
20461 -- Remote_Call_Interface --
20462 ---------------------------
20464 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20466 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
20467 Cunit_Node
: Node_Id
;
20468 Cunit_Ent
: Entity_Id
;
20472 Check_Ada_83_Warning
;
20473 Check_Valid_Library_Unit_Pragma
;
20475 if Nkind
(N
) = N_Null_Statement
then
20479 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20480 K
:= Nkind
(Unit
(Cunit_Node
));
20481 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20483 -- A pragma that applies to a Ghost entity becomes Ghost for the
20484 -- purposes of legality checks and removal of ignored Ghost code.
20486 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20488 if K
= N_Package_Declaration
20489 or else K
= N_Generic_Package_Declaration
20490 or else K
= N_Subprogram_Declaration
20491 or else K
= N_Generic_Subprogram_Declaration
20492 or else (K
= N_Subprogram_Body
20493 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
20498 "pragma% must apply to package or subprogram declaration");
20501 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
20502 end Remote_Call_Interface
;
20508 -- pragma Remote_Types [(library_unit_NAME)];
20510 when Pragma_Remote_Types
=> Remote_Types
: declare
20511 Cunit_Node
: Node_Id
;
20512 Cunit_Ent
: Entity_Id
;
20515 Check_Ada_83_Warning
;
20516 Check_Valid_Library_Unit_Pragma
;
20518 if Nkind
(N
) = N_Null_Statement
then
20522 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20523 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20525 -- A pragma that applies to a Ghost entity becomes Ghost for the
20526 -- purposes of legality checks and removal of ignored Ghost code.
20528 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20530 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20531 N_Generic_Package_Declaration
)
20534 ("pragma% can only apply to a package declaration");
20537 Set_Is_Remote_Types
(Cunit_Ent
);
20544 -- pragma Ravenscar;
20546 when Pragma_Ravenscar
=>
20548 Check_Arg_Count
(0);
20549 Check_Valid_Configuration_Pragma
;
20550 Set_Ravenscar_Profile
(Ravenscar
, N
);
20552 if Warn_On_Obsolescent_Feature
then
20554 ("pragma Ravenscar is an obsolescent feature?j?", N
);
20556 ("|use pragma Profile (Ravenscar) instead?j?", N
);
20559 -------------------------
20560 -- Restricted_Run_Time --
20561 -------------------------
20563 -- pragma Restricted_Run_Time;
20565 when Pragma_Restricted_Run_Time
=>
20567 Check_Arg_Count
(0);
20568 Check_Valid_Configuration_Pragma
;
20569 Set_Profile_Restrictions
20570 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
20572 if Warn_On_Obsolescent_Feature
then
20574 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20577 ("|use pragma Profile (Restricted) instead?j?", N
);
20584 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20587 -- restriction_IDENTIFIER
20588 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20590 when Pragma_Restrictions
=>
20591 Process_Restrictions_Or_Restriction_Warnings
20592 (Warn
=> Treat_Restrictions_As_Warnings
);
20594 --------------------------
20595 -- Restriction_Warnings --
20596 --------------------------
20598 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20601 -- restriction_IDENTIFIER
20602 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20604 when Pragma_Restriction_Warnings
=>
20606 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
20612 -- pragma Reviewable;
20614 when Pragma_Reviewable
=>
20615 Check_Ada_83_Warning
;
20616 Check_Arg_Count
(0);
20618 -- Call dummy debugging function rv. This is done to assist front
20619 -- end debugging. By placing a Reviewable pragma in the source
20620 -- program, a breakpoint on rv catches this place in the source,
20621 -- allowing convenient stepping to the point of interest.
20625 --------------------------
20626 -- Secondary_Stack_Size --
20627 --------------------------
20629 -- pragma Secondary_Stack_Size (EXPRESSION);
20631 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
20632 P
: constant Node_Id
:= Parent
(N
);
20638 Check_No_Identifiers
;
20639 Check_Arg_Count
(1);
20641 if Nkind
(P
) = N_Task_Definition
then
20642 Arg
:= Get_Pragma_Arg
(Arg1
);
20643 Ent
:= Defining_Identifier
(Parent
(P
));
20645 -- The expression must be analyzed in the special manner
20646 -- described in "Handling of Default Expressions" in sem.ads.
20648 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
20650 -- The pragma cannot appear if the No_Secondary_Stack
20651 -- restriction is in effect.
20653 Check_Restriction
(No_Secondary_Stack
, Arg
);
20655 -- Anything else is incorrect
20661 -- Check duplicate pragma before we chain the pragma in the Rep
20662 -- Item chain of Ent.
20664 Check_Duplicate_Pragma
(Ent
);
20665 Record_Rep_Item
(Ent
, N
);
20666 end Secondary_Stack_Size
;
20668 --------------------------
20669 -- Short_Circuit_And_Or --
20670 --------------------------
20672 -- pragma Short_Circuit_And_Or;
20674 when Pragma_Short_Circuit_And_Or
=>
20676 Check_Arg_Count
(0);
20677 Check_Valid_Configuration_Pragma
;
20678 Short_Circuit_And_Or
:= True;
20680 -------------------
20681 -- Share_Generic --
20682 -------------------
20684 -- pragma Share_Generic (GNAME {, GNAME});
20686 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
20688 when Pragma_Share_Generic
=>
20690 Process_Generic_List
;
20696 -- pragma Shared (LOCAL_NAME);
20698 when Pragma_Shared
=>
20700 Process_Atomic_Independent_Shared_Volatile
;
20702 --------------------
20703 -- Shared_Passive --
20704 --------------------
20706 -- pragma Shared_Passive [(library_unit_NAME)];
20708 -- Set the flag Is_Shared_Passive of program unit name entity
20710 when Pragma_Shared_Passive
=> Shared_Passive
: declare
20711 Cunit_Node
: Node_Id
;
20712 Cunit_Ent
: Entity_Id
;
20715 Check_Ada_83_Warning
;
20716 Check_Valid_Library_Unit_Pragma
;
20718 if Nkind
(N
) = N_Null_Statement
then
20722 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20723 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20725 -- A pragma that applies to a Ghost entity becomes Ghost for the
20726 -- purposes of legality checks and removal of ignored Ghost code.
20728 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20730 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20731 N_Generic_Package_Declaration
)
20734 ("pragma% can only apply to a package declaration");
20737 Set_Is_Shared_Passive
(Cunit_Ent
);
20738 end Shared_Passive
;
20740 -----------------------
20741 -- Short_Descriptors --
20742 -----------------------
20744 -- pragma Short_Descriptors;
20746 -- Recognize and validate, but otherwise ignore
20748 when Pragma_Short_Descriptors
=>
20750 Check_Arg_Count
(0);
20751 Check_Valid_Configuration_Pragma
;
20753 ------------------------------
20754 -- Simple_Storage_Pool_Type --
20755 ------------------------------
20757 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
20759 when Pragma_Simple_Storage_Pool_Type
=>
20760 Simple_Storage_Pool_Type
: declare
20766 Check_Arg_Count
(1);
20767 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
20769 Type_Id
:= Get_Pragma_Arg
(Arg1
);
20770 Find_Type
(Type_Id
);
20771 Typ
:= Entity
(Type_Id
);
20773 if Typ
= Any_Type
then
20777 -- A pragma that applies to a Ghost entity becomes Ghost for the
20778 -- purposes of legality checks and removal of ignored Ghost code.
20780 Mark_Ghost_Pragma
(N
, Typ
);
20782 -- We require the pragma to apply to a type declared in a package
20783 -- declaration, but not (immediately) within a package body.
20785 if Ekind
(Current_Scope
) /= E_Package
20786 or else In_Package_Body
(Current_Scope
)
20789 ("pragma% can only apply to type declared immediately "
20790 & "within a package declaration");
20793 -- A simple storage pool type must be an immutably limited record
20794 -- or private type. If the pragma is given for a private type,
20795 -- the full type is similarly restricted (which is checked later
20796 -- in Freeze_Entity).
20798 if Is_Record_Type
(Typ
)
20799 and then not Is_Limited_View
(Typ
)
20802 ("pragma% can only apply to explicitly limited record type");
20804 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
20806 ("pragma% can only apply to a private type that is limited");
20808 elsif not Is_Record_Type
(Typ
)
20809 and then not Is_Private_Type
(Typ
)
20812 ("pragma% can only apply to limited record or private type");
20815 Record_Rep_Item
(Typ
, N
);
20816 end Simple_Storage_Pool_Type
;
20818 ----------------------
20819 -- Source_File_Name --
20820 ----------------------
20822 -- There are five forms for this pragma:
20824 -- pragma Source_File_Name (
20825 -- [UNIT_NAME =>] unit_NAME,
20826 -- BODY_FILE_NAME => STRING_LITERAL
20827 -- [, [INDEX =>] INTEGER_LITERAL]);
20829 -- pragma Source_File_Name (
20830 -- [UNIT_NAME =>] unit_NAME,
20831 -- SPEC_FILE_NAME => STRING_LITERAL
20832 -- [, [INDEX =>] INTEGER_LITERAL]);
20834 -- pragma Source_File_Name (
20835 -- BODY_FILE_NAME => STRING_LITERAL
20836 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20837 -- [, CASING => CASING_SPEC]);
20839 -- pragma Source_File_Name (
20840 -- SPEC_FILE_NAME => STRING_LITERAL
20841 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20842 -- [, CASING => CASING_SPEC]);
20844 -- pragma Source_File_Name (
20845 -- SUBUNIT_FILE_NAME => STRING_LITERAL
20846 -- [, DOT_REPLACEMENT => STRING_LITERAL]
20847 -- [, CASING => CASING_SPEC]);
20849 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
20851 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
20852 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
20853 -- only be used when no project file is used, while SFNP can only be
20854 -- used when a project file is used.
20856 -- No processing here. Processing was completed during parsing, since
20857 -- we need to have file names set as early as possible. Units are
20858 -- loaded well before semantic processing starts.
20860 -- The only processing we defer to this point is the check for
20861 -- correct placement.
20863 when Pragma_Source_File_Name
=>
20865 Check_Valid_Configuration_Pragma
;
20867 ------------------------------
20868 -- Source_File_Name_Project --
20869 ------------------------------
20871 -- See Source_File_Name for syntax
20873 -- No processing here. Processing was completed during parsing, since
20874 -- we need to have file names set as early as possible. Units are
20875 -- loaded well before semantic processing starts.
20877 -- The only processing we defer to this point is the check for
20878 -- correct placement.
20880 when Pragma_Source_File_Name_Project
=>
20882 Check_Valid_Configuration_Pragma
;
20884 -- Check that a pragma Source_File_Name_Project is used only in a
20885 -- configuration pragmas file.
20887 -- Pragmas Source_File_Name_Project should only be generated by
20888 -- the Project Manager in configuration pragmas files.
20890 -- This is really an ugly test. It seems to depend on some
20891 -- accidental and undocumented property. At the very least it
20892 -- needs to be documented, but it would be better to have a
20893 -- clean way of testing if we are in a configuration file???
20895 if Present
(Parent
(N
)) then
20897 ("pragma% can only appear in a configuration pragmas file");
20900 ----------------------
20901 -- Source_Reference --
20902 ----------------------
20904 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
20906 -- Nothing to do, all processing completed in Par.Prag, since we need
20907 -- the information for possible parser messages that are output.
20909 when Pragma_Source_Reference
=>
20916 -- pragma SPARK_Mode [(On | Off)];
20918 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
20919 Mode_Id
: SPARK_Mode_Type
;
20921 procedure Check_Pragma_Conformance
20922 (Context_Pragma
: Node_Id
;
20923 Entity
: Entity_Id
;
20924 Entity_Pragma
: Node_Id
);
20925 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
20926 -- conformance of pragma N depending the following scenarios:
20928 -- If pragma Context_Pragma is not Empty, verify that pragma N is
20929 -- compatible with the pragma Context_Pragma that was inherited
20930 -- from the context:
20931 -- * If the mode of Context_Pragma is ON, then the new mode can
20933 -- * If the mode of Context_Pragma is OFF, then the only allowed
20934 -- new mode is also OFF. Emit error if this is not the case.
20936 -- If Entity is not Empty, verify that pragma N is compatible with
20937 -- pragma Entity_Pragma that belongs to Entity.
20938 -- * If Entity_Pragma is Empty, always issue an error as this
20939 -- corresponds to the case where a previous section of Entity
20940 -- has no SPARK_Mode set.
20941 -- * If the mode of Entity_Pragma is ON, then the new mode can
20943 -- * If the mode of Entity_Pragma is OFF, then the only allowed
20944 -- new mode is also OFF. Emit error if this is not the case.
20946 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
20947 -- Subsidiary to routines Process_xxx. Verify that the related
20948 -- entity E subject to pragma SPARK_Mode is library-level.
20950 procedure Process_Body
(Decl
: Node_Id
);
20951 -- Verify the legality of pragma SPARK_Mode when it appears as the
20952 -- top of the body declarations of entry, package, protected unit,
20953 -- subprogram or task unit body denoted by Decl.
20955 procedure Process_Overloadable
(Decl
: Node_Id
);
20956 -- Verify the legality of pragma SPARK_Mode when it applies to an
20957 -- entry or [generic] subprogram declaration denoted by Decl.
20959 procedure Process_Private_Part
(Decl
: Node_Id
);
20960 -- Verify the legality of pragma SPARK_Mode when it appears at the
20961 -- top of the private declarations of a package spec, protected or
20962 -- task unit declaration denoted by Decl.
20964 procedure Process_Statement_Part
(Decl
: Node_Id
);
20965 -- Verify the legality of pragma SPARK_Mode when it appears at the
20966 -- top of the statement sequence of a package body denoted by node
20969 procedure Process_Visible_Part
(Decl
: Node_Id
);
20970 -- Verify the legality of pragma SPARK_Mode when it appears at the
20971 -- top of the visible declarations of a package spec, protected or
20972 -- task unit declaration denoted by Decl. The routine is also used
20973 -- on protected or task units declared without a definition.
20975 procedure Set_SPARK_Context
;
20976 -- Subsidiary to routines Process_xxx. Set the global variables
20977 -- which represent the mode of the context from pragma N. Ensure
20978 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
20980 ------------------------------
20981 -- Check_Pragma_Conformance --
20982 ------------------------------
20984 procedure Check_Pragma_Conformance
20985 (Context_Pragma
: Node_Id
;
20986 Entity
: Entity_Id
;
20987 Entity_Pragma
: Node_Id
)
20989 Err_Id
: Entity_Id
;
20993 -- The current pragma may appear without an argument. If this
20994 -- is the case, associate all error messages with the pragma
20997 if Present
(Arg1
) then
21003 -- The mode of the current pragma is compared against that of
21004 -- an enclosing context.
21006 if Present
(Context_Pragma
) then
21007 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
21009 -- Issue an error if the new mode is less restrictive than
21010 -- that of the context.
21012 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
21013 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21016 ("cannot change SPARK_Mode from Off to On", Err_N
);
21017 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21018 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
21023 -- The mode of the current pragma is compared against that of
21024 -- an initial package, protected type, subprogram or task type
21027 if Present
(Entity
) then
21029 -- A simple protected or task type is transformed into an
21030 -- anonymous type whose name cannot be used to issue error
21031 -- messages. Recover the original entity of the type.
21033 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
21036 (Original_Node
(Unit_Declaration_Node
(Entity
)));
21041 -- Both the initial declaration and the completion carry
21042 -- SPARK_Mode pragmas.
21044 if Present
(Entity_Pragma
) then
21045 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
21047 -- Issue an error if the new mode is less restrictive
21048 -- than that of the initial declaration.
21050 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
21051 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21053 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21054 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
21056 ("\value Off was set for SPARK_Mode on&#",
21061 -- Otherwise the initial declaration lacks a SPARK_Mode
21062 -- pragma in which case the current pragma is illegal as
21063 -- it cannot "complete".
21066 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21067 Error_Msg_Sloc
:= Sloc
(Err_Id
);
21069 ("\no value was set for SPARK_Mode on&#",
21074 end Check_Pragma_Conformance
;
21076 --------------------------------
21077 -- Check_Library_Level_Entity --
21078 --------------------------------
21080 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
21081 procedure Add_Entity_To_Name_Buffer
;
21082 -- Add the E_Kind of entity E to the name buffer
21084 -------------------------------
21085 -- Add_Entity_To_Name_Buffer --
21086 -------------------------------
21088 procedure Add_Entity_To_Name_Buffer
is
21090 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
21091 Add_Str_To_Name_Buffer
("entry");
21093 elsif Ekind_In
(E
, E_Generic_Package
,
21097 Add_Str_To_Name_Buffer
("package");
21099 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
21100 Add_Str_To_Name_Buffer
("protected type");
21102 elsif Ekind_In
(E
, E_Function
,
21103 E_Generic_Function
,
21104 E_Generic_Procedure
,
21108 Add_Str_To_Name_Buffer
("subprogram");
21111 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
21112 Add_Str_To_Name_Buffer
("task type");
21114 end Add_Entity_To_Name_Buffer
;
21118 Msg_1
: constant String := "incorrect placement of pragma%";
21121 -- Start of processing for Check_Library_Level_Entity
21124 if not Is_Library_Level_Entity
(E
) then
21125 Error_Msg_Name_1
:= Pname
;
21126 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
21129 Add_Str_To_Name_Buffer
("\& is not a library-level ");
21130 Add_Entity_To_Name_Buffer
;
21132 Msg_2
:= Name_Find
;
21133 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
21137 end Check_Library_Level_Entity
;
21143 procedure Process_Body
(Decl
: Node_Id
) is
21144 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21145 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
21148 -- Ignore pragma when applied to the special body created for
21149 -- inlining, recognized by its internal name _Parent.
21151 if Chars
(Body_Id
) = Name_uParent
then
21155 Check_Library_Level_Entity
(Body_Id
);
21157 -- For entry bodies, verify the legality against:
21158 -- * The mode of the context
21159 -- * The mode of the spec (if any)
21161 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
21163 -- A stand alone subprogram body
21165 if Body_Id
= Spec_Id
then
21166 Check_Pragma_Conformance
21167 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21169 Entity_Pragma
=> Empty
);
21171 -- An entry or subprogram body that completes a previous
21175 Check_Pragma_Conformance
21176 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21178 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21182 Set_SPARK_Pragma
(Body_Id
, N
);
21183 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21185 -- For package bodies, verify the legality against:
21186 -- * The mode of the context
21187 -- * The mode of the private part
21189 -- This case is separated from protected and task bodies
21190 -- because the statement part of the package body inherits
21191 -- the mode of the body declarations.
21193 elsif Nkind
(Decl
) = N_Package_Body
then
21194 Check_Pragma_Conformance
21195 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21197 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21200 Set_SPARK_Pragma
(Body_Id
, N
);
21201 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21202 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21203 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
21205 -- For protected and task bodies, verify the legality against:
21206 -- * The mode of the context
21207 -- * The mode of the private part
21211 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
21213 Check_Pragma_Conformance
21214 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21216 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21219 Set_SPARK_Pragma
(Body_Id
, N
);
21220 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21224 --------------------------
21225 -- Process_Overloadable --
21226 --------------------------
21228 procedure Process_Overloadable
(Decl
: Node_Id
) is
21229 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21230 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
21233 Check_Library_Level_Entity
(Spec_Id
);
21235 -- Verify the legality against:
21236 -- * The mode of the context
21238 Check_Pragma_Conformance
21239 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21241 Entity_Pragma
=> Empty
);
21243 Set_SPARK_Pragma
(Spec_Id
, N
);
21244 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21246 -- When the pragma applies to the anonymous object created for
21247 -- a single task type, decorate the type as well. This scenario
21248 -- arises when the single task type lacks a task definition,
21249 -- therefore there is no issue with respect to a potential
21250 -- pragma SPARK_Mode in the private part.
21252 -- task type Anon_Task_Typ;
21253 -- Obj : Anon_Task_Typ;
21254 -- pragma SPARK_Mode ...;
21256 if Is_Single_Task_Object
(Spec_Id
) then
21257 Set_SPARK_Pragma
(Spec_Typ
, N
);
21258 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
21259 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
21260 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
21262 end Process_Overloadable
;
21264 --------------------------
21265 -- Process_Private_Part --
21266 --------------------------
21268 procedure Process_Private_Part
(Decl
: Node_Id
) is
21269 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21272 Check_Library_Level_Entity
(Spec_Id
);
21274 -- Verify the legality against:
21275 -- * The mode of the visible declarations
21277 Check_Pragma_Conformance
21278 (Context_Pragma
=> Empty
,
21280 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21283 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21284 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
21285 end Process_Private_Part
;
21287 ----------------------------
21288 -- Process_Statement_Part --
21289 ----------------------------
21291 procedure Process_Statement_Part
(Decl
: Node_Id
) is
21292 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21295 Check_Library_Level_Entity
(Body_Id
);
21297 -- Verify the legality against:
21298 -- * The mode of the body declarations
21300 Check_Pragma_Conformance
21301 (Context_Pragma
=> Empty
,
21303 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
21306 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21307 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
21308 end Process_Statement_Part
;
21310 --------------------------
21311 -- Process_Visible_Part --
21312 --------------------------
21314 procedure Process_Visible_Part
(Decl
: Node_Id
) is
21315 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21316 Obj_Id
: Entity_Id
;
21319 Check_Library_Level_Entity
(Spec_Id
);
21321 -- Verify the legality against:
21322 -- * The mode of the context
21324 Check_Pragma_Conformance
21325 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21327 Entity_Pragma
=> Empty
);
21329 -- A task unit declared without a definition does not set the
21330 -- SPARK_Mode of the context because the task does not have any
21331 -- entries that could inherit the mode.
21333 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
21334 N_Task_Type_Declaration
)
21339 Set_SPARK_Pragma
(Spec_Id
, N
);
21340 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21341 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21342 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
21344 -- When the pragma applies to a single protected or task type,
21345 -- decorate the corresponding anonymous object as well.
21347 -- protected Anon_Prot_Typ is
21348 -- pragma SPARK_Mode ...;
21350 -- end Anon_Prot_Typ;
21352 -- Obj : Anon_Prot_Typ;
21354 if Is_Single_Concurrent_Type
(Spec_Id
) then
21355 Obj_Id
:= Anonymous_Object
(Spec_Id
);
21357 Set_SPARK_Pragma
(Obj_Id
, N
);
21358 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
21360 end Process_Visible_Part
;
21362 -----------------------
21363 -- Set_SPARK_Context --
21364 -----------------------
21366 procedure Set_SPARK_Context
is
21368 SPARK_Mode
:= Mode_Id
;
21369 SPARK_Mode_Pragma
:= N
;
21370 end Set_SPARK_Context
;
21378 -- Start of processing for Do_SPARK_Mode
21381 -- When a SPARK_Mode pragma appears inside an instantiation whose
21382 -- enclosing context has SPARK_Mode set to "off", the pragma has
21383 -- no semantic effect.
21385 if Ignore_Pragma_SPARK_Mode
then
21386 Rewrite
(N
, Make_Null_Statement
(Loc
));
21392 Check_No_Identifiers
;
21393 Check_At_Most_N_Arguments
(1);
21395 -- Check the legality of the mode (no argument = ON)
21397 if Arg_Count
= 1 then
21398 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21399 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
21404 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
21405 Context
:= Parent
(N
);
21407 -- The pragma appears in a configuration file
21409 if No
(Context
) then
21410 Check_Valid_Configuration_Pragma
;
21412 if Present
(SPARK_Mode_Pragma
) then
21413 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21414 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
21420 -- The pragma acts as a configuration pragma in a compilation unit
21422 -- pragma SPARK_Mode ...;
21423 -- package Pack is ...;
21425 elsif Nkind
(Context
) = N_Compilation_Unit
21426 and then List_Containing
(N
) = Context_Items
(Context
)
21428 Check_Valid_Configuration_Pragma
;
21431 -- Otherwise the placement of the pragma within the tree dictates
21432 -- its associated construct. Inspect the declarative list where
21433 -- the pragma resides to find a potential construct.
21437 while Present
(Stmt
) loop
21439 -- Skip prior pragmas, but check for duplicates. Note that
21440 -- this also takes care of pragmas generated for aspects.
21442 if Nkind
(Stmt
) = N_Pragma
then
21443 if Pragma_Name
(Stmt
) = Pname
then
21444 Error_Msg_Name_1
:= Pname
;
21445 Error_Msg_Sloc
:= Sloc
(Stmt
);
21446 Error_Msg_N
("pragma% duplicates pragma declared#", N
);
21450 -- The pragma applies to an expression function that has
21451 -- already been rewritten into a subprogram declaration.
21453 -- function Expr_Func return ... is (...);
21454 -- pragma SPARK_Mode ...;
21456 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
21457 and then Nkind
(Original_Node
(Stmt
)) =
21458 N_Expression_Function
21460 Process_Overloadable
(Stmt
);
21463 -- The pragma applies to the anonymous object created for a
21464 -- single concurrent type.
21466 -- protected type Anon_Prot_Typ ...;
21467 -- Obj : Anon_Prot_Typ;
21468 -- pragma SPARK_Mode ...;
21470 elsif Nkind
(Stmt
) = N_Object_Declaration
21471 and then Is_Single_Concurrent_Object
21472 (Defining_Entity
(Stmt
))
21474 Process_Overloadable
(Stmt
);
21477 -- Skip internally generated code
21479 elsif not Comes_From_Source
(Stmt
) then
21482 -- The pragma applies to an entry or [generic] subprogram
21486 -- pragma SPARK_Mode ...;
21489 -- procedure Proc ...;
21490 -- pragma SPARK_Mode ...;
21492 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
21493 N_Subprogram_Declaration
)
21494 or else (Nkind
(Stmt
) = N_Entry_Declaration
21495 and then Is_Protected_Type
21496 (Scope
(Defining_Entity
(Stmt
))))
21498 Process_Overloadable
(Stmt
);
21501 -- Otherwise the pragma does not apply to a legal construct
21502 -- or it does not appear at the top of a declarative or a
21503 -- statement list. Issue an error and stop the analysis.
21513 -- The pragma applies to a package or a subprogram that acts as
21514 -- a compilation unit.
21516 -- procedure Proc ...;
21517 -- pragma SPARK_Mode ...;
21519 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
21520 Context
:= Unit
(Parent
(Context
));
21523 -- The pragma appears at the top of entry, package, protected
21524 -- unit, subprogram or task unit body declarations.
21526 -- entry Ent when ... is
21527 -- pragma SPARK_Mode ...;
21529 -- package body Pack is
21530 -- pragma SPARK_Mode ...;
21532 -- procedure Proc ... is
21533 -- pragma SPARK_Mode;
21535 -- protected body Prot is
21536 -- pragma SPARK_Mode ...;
21538 if Nkind_In
(Context
, N_Entry_Body
,
21544 Process_Body
(Context
);
21546 -- The pragma appears at the top of the visible or private
21547 -- declaration of a package spec, protected or task unit.
21550 -- pragma SPARK_Mode ...;
21552 -- pragma SPARK_Mode ...;
21554 -- protected [type] Prot is
21555 -- pragma SPARK_Mode ...;
21557 -- pragma SPARK_Mode ...;
21559 elsif Nkind_In
(Context
, N_Package_Specification
,
21560 N_Protected_Definition
,
21563 if List_Containing
(N
) = Visible_Declarations
(Context
) then
21564 Process_Visible_Part
(Parent
(Context
));
21566 Process_Private_Part
(Parent
(Context
));
21569 -- The pragma appears at the top of package body statements
21571 -- package body Pack is
21573 -- pragma SPARK_Mode;
21575 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
21576 and then Nkind
(Parent
(Context
)) = N_Package_Body
21578 Process_Statement_Part
(Parent
(Context
));
21580 -- The pragma appeared as an aspect of a [generic] subprogram
21581 -- declaration that acts as a compilation unit.
21584 -- procedure Proc ...;
21585 -- pragma SPARK_Mode ...;
21587 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
21588 N_Subprogram_Declaration
)
21590 Process_Overloadable
(Context
);
21592 -- The pragma does not apply to a legal construct, issue error
21600 --------------------------------
21601 -- Static_Elaboration_Desired --
21602 --------------------------------
21604 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21606 when Pragma_Static_Elaboration_Desired
=>
21608 Check_At_Most_N_Arguments
(1);
21610 if Is_Compilation_Unit
(Current_Scope
)
21611 and then Ekind
(Current_Scope
) = E_Package
21613 Set_Static_Elaboration_Desired
(Current_Scope
, True);
21615 Error_Pragma
("pragma% must apply to a library-level package");
21622 -- pragma Storage_Size (EXPRESSION);
21624 when Pragma_Storage_Size
=> Storage_Size
: declare
21625 P
: constant Node_Id
:= Parent
(N
);
21629 Check_No_Identifiers
;
21630 Check_Arg_Count
(1);
21632 -- The expression must be analyzed in the special manner described
21633 -- in "Handling of Default Expressions" in sem.ads.
21635 Arg
:= Get_Pragma_Arg
(Arg1
);
21636 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21638 if not Is_OK_Static_Expression
(Arg
) then
21639 Check_Restriction
(Static_Storage_Size
, Arg
);
21642 if Nkind
(P
) /= N_Task_Definition
then
21647 if Has_Storage_Size_Pragma
(P
) then
21648 Error_Pragma
("duplicate pragma% not allowed");
21650 Set_Has_Storage_Size_Pragma
(P
, True);
21653 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
21661 -- pragma Storage_Unit (NUMERIC_LITERAL);
21663 -- Only permitted argument is System'Storage_Unit value
21665 when Pragma_Storage_Unit
=>
21666 Check_No_Identifiers
;
21667 Check_Arg_Count
(1);
21668 Check_Arg_Is_Integer_Literal
(Arg1
);
21670 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
21671 UI_From_Int
(Ttypes
.System_Storage_Unit
)
21673 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
21675 ("the only allowed argument for pragma% is ^", Arg1
);
21678 --------------------
21679 -- Stream_Convert --
21680 --------------------
21682 -- pragma Stream_Convert (
21683 -- [Entity =>] type_LOCAL_NAME,
21684 -- [Read =>] function_NAME,
21685 -- [Write =>] function NAME);
21687 when Pragma_Stream_Convert
=> Stream_Convert
: declare
21688 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
21689 -- Check that the given argument is the name of a local function
21690 -- of one argument that is not overloaded earlier in the current
21691 -- local scope. A check is also made that the argument is a
21692 -- function with one parameter.
21694 --------------------------------------
21695 -- Check_OK_Stream_Convert_Function --
21696 --------------------------------------
21698 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
21702 Check_Arg_Is_Local_Name
(Arg
);
21703 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
21705 if Has_Homonym
(Ent
) then
21707 ("argument for pragma% may not be overloaded", Arg
);
21710 if Ekind
(Ent
) /= E_Function
21711 or else No
(First_Formal
(Ent
))
21712 or else Present
(Next_Formal
(First_Formal
(Ent
)))
21715 ("argument for pragma% must be function of one argument",
21718 end Check_OK_Stream_Convert_Function
;
21720 -- Start of processing for Stream_Convert
21724 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
21725 Check_Arg_Count
(3);
21726 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21727 Check_Optional_Identifier
(Arg2
, Name_Read
);
21728 Check_Optional_Identifier
(Arg3
, Name_Write
);
21729 Check_Arg_Is_Local_Name
(Arg1
);
21730 Check_OK_Stream_Convert_Function
(Arg2
);
21731 Check_OK_Stream_Convert_Function
(Arg3
);
21734 Typ
: constant Entity_Id
:=
21735 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
21736 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
21737 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
21740 Check_First_Subtype
(Arg1
);
21742 -- Check for too early or too late. Note that we don't enforce
21743 -- the rule about primitive operations in this case, since, as
21744 -- is the case for explicit stream attributes themselves, these
21745 -- restrictions are not appropriate. Note that the chaining of
21746 -- the pragma by Rep_Item_Too_Late is actually the critical
21747 -- processing done for this pragma.
21749 if Rep_Item_Too_Early
(Typ
, N
)
21751 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
21756 -- Return if previous error
21758 if Etype
(Typ
) = Any_Type
21760 Etype
(Read
) = Any_Type
21762 Etype
(Write
) = Any_Type
21769 if Underlying_Type
(Etype
(Read
)) /= Typ
then
21771 ("incorrect return type for function&", Arg2
);
21774 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
21776 ("incorrect parameter type for function&", Arg3
);
21779 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
21780 Underlying_Type
(Etype
(Write
))
21783 ("result type of & does not match Read parameter type",
21787 end Stream_Convert
;
21793 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
21795 -- This is processed by the parser since some of the style checks
21796 -- take place during source scanning and parsing. This means that
21797 -- we don't need to issue error messages here.
21799 when Pragma_Style_Checks
=> Style_Checks
: declare
21800 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
21806 Check_No_Identifiers
;
21808 -- Two argument form
21810 if Arg_Count
= 2 then
21811 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21818 E_Id
:= Get_Pragma_Arg
(Arg2
);
21821 if not Is_Entity_Name
(E_Id
) then
21823 ("second argument of pragma% must be entity name",
21827 E
:= Entity
(E_Id
);
21829 if not Ignore_Style_Checks_Pragmas
then
21834 Set_Suppress_Style_Checks
21835 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
21836 exit when No
(Homonym
(E
));
21843 -- One argument form
21846 Check_Arg_Count
(1);
21848 if Nkind
(A
) = N_String_Literal
then
21852 Slen
: constant Natural := Natural (String_Length
(S
));
21853 Options
: String (1 .. Slen
);
21859 C
:= Get_String_Char
(S
, Pos
(J
));
21860 exit when not In_Character_Range
(C
);
21861 Options
(J
) := Get_Character
(C
);
21863 -- If at end of string, set options. As per discussion
21864 -- above, no need to check for errors, since we issued
21865 -- them in the parser.
21868 if not Ignore_Style_Checks_Pragmas
then
21869 Set_Style_Check_Options
(Options
);
21879 elsif Nkind
(A
) = N_Identifier
then
21880 if Chars
(A
) = Name_All_Checks
then
21881 if not Ignore_Style_Checks_Pragmas
then
21883 Set_GNAT_Style_Check_Options
;
21885 Set_Default_Style_Check_Options
;
21889 elsif Chars
(A
) = Name_On
then
21890 if not Ignore_Style_Checks_Pragmas
then
21891 Style_Check
:= True;
21894 elsif Chars
(A
) = Name_Off
then
21895 if not Ignore_Style_Checks_Pragmas
then
21896 Style_Check
:= False;
21907 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
21909 when Pragma_Subtitle
=>
21911 Check_Arg_Count
(1);
21912 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
21913 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
21920 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
21922 when Pragma_Suppress
=>
21923 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
21929 -- pragma Suppress_All;
21931 -- The only check made here is that the pragma has no arguments.
21932 -- There are no placement rules, and the processing required (setting
21933 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
21934 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
21935 -- then creates and inserts a pragma Suppress (All_Checks).
21937 when Pragma_Suppress_All
=>
21939 Check_Arg_Count
(0);
21941 -------------------------
21942 -- Suppress_Debug_Info --
21943 -------------------------
21945 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
21947 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
21948 Nam_Id
: Entity_Id
;
21952 Check_Arg_Count
(1);
21953 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21954 Check_Arg_Is_Local_Name
(Arg1
);
21956 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
21958 -- A pragma that applies to a Ghost entity becomes Ghost for the
21959 -- purposes of legality checks and removal of ignored Ghost code.
21961 Mark_Ghost_Pragma
(N
, Nam_Id
);
21962 Set_Debug_Info_Off
(Nam_Id
);
21963 end Suppress_Debug_Info
;
21965 ----------------------------------
21966 -- Suppress_Exception_Locations --
21967 ----------------------------------
21969 -- pragma Suppress_Exception_Locations;
21971 when Pragma_Suppress_Exception_Locations
=>
21973 Check_Arg_Count
(0);
21974 Check_Valid_Configuration_Pragma
;
21975 Exception_Locations_Suppressed
:= True;
21977 -----------------------------
21978 -- Suppress_Initialization --
21979 -----------------------------
21981 -- pragma Suppress_Initialization ([Entity =>] type_Name);
21983 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
21989 Check_Arg_Count
(1);
21990 Check_Optional_Identifier
(Arg1
, Name_Entity
);
21991 Check_Arg_Is_Local_Name
(Arg1
);
21993 E_Id
:= Get_Pragma_Arg
(Arg1
);
21995 if Etype
(E_Id
) = Any_Type
then
21999 E
:= Entity
(E_Id
);
22001 -- A pragma that applies to a Ghost entity becomes Ghost for the
22002 -- purposes of legality checks and removal of ignored Ghost code.
22004 Mark_Ghost_Pragma
(N
, E
);
22006 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
22008 ("pragma% requires variable, type or subtype", Arg1
);
22011 if Rep_Item_Too_Early
(E
, N
)
22013 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
22018 -- For incomplete/private type, set flag on full view
22020 if Is_Incomplete_Or_Private_Type
(E
) then
22021 if No
(Full_View
(Base_Type
(E
))) then
22023 ("argument of pragma% cannot be an incomplete type", Arg1
);
22025 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
22028 -- For first subtype, set flag on base type
22030 elsif Is_First_Subtype
(E
) then
22031 Set_Suppress_Initialization
(Base_Type
(E
));
22033 -- For other than first subtype, set flag on subtype or variable
22036 Set_Suppress_Initialization
(E
);
22044 -- pragma System_Name (DIRECT_NAME);
22046 -- Syntax check: one argument, which must be the identifier GNAT or
22047 -- the identifier GCC, no other identifiers are acceptable.
22049 when Pragma_System_Name
=>
22051 Check_No_Identifiers
;
22052 Check_Arg_Count
(1);
22053 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
22055 -----------------------------
22056 -- Task_Dispatching_Policy --
22057 -----------------------------
22059 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22061 when Pragma_Task_Dispatching_Policy
=> declare
22065 Check_Ada_83_Warning
;
22066 Check_Arg_Count
(1);
22067 Check_No_Identifiers
;
22068 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22069 Check_Valid_Configuration_Pragma
;
22070 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22071 DP
:= Fold_Upper
(Name_Buffer
(1));
22073 if Task_Dispatching_Policy
/= ' '
22074 and then Task_Dispatching_Policy
/= DP
22076 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22078 ("task dispatching policy incompatible with policy#");
22080 -- Set new policy, but always preserve System_Location since we
22081 -- like the error message with the run time name.
22084 Task_Dispatching_Policy
:= DP
;
22086 if Task_Dispatching_Policy_Sloc
/= System_Location
then
22087 Task_Dispatching_Policy_Sloc
:= Loc
;
22096 -- pragma Task_Info (EXPRESSION);
22098 when Pragma_Task_Info
=> Task_Info
: declare
22099 P
: constant Node_Id
:= Parent
(N
);
22105 if Warn_On_Obsolescent_Feature
then
22107 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22108 & "instead?j?", N
);
22111 if Nkind
(P
) /= N_Task_Definition
then
22112 Error_Pragma
("pragma% must appear in task definition");
22115 Check_No_Identifiers
;
22116 Check_Arg_Count
(1);
22118 Analyze_And_Resolve
22119 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
22121 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
22125 Ent
:= Defining_Identifier
(Parent
(P
));
22127 -- Check duplicate pragma before we chain the pragma in the Rep
22128 -- Item chain of Ent.
22131 (Ent
, Name_Task_Info
, Check_Parents
=> False)
22133 Error_Pragma
("duplicate pragma% not allowed");
22136 Record_Rep_Item
(Ent
, N
);
22143 -- pragma Task_Name (string_EXPRESSION);
22145 when Pragma_Task_Name
=> Task_Name
: declare
22146 P
: constant Node_Id
:= Parent
(N
);
22151 Check_No_Identifiers
;
22152 Check_Arg_Count
(1);
22154 Arg
:= Get_Pragma_Arg
(Arg1
);
22156 -- The expression is used in the call to Create_Task, and must be
22157 -- expanded there, not in the context of the current spec. It must
22158 -- however be analyzed to capture global references, in case it
22159 -- appears in a generic context.
22161 Preanalyze_And_Resolve
(Arg
, Standard_String
);
22163 if Nkind
(P
) /= N_Task_Definition
then
22167 Ent
:= Defining_Identifier
(Parent
(P
));
22169 -- Check duplicate pragma before we chain the pragma in the Rep
22170 -- Item chain of Ent.
22173 (Ent
, Name_Task_Name
, Check_Parents
=> False)
22175 Error_Pragma
("duplicate pragma% not allowed");
22178 Record_Rep_Item
(Ent
, N
);
22185 -- pragma Task_Storage (
22186 -- [Task_Type =>] LOCAL_NAME,
22187 -- [Top_Guard =>] static_integer_EXPRESSION);
22189 when Pragma_Task_Storage
=> Task_Storage
: declare
22190 Args
: Args_List
(1 .. 2);
22191 Names
: constant Name_List
(1 .. 2) := (
22195 Task_Type
: Node_Id
renames Args
(1);
22196 Top_Guard
: Node_Id
renames Args
(2);
22202 Gather_Associations
(Names
, Args
);
22204 if No
(Task_Type
) then
22206 ("missing task_type argument for pragma%");
22209 Check_Arg_Is_Local_Name
(Task_Type
);
22211 Ent
:= Entity
(Task_Type
);
22213 if not Is_Task_Type
(Ent
) then
22215 ("argument for pragma% must be task type", Task_Type
);
22218 if No
(Top_Guard
) then
22220 ("pragma% takes two arguments", Task_Type
);
22222 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
22225 Check_First_Subtype
(Task_Type
);
22227 if Rep_Item_Too_Late
(Ent
, N
) then
22236 -- pragma Test_Case
22237 -- ([Name =>] Static_String_EXPRESSION
22238 -- ,[Mode =>] MODE_TYPE
22239 -- [, Requires => Boolean_EXPRESSION]
22240 -- [, Ensures => Boolean_EXPRESSION]);
22242 -- MODE_TYPE ::= Nominal | Robustness
22244 -- Characteristics:
22246 -- * Analysis - The annotation undergoes initial checks to verify
22247 -- the legal placement and context. Secondary checks preanalyze the
22250 -- Analyze_Test_Case_In_Decl_Part
22252 -- * Expansion - None.
22254 -- * Template - The annotation utilizes the generic template of the
22255 -- related subprogram when it is:
22257 -- aspect on subprogram declaration
22259 -- The annotation must prepare its own template when it is:
22261 -- pragma on subprogram declaration
22263 -- * Globals - Capture of global references must occur after full
22266 -- * Instance - The annotation is instantiated automatically when
22267 -- the related generic subprogram is instantiated except for the
22268 -- "pragma on subprogram declaration" case. In that scenario the
22269 -- annotation must instantiate itself.
22271 when Pragma_Test_Case
=> Test_Case
: declare
22272 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
22273 -- Ensure that the contract of subprogram Subp_Id does not contain
22274 -- another Test_Case pragma with the same Name as the current one.
22276 -------------------------
22277 -- Check_Distinct_Name --
22278 -------------------------
22280 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
22281 Items
: constant Node_Id
:= Contract
(Subp_Id
);
22282 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
22286 -- Inspect all Test_Case pragma of the related subprogram
22287 -- looking for one with a duplicate "Name" argument.
22289 if Present
(Items
) then
22290 Prag
:= Contract_Test_Cases
(Items
);
22291 while Present
(Prag
) loop
22292 if Pragma_Name
(Prag
) = Name_Test_Case
22294 and then String_Equal
22295 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
22297 Error_Msg_Sloc
:= Sloc
(Prag
);
22298 Error_Pragma
("name for pragma % is already used #");
22301 Prag
:= Next_Pragma
(Prag
);
22304 end Check_Distinct_Name
;
22308 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
22311 Subp_Decl
: Node_Id
;
22312 Subp_Id
: Entity_Id
;
22314 -- Start of processing for Test_Case
22318 Check_At_Least_N_Arguments
(2);
22319 Check_At_Most_N_Arguments
(4);
22321 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
22325 Check_Optional_Identifier
(Arg1
, Name_Name
);
22326 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22330 Check_Optional_Identifier
(Arg2
, Name_Mode
);
22331 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
22333 -- Arguments "Requires" and "Ensures"
22335 if Present
(Arg3
) then
22336 if Present
(Arg4
) then
22337 Check_Identifier
(Arg3
, Name_Requires
);
22338 Check_Identifier
(Arg4
, Name_Ensures
);
22340 Check_Identifier_Is_One_Of
22341 (Arg3
, Name_Requires
, Name_Ensures
);
22345 -- Pragma Test_Case must be associated with a subprogram declared
22346 -- in a library-level package. First determine whether the current
22347 -- compilation unit is a legal context.
22349 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
22350 N_Generic_Package_Declaration
)
22354 -- Otherwise the placement is illegal
22358 ("pragma % must be specified within a package declaration");
22362 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
22364 -- Find the enclosing context
22366 Context
:= Parent
(Subp_Decl
);
22368 if Present
(Context
) then
22369 Context
:= Parent
(Context
);
22372 -- Verify the placement of the pragma
22374 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
22376 ("pragma % cannot be applied to abstract subprogram");
22379 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
22380 Error_Pragma
("pragma % cannot be applied to entry");
22383 -- The context is a [generic] subprogram declared at the top level
22384 -- of the [generic] package unit.
22386 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
22387 N_Subprogram_Declaration
)
22388 and then Present
(Context
)
22389 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
22390 N_Package_Declaration
)
22394 -- Otherwise the placement is illegal
22398 ("pragma % must be applied to a library-level subprogram "
22403 Subp_Id
:= Defining_Entity
(Subp_Decl
);
22405 -- A pragma that applies to a Ghost entity becomes Ghost for the
22406 -- purposes of legality checks and removal of ignored Ghost code.
22408 Mark_Ghost_Pragma
(N
, Subp_Id
);
22410 -- Chain the pragma on the contract for further processing by
22411 -- Analyze_Test_Case_In_Decl_Part.
22413 Add_Contract_Item
(N
, Subp_Id
);
22415 -- Preanalyze the original aspect argument "Name" for ASIS or for
22416 -- a generic subprogram to properly capture global references.
22418 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
22419 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
22421 if Present
(Asp_Arg
) then
22423 -- The argument appears with an identifier in association
22426 if Nkind
(Asp_Arg
) = N_Component_Association
then
22427 Asp_Arg
:= Expression
(Asp_Arg
);
22430 Check_Expr_Is_OK_Static_Expression
22431 (Asp_Arg
, Standard_String
);
22435 -- Ensure that the all Test_Case pragmas of the related subprogram
22436 -- have distinct names.
22438 Check_Distinct_Name
(Subp_Id
);
22440 -- Fully analyze the pragma when it appears inside an entry
22441 -- or subprogram body because it cannot benefit from forward
22444 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
22446 N_Subprogram_Body_Stub
)
22448 -- The legality checks of pragma Test_Case are affected by the
22449 -- SPARK mode in effect and the volatility of the context.
22450 -- Analyze all pragmas in a specific order.
22452 Analyze_If_Present
(Pragma_SPARK_Mode
);
22453 Analyze_If_Present
(Pragma_Volatile_Function
);
22454 Analyze_Test_Case_In_Decl_Part
(N
);
22458 --------------------------
22459 -- Thread_Local_Storage --
22460 --------------------------
22462 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22464 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
22470 Check_Arg_Count
(1);
22471 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22472 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22474 Id
:= Get_Pragma_Arg
(Arg1
);
22477 if not Is_Entity_Name
(Id
)
22478 or else Ekind
(Entity
(Id
)) /= E_Variable
22480 Error_Pragma_Arg
("local variable name required", Arg1
);
22485 -- A pragma that applies to a Ghost entity becomes Ghost for the
22486 -- purposes of legality checks and removal of ignored Ghost code.
22488 Mark_Ghost_Pragma
(N
, E
);
22490 if Rep_Item_Too_Early
(E
, N
)
22492 Rep_Item_Too_Late
(E
, N
)
22497 Set_Has_Pragma_Thread_Local_Storage
(E
);
22498 Set_Has_Gigi_Rep_Item
(E
);
22499 end Thread_Local_Storage
;
22505 -- pragma Time_Slice (static_duration_EXPRESSION);
22507 when Pragma_Time_Slice
=> Time_Slice
: declare
22513 Check_Arg_Count
(1);
22514 Check_No_Identifiers
;
22515 Check_In_Main_Program
;
22516 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
22518 if not Error_Posted
(Arg1
) then
22520 while Present
(Nod
) loop
22521 if Nkind
(Nod
) = N_Pragma
22522 and then Pragma_Name
(Nod
) = Name_Time_Slice
22524 Error_Msg_Name_1
:= Pname
;
22525 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
22532 -- Process only if in main unit
22534 if Get_Source_Unit
(Loc
) = Main_Unit
then
22535 Opt
.Time_Slice_Set
:= True;
22536 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
22538 if Val
<= Ureal_0
then
22539 Opt
.Time_Slice_Value
:= 0;
22541 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
22542 Opt
.Time_Slice_Value
:= 1_000_000_000
;
22545 Opt
.Time_Slice_Value
:=
22546 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
22555 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22557 -- TITLING_OPTION ::=
22558 -- [Title =>] STRING_LITERAL
22559 -- | [Subtitle =>] STRING_LITERAL
22561 when Pragma_Title
=> Title
: declare
22562 Args
: Args_List
(1 .. 2);
22563 Names
: constant Name_List
(1 .. 2) := (
22569 Gather_Associations
(Names
, Args
);
22572 for J
in 1 .. 2 loop
22573 if Present
(Args
(J
)) then
22574 Check_Arg_Is_OK_Static_Expression
22575 (Args
(J
), Standard_String
);
22580 ----------------------------
22581 -- Type_Invariant[_Class] --
22582 ----------------------------
22584 -- pragma Type_Invariant[_Class]
22585 -- ([Entity =>] type_LOCAL_NAME,
22586 -- [Check =>] EXPRESSION);
22588 when Pragma_Type_Invariant
22589 | Pragma_Type_Invariant_Class
22591 Type_Invariant
: declare
22592 I_Pragma
: Node_Id
;
22595 Check_Arg_Count
(2);
22597 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22598 -- setting Class_Present for the Type_Invariant_Class case.
22600 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
22601 I_Pragma
:= New_Copy
(N
);
22602 Set_Pragma_Identifier
22603 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
22604 Rewrite
(N
, I_Pragma
);
22605 Set_Analyzed
(N
, False);
22607 end Type_Invariant
;
22609 ---------------------
22610 -- Unchecked_Union --
22611 ---------------------
22613 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22615 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
22616 Assoc
: constant Node_Id
:= Arg1
;
22617 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
22627 Check_No_Identifiers
;
22628 Check_Arg_Count
(1);
22629 Check_Arg_Is_Local_Name
(Arg1
);
22631 Find_Type
(Type_Id
);
22633 Typ
:= Entity
(Type_Id
);
22635 -- A pragma that applies to a Ghost entity becomes Ghost for the
22636 -- purposes of legality checks and removal of ignored Ghost code.
22638 Mark_Ghost_Pragma
(N
, Typ
);
22641 or else Rep_Item_Too_Early
(Typ
, N
)
22645 Typ
:= Underlying_Type
(Typ
);
22648 if Rep_Item_Too_Late
(Typ
, N
) then
22652 Check_First_Subtype
(Arg1
);
22654 -- Note remaining cases are references to a type in the current
22655 -- declarative part. If we find an error, we post the error on
22656 -- the relevant type declaration at an appropriate point.
22658 if not Is_Record_Type
(Typ
) then
22659 Error_Msg_N
("unchecked union must be record type", Typ
);
22662 elsif Is_Tagged_Type
(Typ
) then
22663 Error_Msg_N
("unchecked union must not be tagged", Typ
);
22666 elsif not Has_Discriminants
(Typ
) then
22668 ("unchecked union must have one discriminant", Typ
);
22671 -- Note: in previous versions of GNAT we used to check for limited
22672 -- types and give an error, but in fact the standard does allow
22673 -- Unchecked_Union on limited types, so this check was removed.
22675 -- Similarly, GNAT used to require that all discriminants have
22676 -- default values, but this is not mandated by the RM.
22678 -- Proceed with basic error checks completed
22681 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
22682 Clist
:= Component_List
(Tdef
);
22684 -- Check presence of component list and variant part
22686 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
22688 ("unchecked union must have variant part", Tdef
);
22692 -- Check components
22694 Comp
:= First
(Component_Items
(Clist
));
22695 while Present
(Comp
) loop
22696 Check_Component
(Comp
, Typ
);
22700 -- Check variant part
22702 Vpart
:= Variant_Part
(Clist
);
22704 Variant
:= First
(Variants
(Vpart
));
22705 while Present
(Variant
) loop
22706 Check_Variant
(Variant
, Typ
);
22711 Set_Is_Unchecked_Union
(Typ
);
22712 Set_Convention
(Typ
, Convention_C
);
22713 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
22714 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
22715 end Unchecked_Union
;
22717 ----------------------------
22718 -- Unevaluated_Use_Of_Old --
22719 ----------------------------
22721 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
22723 when Pragma_Unevaluated_Use_Of_Old
=>
22725 Check_Arg_Count
(1);
22726 Check_No_Identifiers
;
22727 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
22729 -- Suppress/Unsuppress can appear as a configuration pragma, or in
22730 -- a declarative part or a package spec.
22732 if not Is_Configuration_Pragma
then
22733 Check_Is_In_Decl_Part_Or_Package_Spec
;
22736 -- Store proper setting of Uneval_Old
22738 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22739 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
22741 ------------------------
22742 -- Unimplemented_Unit --
22743 ------------------------
22745 -- pragma Unimplemented_Unit;
22747 -- Note: this only gives an error if we are generating code, or if
22748 -- we are in a generic library unit (where the pragma appears in the
22749 -- body, not in the spec).
22751 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
22752 Cunitent
: constant Entity_Id
:=
22753 Cunit_Entity
(Get_Source_Unit
(Loc
));
22754 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
22758 Check_Arg_Count
(0);
22760 if Operating_Mode
= Generate_Code
22761 or else Ent_Kind
= E_Generic_Function
22762 or else Ent_Kind
= E_Generic_Procedure
22763 or else Ent_Kind
= E_Generic_Package
22765 Get_Name_String
(Chars
(Cunitent
));
22766 Set_Casing
(Mixed_Case
);
22767 Write_Str
(Name_Buffer
(1 .. Name_Len
));
22768 Write_Str
(" is not supported in this configuration");
22770 raise Unrecoverable_Error
;
22772 end Unimplemented_Unit
;
22774 ------------------------
22775 -- Universal_Aliasing --
22776 ------------------------
22778 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
22780 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
22785 Check_Arg_Count
(1);
22786 Check_Optional_Identifier
(Arg2
, Name_Entity
);
22787 Check_Arg_Is_Local_Name
(Arg1
);
22788 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22790 if E_Id
= Any_Type
then
22792 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
22793 Error_Pragma_Arg
("pragma% requires type", Arg1
);
22796 -- A pragma that applies to a Ghost entity becomes Ghost for the
22797 -- purposes of legality checks and removal of ignored Ghost code.
22799 Mark_Ghost_Pragma
(N
, E_Id
);
22800 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
22801 Record_Rep_Item
(E_Id
, N
);
22802 end Universal_Alias
;
22804 --------------------
22805 -- Universal_Data --
22806 --------------------
22808 -- pragma Universal_Data [(library_unit_NAME)];
22810 when Pragma_Universal_Data
=>
22812 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
22818 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
22820 when Pragma_Unmodified
=>
22821 Analyze_Unmodified_Or_Unused
;
22827 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
22829 -- or when used in a context clause:
22831 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
22833 when Pragma_Unreferenced
=>
22834 Analyze_Unreferenced_Or_Unused
;
22836 --------------------------
22837 -- Unreferenced_Objects --
22838 --------------------------
22840 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
22842 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
22844 Arg_Expr
: Node_Id
;
22845 Arg_Id
: Entity_Id
;
22847 Ghost_Error_Posted
: Boolean := False;
22848 -- Flag set when an error concerning the illegal mix of Ghost and
22849 -- non-Ghost types is emitted.
22851 Ghost_Id
: Entity_Id
:= Empty
;
22852 -- The entity of the first Ghost type encountered while processing
22853 -- the arguments of the pragma.
22857 Check_At_Least_N_Arguments
(1);
22860 while Present
(Arg
) loop
22861 Check_No_Identifier
(Arg
);
22862 Check_Arg_Is_Local_Name
(Arg
);
22863 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
22865 if Is_Entity_Name
(Arg_Expr
) then
22866 Arg_Id
:= Entity
(Arg_Expr
);
22868 if Is_Type
(Arg_Id
) then
22869 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
22871 -- A pragma that applies to a Ghost entity becomes Ghost
22872 -- for the purposes of legality checks and removal of
22873 -- ignored Ghost code.
22875 Mark_Ghost_Pragma
(N
, Arg_Id
);
22877 -- Capture the entity of the first Ghost type being
22878 -- processed for error detection purposes.
22880 if Is_Ghost_Entity
(Arg_Id
) then
22881 if No
(Ghost_Id
) then
22882 Ghost_Id
:= Arg_Id
;
22885 -- Otherwise the type is non-Ghost. It is illegal to mix
22886 -- references to Ghost and non-Ghost entities
22889 elsif Present
(Ghost_Id
)
22890 and then not Ghost_Error_Posted
22892 Ghost_Error_Posted
:= True;
22894 Error_Msg_Name_1
:= Pname
;
22896 ("pragma % cannot mention ghost and non-ghost types",
22899 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
22900 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
22902 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
22903 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
22907 ("argument for pragma% must be type or subtype", Arg
);
22911 ("argument for pragma% must be type or subtype", Arg
);
22916 end Unreferenced_Objects
;
22918 ------------------------------
22919 -- Unreserve_All_Interrupts --
22920 ------------------------------
22922 -- pragma Unreserve_All_Interrupts;
22924 when Pragma_Unreserve_All_Interrupts
=>
22926 Check_Arg_Count
(0);
22928 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
22929 Unreserve_All_Interrupts
:= True;
22936 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
22938 when Pragma_Unsuppress
=>
22940 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
22946 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
22948 when Pragma_Unused
=>
22949 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
22950 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
22952 -------------------
22953 -- Use_VADS_Size --
22954 -------------------
22956 -- pragma Use_VADS_Size;
22958 when Pragma_Use_VADS_Size
=>
22960 Check_Arg_Count
(0);
22961 Check_Valid_Configuration_Pragma
;
22962 Use_VADS_Size
:= True;
22964 ---------------------
22965 -- Validity_Checks --
22966 ---------------------
22968 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22970 when Pragma_Validity_Checks
=> Validity_Checks
: declare
22971 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22977 Check_Arg_Count
(1);
22978 Check_No_Identifiers
;
22980 -- Pragma always active unless in CodePeer or GNATprove modes,
22981 -- which use a fixed configuration of validity checks.
22983 if not (CodePeer_Mode
or GNATprove_Mode
) then
22984 if Nkind
(A
) = N_String_Literal
then
22988 Slen
: constant Natural := Natural (String_Length
(S
));
22989 Options
: String (1 .. Slen
);
22993 -- Couldn't we use a for loop here over Options'Range???
22997 C
:= Get_String_Char
(S
, Pos
(J
));
22999 -- This is a weird test, it skips setting validity
23000 -- checks entirely if any element of S is out of
23001 -- range of Character, what is that about ???
23003 exit when not In_Character_Range
(C
);
23004 Options
(J
) := Get_Character
(C
);
23007 Set_Validity_Check_Options
(Options
);
23015 elsif Nkind
(A
) = N_Identifier
then
23016 if Chars
(A
) = Name_All_Checks
then
23017 Set_Validity_Check_Options
("a");
23018 elsif Chars
(A
) = Name_On
then
23019 Validity_Checks_On
:= True;
23020 elsif Chars
(A
) = Name_Off
then
23021 Validity_Checks_On
:= False;
23025 end Validity_Checks
;
23031 -- pragma Volatile (LOCAL_NAME);
23033 when Pragma_Volatile
=>
23034 Process_Atomic_Independent_Shared_Volatile
;
23036 -------------------------
23037 -- Volatile_Components --
23038 -------------------------
23040 -- pragma Volatile_Components (array_LOCAL_NAME);
23042 -- Volatile is handled by the same circuit as Atomic_Components
23044 --------------------------
23045 -- Volatile_Full_Access --
23046 --------------------------
23048 -- pragma Volatile_Full_Access (LOCAL_NAME);
23050 when Pragma_Volatile_Full_Access
=>
23052 Process_Atomic_Independent_Shared_Volatile
;
23054 -----------------------
23055 -- Volatile_Function --
23056 -----------------------
23058 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23060 when Pragma_Volatile_Function
=> Volatile_Function
: declare
23061 Over_Id
: Entity_Id
;
23062 Spec_Id
: Entity_Id
;
23063 Subp_Decl
: Node_Id
;
23067 Check_No_Identifiers
;
23068 Check_At_Most_N_Arguments
(1);
23071 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23073 -- Generic subprogram
23075 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23078 -- Body acts as spec
23080 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23081 and then No
(Corresponding_Spec
(Subp_Decl
))
23085 -- Body stub acts as spec
23087 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23088 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23094 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23102 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23104 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
23109 -- A pragma that applies to a Ghost entity becomes Ghost for the
23110 -- purposes of legality checks and removal of ignored Ghost code.
23112 Mark_Ghost_Pragma
(N
, Spec_Id
);
23114 -- Chain the pragma on the contract for completeness
23116 Add_Contract_Item
(N
, Spec_Id
);
23118 -- The legality checks of pragma Volatile_Function are affected by
23119 -- the SPARK mode in effect. Analyze all pragmas in a specific
23122 Analyze_If_Present
(Pragma_SPARK_Mode
);
23124 -- A volatile function cannot override a non-volatile function
23125 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23126 -- in New_Overloaded_Entity, however at that point the pragma has
23127 -- not been processed yet.
23129 Over_Id
:= Overridden_Operation
(Spec_Id
);
23131 if Present
(Over_Id
)
23132 and then not Is_Volatile_Function
(Over_Id
)
23135 ("incompatible volatile function values in effect", Spec_Id
);
23137 Error_Msg_Sloc
:= Sloc
(Over_Id
);
23139 ("\& declared # with Volatile_Function value False",
23142 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
23144 ("\overridden # with Volatile_Function value True",
23148 -- Analyze the Boolean expression (if any)
23150 if Present
(Arg1
) then
23151 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
23153 end Volatile_Function
;
23155 ----------------------
23156 -- Warning_As_Error --
23157 ----------------------
23159 -- pragma Warning_As_Error (static_string_EXPRESSION);
23161 when Pragma_Warning_As_Error
=>
23163 Check_Arg_Count
(1);
23164 Check_No_Identifiers
;
23165 Check_Valid_Configuration_Pragma
;
23167 if not Is_Static_String_Expression
(Arg1
) then
23169 ("argument of pragma% must be static string expression",
23172 -- OK static string expression
23175 Acquire_Warning_Match_String
(Arg1
);
23176 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
23177 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
23178 new String'(Name_Buffer (1 .. Name_Len));
23185 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23187 -- DETAILS ::= On | Off
23188 -- DETAILS ::= On | Off, local_NAME
23189 -- DETAILS ::= static_string_EXPRESSION
23190 -- DETAILS ::= On | Off, static_string_EXPRESSION
23192 -- TOOL_NAME ::= GNAT | GNATProve
23194 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23196 -- Note: If the first argument matches an allowed tool name, it is
23197 -- always considered to be a tool name, even if there is a string
23198 -- variable of that name.
23200 -- Note if the second argument of DETAILS is a local_NAME then the
23201 -- second form is always understood. If the intention is to use
23202 -- the fourth form, then you can write NAME & "" to force the
23203 -- intepretation as a static_string_EXPRESSION.
23205 when Pragma_Warnings => Warnings : declare
23206 Reason : String_Id;
23210 Check_At_Least_N_Arguments (1);
23212 -- See if last argument is labeled Reason. If so, make sure we
23213 -- have a string literal or a concatenation of string literals,
23214 -- and acquire the REASON string. Then remove the REASON argument
23215 -- by decreasing Num_Args by one; Remaining processing looks only
23216 -- at first Num_Args arguments).
23219 Last_Arg : constant Node_Id :=
23220 Last (Pragma_Argument_Associations (N));
23223 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23224 and then Chars (Last_Arg) = Name_Reason
23227 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23228 Reason := End_String;
23229 Arg_Count := Arg_Count - 1;
23231 -- Not allowed in compiler units (bootstrap issues)
23233 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23235 -- No REASON string, set null string as reason
23238 Reason := Null_String_Id;
23242 -- Now proceed with REASON taken care of and eliminated
23244 Check_No_Identifiers;
23246 -- If debug flag -gnatd.i is set, pragma is ignored
23248 if Debug_Flag_Dot_I then
23252 -- Process various forms of the pragma
23255 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23256 Shifted_Args : List_Id;
23259 -- See if first argument is a tool name, currently either
23260 -- GNAT or GNATprove. If so, either ignore the pragma if the
23261 -- tool used does not match, or continue as if no tool name
23262 -- was given otherwise, by shifting the arguments.
23264 if Nkind (Argx) = N_Identifier
23265 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23267 if Chars (Argx) = Name_Gnat then
23268 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23269 Rewrite (N, Make_Null_Statement (Loc));
23274 elsif Chars (Argx) = Name_Gnatprove then
23275 if not GNATprove_Mode then
23276 Rewrite (N, Make_Null_Statement (Loc));
23282 raise Program_Error;
23285 -- At this point, the pragma Warnings applies to the tool,
23286 -- so continue with shifted arguments.
23288 Arg_Count := Arg_Count - 1;
23290 if Arg_Count = 1 then
23291 Shifted_Args := New_List (New_Copy (Arg2));
23292 elsif Arg_Count = 2 then
23293 Shifted_Args := New_List (New_Copy (Arg2),
23295 elsif Arg_Count = 3 then
23296 Shifted_Args := New_List (New_Copy (Arg2),
23300 raise Program_Error;
23305 Chars => Name_Warnings,
23306 Pragma_Argument_Associations => Shifted_Args));
23311 -- One argument case
23313 if Arg_Count = 1 then
23315 -- On/Off one argument case was processed by parser
23317 if Nkind (Argx) = N_Identifier
23318 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23322 -- One argument case must be ON/OFF or static string expr
23324 elsif not Is_Static_String_Expression (Arg1) then
23326 ("argument of pragma% must be On/Off or static string "
23327 & "expression", Arg1);
23329 -- One argument string expression case
23333 Lit : constant Node_Id := Expr_Value_S (Argx);
23334 Str : constant String_Id := Strval (Lit);
23335 Len : constant Nat := String_Length (Str);
23343 while J <= Len loop
23344 C := Get_String_Char (Str, J);
23345 OK := In_Character_Range (C);
23348 Chr := Get_Character (C);
23350 -- Dash case: only -Wxxx is accepted
23357 C := Get_String_Char (Str, J);
23358 Chr := Get_Character (C);
23359 exit when Chr = 'W
';
23364 elsif J < Len and then Chr = '.' then
23366 C := Get_String_Char (Str, J);
23367 Chr := Get_Character (C);
23369 if not Set_Dot_Warning_Switch (Chr) then
23371 ("invalid warning switch character "
23372 & '.' & Chr, Arg1);
23378 OK := Set_Warning_Switch (Chr);
23384 ("invalid warning switch character " & Chr,
23393 -- Two or more arguments (must be two)
23396 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23397 Check_Arg_Count (2);
23405 E_Id := Get_Pragma_Arg (Arg2);
23408 -- In the expansion of an inlined body, a reference to
23409 -- the formal may be wrapped in a conversion if the
23410 -- actual is a conversion. Retrieve the real entity name.
23412 if (In_Instance_Body or In_Inlined_Body)
23413 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23415 E_Id := Expression (E_Id);
23418 -- Entity name case
23420 if Is_Entity_Name (E_Id) then
23421 E := Entity (E_Id);
23428 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23431 -- For OFF case, make entry in warnings off
23432 -- pragma table for later processing. But we do
23433 -- not do that within an instance, since these
23434 -- warnings are about what is needed in the
23435 -- template, not an instance of it.
23437 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23438 and then Warn_On_Warnings_Off
23439 and then not In_Instance
23441 Warnings_Off_Pragmas.Append ((N, E, Reason));
23444 if Is_Enumeration_Type (E) then
23448 Lit := First_Literal (E);
23449 while Present (Lit) loop
23450 Set_Warnings_Off (Lit);
23451 Next_Literal (Lit);
23456 exit when No (Homonym (E));
23461 -- Error if not entity or static string expression case
23463 elsif not Is_Static_String_Expression (Arg2) then
23465 ("second argument of pragma% must be entity name "
23466 & "or static string expression", Arg2);
23468 -- Static string expression case
23471 Acquire_Warning_Match_String (Arg2);
23473 -- Note on configuration pragma case: If this is a
23474 -- configuration pragma, then for an OFF pragma, we
23475 -- just set Config True in the call, which is all
23476 -- that needs to be done. For the case of ON, this
23477 -- is normally an error, unless it is canceling the
23478 -- effect of a previous OFF pragma in the same file.
23479 -- In any other case, an error will be signalled (ON
23480 -- with no matching OFF).
23482 -- Note: We set Used if we are inside a generic to
23483 -- disable the test that the non-config case actually
23484 -- cancels a warning. That's because we can't be sure
23485 -- there isn't an instantiation in some other unit
23486 -- where a warning is suppressed.
23488 -- We could do a little better here by checking if the
23489 -- generic unit we are inside is public, but for now
23490 -- we don't bother with that refinement.
23492 if Chars (Argx) = Name_Off then
23493 Set_Specific_Warning_Off
23494 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23495 Config => Is_Configuration_Pragma,
23496 Used => Inside_A_Generic or else In_Instance);
23498 elsif Chars (Argx) = Name_On then
23499 Set_Specific_Warning_On
23500 (Loc, Name_Buffer (1 .. Name_Len), Err);
23504 ("??pragma Warnings On with no matching "
23505 & "Warnings Off", Loc);
23514 -------------------
23515 -- Weak_External --
23516 -------------------
23518 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23520 when Pragma_Weak_External => Weak_External : declare
23525 Check_Arg_Count (1);
23526 Check_Optional_Identifier (Arg1, Name_Entity);
23527 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23528 Ent := Entity (Get_Pragma_Arg (Arg1));
23530 if Rep_Item_Too_Early (Ent, N) then
23533 Ent := Underlying_Type (Ent);
23536 -- The only processing required is to link this item on to the
23537 -- list of rep items for the given entity. This is accomplished
23538 -- by the call to Rep_Item_Too_Late (when no error is detected
23539 -- and False is returned).
23541 if Rep_Item_Too_Late (Ent, N) then
23544 Set_Has_Gigi_Rep_Item (Ent);
23548 -----------------------------
23549 -- Wide_Character_Encoding --
23550 -----------------------------
23552 -- pragma Wide_Character_Encoding (IDENTIFIER);
23554 when Pragma_Wide_Character_Encoding =>
23557 -- Nothing to do, handled in parser. Note that we do not enforce
23558 -- configuration pragma placement, this pragma can appear at any
23559 -- place in the source, allowing mixed encodings within a single
23564 --------------------
23565 -- Unknown_Pragma --
23566 --------------------
23568 -- Should be impossible, since the case of an unknown pragma is
23569 -- separately processed before the case statement is entered.
23571 when Unknown_Pragma =>
23572 raise Program_Error;
23575 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23576 -- until AI is formally approved.
23578 -- Check_Order_Dependence;
23581 when Pragma_Exit => null;
23582 end Analyze_Pragma;
23584 ---------------------------------------------
23585 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23586 ---------------------------------------------
23588 -- WARNING: This routine manages Ghost regions. Return statements must be
23589 -- replaced by gotos which jump to the end of the routine and restore the
23592 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23594 Freeze_Id : Entity_Id := Empty)
23596 Disp_Typ : Entity_Id;
23597 -- The dispatching type of the subprogram subject to the pre- or
23600 function Check_References (Nod : Node_Id) return Traverse_Result;
23601 -- Check that expression Nod does not mention non-primitives of the
23602 -- type, global objects of the type, or other illegalities described
23603 -- and implied by AI12-0113.
23605 ----------------------
23606 -- Check_References --
23607 ----------------------
23609 function Check_References (Nod : Node_Id) return Traverse_Result is
23611 if Nkind (Nod) = N_Function_Call
23612 and then Is_Entity_Name (Name (Nod))
23615 Func : constant Entity_Id := Entity (Name (Nod));
23619 -- An operation of the type must be a primitive
23621 if No (Find_Dispatching_Type (Func)) then
23622 Form := First_Formal (Func);
23623 while Present (Form) loop
23624 if Etype (Form) = Disp_Typ then
23626 ("operation in class-wide condition must be "
23627 & "primitive of &", Nod, Disp_Typ);
23630 Next_Formal (Form);
23633 -- A return object of the type is illegal as well
23635 if Etype (Func) = Disp_Typ
23636 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
23639 ("operation in class-wide condition must be primitive "
23640 & "of &", Nod, Disp_Typ);
23645 elsif Is_Entity_Name (Nod)
23647 (Etype (Nod) = Disp_Typ
23648 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23649 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
23652 ("object in class-wide condition must be formal of type &",
23655 elsif Nkind (Nod) = N_Explicit_Dereference
23656 and then (Etype (Nod) = Disp_Typ
23657 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
23658 and then (not Is_Entity_Name (Prefix (Nod))
23659 or else not Is_Formal (Entity (Prefix (Nod))))
23662 ("operation in class-wide condition must be primitive of &",
23667 end Check_References;
23669 procedure Check_Class_Wide_Condition is
23670 new Traverse_Proc (Check_References);
23674 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23675 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23676 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
23679 Mode : Ghost_Mode_Type;
23680 Restore_Scope : Boolean := False;
23682 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
23685 -- Do not analyze the pragma multiple times
23687 if Is_Analyzed_Pragma (N) then
23691 -- Set the Ghost mode in effect from the pragma. Due to the delayed
23692 -- analysis of the pragma, the Ghost mode at point of declaration and
23693 -- point of analysis may not necessarily be the same. Use the mode in
23694 -- effect at the point of declaration.
23696 Set_Ghost_Mode (N, Mode);
23698 -- Ensure that the subprogram and its formals are visible when analyzing
23699 -- the expression of the pragma.
23701 if not In_Open_Scopes (Spec_Id) then
23702 Restore_Scope := True;
23703 Push_Scope (Spec_Id);
23705 if Is_Generic_Subprogram (Spec_Id) then
23706 Install_Generic_Formals (Spec_Id);
23708 Install_Formals (Spec_Id);
23712 Errors := Serious_Errors_Detected;
23713 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
23715 -- Emit a clarification message when the expression contains at least
23716 -- one undefined reference, possibly due to contract "freezing".
23718 if Errors /= Serious_Errors_Detected
23719 and then Present (Freeze_Id)
23720 and then Has_Undefined_Reference (Expr)
23722 Contract_Freeze_Error (Spec_Id, Freeze_Id);
23725 if Class_Present (N) then
23727 -- Verify that a class-wide condition is legal, i.e. the operation is
23728 -- a primitive of a tagged type. Note that a generic subprogram is
23729 -- not a primitive operation.
23731 Disp_Typ := Find_Dispatching_Type (Spec_Id);
23733 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
23734 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
23736 if From_Aspect_Specification (N) then
23738 ("aspect % can only be specified for a primitive operation "
23739 & "of a tagged type", Corresponding_Aspect (N));
23741 -- The pragma is a source construct
23745 ("pragma % can only be specified for a primitive operation "
23746 & "of a tagged type", N);
23749 -- Remaining semantic checks require a full tree traversal
23752 Check_Class_Wide_Condition (Expr);
23757 if Restore_Scope then
23761 -- Currently it is not possible to inline pre/postconditions on a
23762 -- subprogram subject to pragma Inline_Always.
23764 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
23765 Set_Is_Analyzed_Pragma (N);
23767 Restore_Ghost_Mode (Mode);
23768 end Analyze_Pre_Post_Condition_In_Decl_Part;
23770 ------------------------------------------
23771 -- Analyze_Refined_Depends_In_Decl_Part --
23772 ------------------------------------------
23774 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
23775 Body_Inputs : Elist_Id := No_Elist;
23776 Body_Outputs : Elist_Id := No_Elist;
23777 -- The inputs and outputs of the subprogram body synthesized from pragma
23778 -- Refined_Depends.
23780 Dependencies : List_Id := No_List;
23782 -- The corresponding Depends pragma along with its clauses
23784 Matched_Items : Elist_Id := No_Elist;
23785 -- A list containing the entities of all successfully matched items
23786 -- found in pragma Depends.
23788 Refinements : List_Id := No_List;
23789 -- The clauses of pragma Refined_Depends
23791 Spec_Id : Entity_Id;
23792 -- The entity of the subprogram subject to pragma Refined_Depends
23794 Spec_Inputs : Elist_Id := No_Elist;
23795 Spec_Outputs : Elist_Id := No_Elist;
23796 -- The inputs and outputs of the subprogram spec synthesized from pragma
23799 procedure Check_Dependency_Clause
23800 (States : Elist_Id;
23801 Dep_Clause : Node_Id);
23802 -- Try to match a single dependency clause Dep_Clause against one or
23803 -- more refinement clauses found in list Refinements. Each successful
23804 -- match eliminates at least one refinement clause from Refinements.
23805 -- States is a list of states appearing in dependencies obtained by
23806 -- calling Get_States_Seen.
23808 procedure Check_Output_States;
23809 -- Determine whether pragma Depends contains an output state with a
23810 -- visible refinement and if so, ensure that pragma Refined_Depends
23811 -- mentions all its constituents as outputs.
23813 function Get_States_Seen (Dependencies : List_Id) return Elist_Id;
23814 -- Given a normalized list of dependencies obtained from calling
23815 -- Normalize_Clauses, return a list containing the entities of all
23816 -- states appearing in dependencies. It helps in checking refinements
23817 -- involving a state and a corresponding constituent which is not a
23818 -- direct constituent of the state.
23820 procedure Normalize_Clauses (Clauses : List_Id);
23821 -- Given a list of dependence or refinement clauses Clauses, normalize
23822 -- each clause by creating multiple dependencies with exactly one input
23825 procedure Report_Extra_Clauses;
23826 -- Emit an error for each extra clause found in list Refinements
23828 -----------------------------
23829 -- Check_Dependency_Clause --
23830 -----------------------------
23832 procedure Check_Dependency_Clause
23833 (States : Elist_Id;
23834 Dep_Clause : Node_Id)
23836 Dep_Input : constant Node_Id := Expression (Dep_Clause);
23837 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
23839 function Is_In_Out_State_Clause return Boolean;
23840 -- Determine whether dependence clause Dep_Clause denotes an abstract
23841 -- state that depends on itself (State => State).
23843 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
23844 -- Determine whether item Item denotes an abstract state with visible
23845 -- null refinement.
23847 procedure Match_Items
23848 (Dep_Item : Node_Id;
23849 Ref_Item : Node_Id;
23850 Matched : out Boolean);
23851 -- Try to match dependence item Dep_Item against refinement item
23852 -- Ref_Item. To match against a possible null refinement (see 2, 9),
23853 -- set Ref_Item to Empty. Flag Matched is set to True when one of
23854 -- the following conformance scenarios is in effect:
23855 -- 1) Both items denote null
23856 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
23857 -- 3) Both items denote attribute 'Result
23858 -- 4) Both items denote the same object
23859 -- 5) Both items denote the same formal parameter
23860 -- 6) Both items denote the same current instance of a type
23861 -- 7) Both items denote the same discriminant
23862 -- 8) Dep_Item is an abstract state with visible null refinement
23863 -- and Ref_Item denotes null.
23864 -- 9) Dep_Item is an abstract state with visible null refinement
23865 -- and Ref_Item is Empty (special case).
23866 -- 10) Dep_Item is an abstract state with full or partial visible
23867 -- non-null refinement and Ref_Item denotes one of its
23869 -- 11) Dep_Item is an abstract state without a full visible
23870 -- refinement and Ref_Item denotes the same state.
23871 -- When scenario 10 is in effect, the entity of the abstract state
23872 -- denoted by Dep_Item is added to list Refined_States.
23874 procedure Record_Item
(Item_Id
: Entity_Id
);
23875 -- Store the entity of an item denoted by Item_Id in Matched_Items
23877 ----------------------------
23878 -- Is_In_Out_State_Clause --
23879 ----------------------------
23881 function Is_In_Out_State_Clause
return Boolean is
23882 Dep_Input_Id
: Entity_Id
;
23883 Dep_Output_Id
: Entity_Id
;
23886 -- Detect the following clause:
23889 if Is_Entity_Name
(Dep_Input
)
23890 and then Is_Entity_Name
(Dep_Output
)
23892 -- Handle abstract views generated for limited with clauses
23894 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
23895 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
23898 Ekind
(Dep_Input_Id
) = E_Abstract_State
23899 and then Dep_Input_Id
= Dep_Output_Id
;
23903 end Is_In_Out_State_Clause
;
23905 ---------------------------
23906 -- Is_Null_Refined_State --
23907 ---------------------------
23909 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
23910 Item_Id
: Entity_Id
;
23913 if Is_Entity_Name
(Item
) then
23915 -- Handle abstract views generated for limited with clauses
23917 Item_Id
:= Available_View
(Entity_Of
(Item
));
23920 Ekind
(Item_Id
) = E_Abstract_State
23921 and then Has_Null_Visible_Refinement
(Item_Id
);
23925 end Is_Null_Refined_State
;
23931 procedure Match_Items
23932 (Dep_Item
: Node_Id
;
23933 Ref_Item
: Node_Id
;
23934 Matched
: out Boolean)
23936 Dep_Item_Id
: Entity_Id
;
23937 Ref_Item_Id
: Entity_Id
;
23940 -- Assume that the two items do not match
23944 -- A null matches null or Empty (special case)
23946 if Nkind
(Dep_Item
) = N_Null
23947 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23951 -- Attribute 'Result matches attribute 'Result
23953 -- ??? this is incorrect, Ref_Item should be checked as well
23955 elsif Is_Attribute_Result
(Dep_Item
) then
23958 -- Abstract states, current instances of concurrent types,
23959 -- discriminants, formal parameters and objects.
23961 elsif Is_Entity_Name
(Dep_Item
) then
23963 -- Handle abstract views generated for limited with clauses
23965 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
23967 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
23969 -- An abstract state with visible null refinement matches
23970 -- null or Empty (special case).
23972 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
23973 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
23975 Record_Item
(Dep_Item_Id
);
23978 -- An abstract state with visible non-null refinement
23979 -- matches one of its constituents, or itself for an
23980 -- abstract state with partial visible refinement.
23982 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
23983 if Is_Entity_Name
(Ref_Item
) then
23984 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
23986 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
23989 and then Present
(Encapsulating_State
(Ref_Item_Id
))
23990 and then Find_Encapsulating_State
23991 (States
, Ref_Item_Id
) = Dep_Item_Id
23993 Record_Item
(Dep_Item_Id
);
23996 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
23997 and then Ref_Item_Id
= Dep_Item_Id
23999 Record_Item
(Dep_Item_Id
);
24004 -- An abstract state without a visible refinement matches
24007 elsif Is_Entity_Name
(Ref_Item
)
24008 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24010 Record_Item
(Dep_Item_Id
);
24014 -- A current instance of a concurrent type, discriminant,
24015 -- formal parameter or an object matches itself.
24017 elsif Is_Entity_Name
(Ref_Item
)
24018 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24020 Record_Item
(Dep_Item_Id
);
24030 procedure Record_Item
(Item_Id
: Entity_Id
) is
24032 if not Contains
(Matched_Items
, Item_Id
) then
24033 Append_New_Elmt
(Item_Id
, Matched_Items
);
24039 Clause_Matched
: Boolean := False;
24040 Dummy
: Boolean := False;
24041 Inputs_Match
: Boolean;
24042 Next_Ref_Clause
: Node_Id
;
24043 Outputs_Match
: Boolean;
24044 Ref_Clause
: Node_Id
;
24045 Ref_Input
: Node_Id
;
24046 Ref_Output
: Node_Id
;
24048 -- Start of processing for Check_Dependency_Clause
24051 -- Do not perform this check in an instance because it was already
24052 -- performed successfully in the generic template.
24054 if Is_Generic_Instance
(Spec_Id
) then
24058 -- Examine all refinement clauses and compare them against the
24059 -- dependence clause.
24061 Ref_Clause
:= First
(Refinements
);
24062 while Present
(Ref_Clause
) loop
24063 Next_Ref_Clause
:= Next
(Ref_Clause
);
24065 -- Obtain the attributes of the current refinement clause
24067 Ref_Input
:= Expression
(Ref_Clause
);
24068 Ref_Output
:= First
(Choices
(Ref_Clause
));
24070 -- The current refinement clause matches the dependence clause
24071 -- when both outputs match and both inputs match. See routine
24072 -- Match_Items for all possible conformance scenarios.
24074 -- Depends Dep_Output => Dep_Input
24078 -- Refined_Depends Ref_Output => Ref_Input
24081 (Dep_Item
=> Dep_Input
,
24082 Ref_Item
=> Ref_Input
,
24083 Matched
=> Inputs_Match
);
24086 (Dep_Item
=> Dep_Output
,
24087 Ref_Item
=> Ref_Output
,
24088 Matched
=> Outputs_Match
);
24090 -- An In_Out state clause may be matched against a refinement with
24091 -- a null input or null output as long as the non-null side of the
24092 -- relation contains a valid constituent of the In_Out_State.
24094 if Is_In_Out_State_Clause
then
24096 -- Depends => (State => State)
24097 -- Refined_Depends => (null => Constit) -- OK
24100 and then not Outputs_Match
24101 and then Nkind
(Ref_Output
) = N_Null
24103 Outputs_Match
:= True;
24106 -- Depends => (State => State)
24107 -- Refined_Depends => (Constit => null) -- OK
24109 if not Inputs_Match
24110 and then Outputs_Match
24111 and then Nkind
(Ref_Input
) = N_Null
24113 Inputs_Match
:= True;
24117 -- The current refinement clause is legally constructed following
24118 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24119 -- the pool of candidates. The seach continues because a single
24120 -- dependence clause may have multiple matching refinements.
24122 if Inputs_Match
and Outputs_Match
then
24123 Clause_Matched
:= True;
24124 Remove
(Ref_Clause
);
24127 Ref_Clause
:= Next_Ref_Clause
;
24130 -- Depending on the order or composition of refinement clauses, an
24131 -- In_Out state clause may not be directly refinable.
24133 -- Depends => ((Output, State) => (Input, State))
24134 -- Refined_State => (State => (Constit_1, Constit_2))
24135 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24137 -- Matching normalized clause (State => State) fails because there is
24138 -- no direct refinement capable of satisfying this relation. Another
24139 -- similar case arises when clauses (Constit_1 => Input) and (Output
24140 -- => Constit_2) are matched first, leaving no candidates for clause
24141 -- (State => State). Both scenarios are legal as long as one of the
24142 -- previous clauses mentioned a valid constituent of State.
24144 if not Clause_Matched
24145 and then Is_In_Out_State_Clause
24147 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
24149 Clause_Matched
:= True;
24152 -- A clause where the input is an abstract state with visible null
24153 -- refinement is implicitly matched when the output has already been
24154 -- matched in a previous clause.
24156 -- Depends => (Output => State) -- implicitly OK
24157 -- Refined_State => (State => null)
24158 -- Refined_Depends => (Output => ...)
24160 if not Clause_Matched
24161 and then Is_Null_Refined_State
(Dep_Input
)
24162 and then Is_Entity_Name
(Dep_Output
)
24164 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Output
)))
24166 Clause_Matched
:= True;
24169 -- A clause where the output is an abstract state with visible null
24170 -- refinement is implicitly matched when the input has already been
24171 -- matched in a previous clause.
24173 -- Depends => (State => Input) -- implicitly OK
24174 -- Refined_State => (State => null)
24175 -- Refined_Depends => (... => Input)
24177 if not Clause_Matched
24178 and then Is_Null_Refined_State
(Dep_Output
)
24179 and then Is_Entity_Name
(Dep_Input
)
24181 Contains
(Matched_Items
, Available_View
(Entity_Of
(Dep_Input
)))
24183 Clause_Matched
:= True;
24186 -- At this point either all refinement clauses have been examined or
24187 -- pragma Refined_Depends contains a solitary null. Only an abstract
24188 -- state with null refinement can possibly match these cases.
24190 -- Depends => (State => null)
24191 -- Refined_State => (State => null)
24192 -- Refined_Depends => null -- OK
24194 if not Clause_Matched
then
24196 (Dep_Item
=> Dep_Input
,
24198 Matched
=> Inputs_Match
);
24201 (Dep_Item
=> Dep_Output
,
24203 Matched
=> Outputs_Match
);
24205 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
24208 -- If the contents of Refined_Depends are legal, then the current
24209 -- dependence clause should be satisfied either by an explicit match
24210 -- or by one of the special cases.
24212 if not Clause_Matched
then
24214 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
24215 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
24217 end Check_Dependency_Clause
;
24219 -------------------------
24220 -- Check_Output_States --
24221 -------------------------
24223 procedure Check_Output_States
is
24224 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24225 -- Determine whether all constituents of state State_Id with full
24226 -- visible refinement are used as outputs in pragma Refined_Depends.
24227 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24229 -----------------------------
24230 -- Check_Constituent_Usage --
24231 -----------------------------
24233 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24234 Constits
: constant Elist_Id
:=
24235 Partial_Refinement_Constituents
(State_Id
);
24236 Constit_Elmt
: Elmt_Id
;
24237 Constit_Id
: Entity_Id
;
24238 Only_Partial
: constant Boolean :=
24239 not Has_Visible_Refinement
(State_Id
);
24240 Posted
: Boolean := False;
24243 if Present
(Constits
) then
24244 Constit_Elmt
:= First_Elmt
(Constits
);
24245 while Present
(Constit_Elmt
) loop
24246 Constit_Id
:= Node
(Constit_Elmt
);
24248 -- Issue an error when a constituent of State_Id is used,
24249 -- and State_Id has only partial visible refinement
24250 -- (SPARK RM 7.2.4(3d)).
24252 if Only_Partial
then
24253 if (Present
(Body_Inputs
)
24254 and then Appears_In
(Body_Inputs
, Constit_Id
))
24256 (Present
(Body_Outputs
)
24257 and then Appears_In
(Body_Outputs
, Constit_Id
))
24259 Error_Msg_Name_1
:= Chars
(State_Id
);
24261 ("constituent & of state % cannot be used in "
24262 & "dependence refinement", N
, Constit_Id
);
24263 Error_Msg_Name_1
:= Chars
(State_Id
);
24264 SPARK_Msg_N
("\use state % instead", N
);
24267 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24269 elsif Present
(Body_Inputs
)
24270 and then Appears_In
(Body_Inputs
, Constit_Id
)
24272 Error_Msg_Name_1
:= Chars
(State_Id
);
24274 ("constituent & of state % must act as output in "
24275 & "dependence refinement", N
, Constit_Id
);
24277 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24279 elsif No
(Body_Outputs
)
24280 or else not Appears_In
(Body_Outputs
, Constit_Id
)
24285 ("output state & must be replaced by all its "
24286 & "constituents in dependence refinement",
24291 ("\constituent & is missing in output list",
24295 Next_Elmt
(Constit_Elmt
);
24298 end Check_Constituent_Usage
;
24303 Item_Elmt
: Elmt_Id
;
24304 Item_Id
: Entity_Id
;
24306 -- Start of processing for Check_Output_States
24309 -- Do not perform this check in an instance because it was already
24310 -- performed successfully in the generic template.
24312 if Is_Generic_Instance
(Spec_Id
) then
24315 -- Inspect the outputs of pragma Depends looking for a state with a
24316 -- visible refinement.
24318 elsif Present
(Spec_Outputs
) then
24319 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
24320 while Present
(Item_Elmt
) loop
24321 Item
:= Node
(Item_Elmt
);
24323 -- Deal with the mixed nature of the input and output lists
24325 if Nkind
(Item
) = N_Defining_Identifier
then
24328 Item_Id
:= Available_View
(Entity_Of
(Item
));
24331 if Ekind
(Item_Id
) = E_Abstract_State
then
24333 -- The state acts as an input-output, skip it
24335 if Present
(Spec_Inputs
)
24336 and then Appears_In
(Spec_Inputs
, Item_Id
)
24340 -- Ensure that all of the constituents are utilized as
24341 -- outputs in pragma Refined_Depends.
24343 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
24344 Check_Constituent_Usage
(Item_Id
);
24348 Next_Elmt
(Item_Elmt
);
24351 end Check_Output_States
;
24353 ---------------------
24354 -- Get_States_Seen --
24355 ---------------------
24357 function Get_States_Seen
(Dependencies
: List_Id
) return Elist_Id
is
24358 States_Seen
: Elist_Id
:= No_Elist
;
24360 procedure Get_State
(Glob_Item
: Node_Id
);
24361 -- Add global item to States_Seen when it corresponds to a state
24367 procedure Get_State
(Glob_Item
: Node_Id
) is
24370 if Is_Entity_Name
(Glob_Item
) then
24371 Id
:= Entity_Of
(Glob_Item
);
24373 if Ekind
(Id
) = E_Abstract_State
then
24374 Append_New_Elmt
(Id
, States_Seen
);
24381 Dep_Clause
: Node_Id
;
24382 Dep_Input
: Node_Id
;
24383 Dep_Output
: Node_Id
;
24385 -- Start of processing for Get_States_Seen
24388 Dep_Clause
:= First
(Dependencies
);
24389 while Present
(Dep_Clause
) loop
24390 Dep_Input
:= Expression
(Dep_Clause
);
24391 Dep_Output
:= First
(Choices
(Dep_Clause
));
24393 Get_State
(Dep_Input
);
24394 Get_State
(Dep_Output
);
24399 return States_Seen
;
24400 end Get_States_Seen
;
24402 -----------------------
24403 -- Normalize_Clauses --
24404 -----------------------
24406 procedure Normalize_Clauses
(Clauses
: List_Id
) is
24407 procedure Normalize_Inputs
(Clause
: Node_Id
);
24408 -- Normalize clause Clause by creating multiple clauses for each
24409 -- input item of Clause. It is assumed that Clause has exactly one
24410 -- output. The transformation is as follows:
24412 -- Output => (Input_1, Input_2) -- original
24414 -- Output => Input_1 -- normalizations
24415 -- Output => Input_2
24417 procedure Normalize_Outputs
(Clause
: Node_Id
);
24418 -- Normalize clause Clause by creating multiple clause for each
24419 -- output item of Clause. The transformation is as follows:
24421 -- (Output_1, Output_2) => Input -- original
24423 -- Output_1 => Input -- normalization
24424 -- Output_2 => Input
24426 ----------------------
24427 -- Normalize_Inputs --
24428 ----------------------
24430 procedure Normalize_Inputs
(Clause
: Node_Id
) is
24431 Inputs
: constant Node_Id
:= Expression
(Clause
);
24432 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24433 Output
: constant List_Id
:= Choices
(Clause
);
24434 Last_Input
: Node_Id
;
24436 New_Clause
: Node_Id
;
24437 Next_Input
: Node_Id
;
24440 -- Normalization is performed only when the original clause has
24441 -- more than one input. Multiple inputs appear as an aggregate.
24443 if Nkind
(Inputs
) = N_Aggregate
then
24444 Last_Input
:= Last
(Expressions
(Inputs
));
24446 -- Create a new clause for each input
24448 Input
:= First
(Expressions
(Inputs
));
24449 while Present
(Input
) loop
24450 Next_Input
:= Next
(Input
);
24452 -- Unhook the current input from the original input list
24453 -- because it will be relocated to a new clause.
24457 -- Special processing for the last input. At this point the
24458 -- original aggregate has been stripped down to one element.
24459 -- Replace the aggregate by the element itself.
24461 if Input
= Last_Input
then
24462 Rewrite
(Inputs
, Input
);
24464 -- Generate a clause of the form:
24469 Make_Component_Association
(Loc
,
24470 Choices
=> New_Copy_List_Tree
(Output
),
24471 Expression
=> Input
);
24473 -- The new clause contains replicated content that has
24474 -- already been analyzed, mark the clause as analyzed.
24476 Set_Analyzed
(New_Clause
);
24477 Insert_After
(Clause
, New_Clause
);
24480 Input
:= Next_Input
;
24483 end Normalize_Inputs
;
24485 -----------------------
24486 -- Normalize_Outputs --
24487 -----------------------
24489 procedure Normalize_Outputs
(Clause
: Node_Id
) is
24490 Inputs
: constant Node_Id
:= Expression
(Clause
);
24491 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24492 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
24493 Last_Output
: Node_Id
;
24494 New_Clause
: Node_Id
;
24495 Next_Output
: Node_Id
;
24499 -- Multiple outputs appear as an aggregate. Nothing to do when
24500 -- the clause has exactly one output.
24502 if Nkind
(Outputs
) = N_Aggregate
then
24503 Last_Output
:= Last
(Expressions
(Outputs
));
24505 -- Create a clause for each output. Note that each time a new
24506 -- clause is created, the original output list slowly shrinks
24507 -- until there is one item left.
24509 Output
:= First
(Expressions
(Outputs
));
24510 while Present
(Output
) loop
24511 Next_Output
:= Next
(Output
);
24513 -- Unhook the output from the original output list as it
24514 -- will be relocated to a new clause.
24518 -- Special processing for the last output. At this point
24519 -- the original aggregate has been stripped down to one
24520 -- element. Replace the aggregate by the element itself.
24522 if Output
= Last_Output
then
24523 Rewrite
(Outputs
, Output
);
24526 -- Generate a clause of the form:
24527 -- (Output => Inputs)
24530 Make_Component_Association
(Loc
,
24531 Choices
=> New_List
(Output
),
24532 Expression
=> New_Copy_Tree
(Inputs
));
24534 -- The new clause contains replicated content that has
24535 -- already been analyzed. There is not need to reanalyze
24538 Set_Analyzed
(New_Clause
);
24539 Insert_After
(Clause
, New_Clause
);
24542 Output
:= Next_Output
;
24545 end Normalize_Outputs
;
24551 -- Start of processing for Normalize_Clauses
24554 Clause
:= First
(Clauses
);
24555 while Present
(Clause
) loop
24556 Normalize_Outputs
(Clause
);
24560 Clause
:= First
(Clauses
);
24561 while Present
(Clause
) loop
24562 Normalize_Inputs
(Clause
);
24565 end Normalize_Clauses
;
24567 --------------------------
24568 -- Report_Extra_Clauses --
24569 --------------------------
24571 procedure Report_Extra_Clauses
is
24575 -- Do not perform this check in an instance because it was already
24576 -- performed successfully in the generic template.
24578 if Is_Generic_Instance
(Spec_Id
) then
24581 elsif Present
(Refinements
) then
24582 Clause
:= First
(Refinements
);
24583 while Present
(Clause
) loop
24585 -- Do not complain about a null input refinement, since a null
24586 -- input legitimately matches anything.
24588 if Nkind
(Clause
) = N_Component_Association
24589 and then Nkind
(Expression
(Clause
)) = N_Null
24595 ("unmatched or extra clause in dependence refinement",
24602 end Report_Extra_Clauses
;
24606 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
24607 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
24608 Errors
: constant Nat
:= Serious_Errors_Detected
;
24613 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
24616 -- Do not analyze the pragma multiple times
24618 if Is_Analyzed_Pragma
(N
) then
24622 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
24624 -- Use the anonymous object as the proper spec when Refined_Depends
24625 -- applies to the body of a single task type. The object carries the
24626 -- proper Chars as well as all non-refined versions of pragmas.
24628 if Is_Single_Concurrent_Type
(Spec_Id
) then
24629 Spec_Id
:= Anonymous_Object
(Spec_Id
);
24632 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
24634 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
24635 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
24637 if No
(Depends
) then
24639 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
24640 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
24644 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
24646 -- A null dependency relation renders the refinement useless because it
24647 -- cannot possibly mention abstract states with visible refinement. Note
24648 -- that the inverse is not true as states may be refined to null
24649 -- (SPARK RM 7.2.5(2)).
24651 if Nkind
(Deps
) = N_Null
then
24653 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
24654 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
24658 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
24659 -- This ensures that the categorization of all refined dependency items
24660 -- is consistent with their role.
24662 Analyze_Depends_In_Decl_Part
(N
);
24664 -- Do not match dependencies against refinements if Refined_Depends is
24665 -- illegal to avoid emitting misleading error.
24667 if Serious_Errors_Detected
= Errors
then
24669 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
24670 -- the inputs and outputs of the subprogram spec and body to verify
24671 -- the use of states with visible refinement and their constituents.
24673 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
24674 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
24676 Collect_Subprogram_Inputs_Outputs
24677 (Subp_Id
=> Spec_Id
,
24678 Synthesize
=> True,
24679 Subp_Inputs
=> Spec_Inputs
,
24680 Subp_Outputs
=> Spec_Outputs
,
24681 Global_Seen
=> Dummy
);
24683 Collect_Subprogram_Inputs_Outputs
24684 (Subp_Id
=> Body_Id
,
24685 Synthesize
=> True,
24686 Subp_Inputs
=> Body_Inputs
,
24687 Subp_Outputs
=> Body_Outputs
,
24688 Global_Seen
=> Dummy
);
24690 -- For an output state with a visible refinement, ensure that all
24691 -- constituents appear as outputs in the dependency refinement.
24693 Check_Output_States
;
24696 -- Matching is disabled in ASIS because clauses are not normalized as
24697 -- this is a tree altering activity similar to expansion.
24703 -- Multiple dependency clauses appear as component associations of an
24704 -- aggregate. Note that the clauses are copied because the algorithm
24705 -- modifies them and this should not be visible in Depends.
24707 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
24708 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
24709 Normalize_Clauses
(Dependencies
);
24711 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
24713 if Nkind
(Refs
) = N_Null
then
24714 Refinements
:= No_List
;
24716 -- Multiple dependency clauses appear as component associations of an
24717 -- aggregate. Note that the clauses are copied because the algorithm
24718 -- modifies them and this should not be visible in Refined_Depends.
24720 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
24721 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
24722 Normalize_Clauses
(Refinements
);
24725 -- At this point the clauses of pragmas Depends and Refined_Depends
24726 -- have been normalized into simple dependencies between one output
24727 -- and one input. Examine all clauses of pragma Depends looking for
24728 -- matching clauses in pragma Refined_Depends.
24731 States_Seen
: constant Elist_Id
:= Get_States_Seen
(Dependencies
);
24735 Clause
:= First
(Dependencies
);
24736 while Present
(Clause
) loop
24737 Check_Dependency_Clause
(States_Seen
, Clause
);
24742 if Serious_Errors_Detected
= Errors
then
24743 Report_Extra_Clauses
;
24748 Set_Is_Analyzed_Pragma
(N
);
24749 end Analyze_Refined_Depends_In_Decl_Part
;
24751 -----------------------------------------
24752 -- Analyze_Refined_Global_In_Decl_Part --
24753 -----------------------------------------
24755 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
24757 -- The corresponding Global pragma
24759 Has_In_State
: Boolean := False;
24760 Has_In_Out_State
: Boolean := False;
24761 Has_Out_State
: Boolean := False;
24762 Has_Proof_In_State
: Boolean := False;
24763 -- These flags are set when the corresponding Global pragma has a state
24764 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
24767 Has_Null_State
: Boolean := False;
24768 -- This flag is set when the corresponding Global pragma has at least
24769 -- one state with a null refinement.
24771 In_Constits
: Elist_Id
:= No_Elist
;
24772 In_Out_Constits
: Elist_Id
:= No_Elist
;
24773 Out_Constits
: Elist_Id
:= No_Elist
;
24774 Proof_In_Constits
: Elist_Id
:= No_Elist
;
24775 -- These lists contain the entities of all Input, In_Out, Output and
24776 -- Proof_In constituents that appear in Refined_Global and participate
24777 -- in state refinement.
24779 In_Items
: Elist_Id
:= No_Elist
;
24780 In_Out_Items
: Elist_Id
:= No_Elist
;
24781 Out_Items
: Elist_Id
:= No_Elist
;
24782 Proof_In_Items
: Elist_Id
:= No_Elist
;
24783 -- These lists contain the entities of all Input, In_Out, Output and
24784 -- Proof_In items defined in the corresponding Global pragma.
24786 Repeat_Items
: Elist_Id
:= No_Elist
;
24787 -- A list of all global items without full visible refinement found
24788 -- in pragma Global. These states should be repeated in the global
24789 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
24790 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
24792 Spec_Id
: Entity_Id
;
24793 -- The entity of the subprogram subject to pragma Refined_Global
24795 States
: Elist_Id
:= No_Elist
;
24796 -- A list of all states with full or partial visible refinement found in
24799 procedure Check_In_Out_States
;
24800 -- Determine whether the corresponding Global pragma mentions In_Out
24801 -- states with visible refinement and if so, ensure that one of the
24802 -- following completions apply to the constituents of the state:
24803 -- 1) there is at least one constituent of mode In_Out
24804 -- 2) there is at least one Input and one Output constituent
24805 -- 3) not all constituents are present and one of them is of mode
24807 -- This routine may remove elements from In_Constits, In_Out_Constits,
24808 -- Out_Constits and Proof_In_Constits.
24810 procedure Check_Input_States
;
24811 -- Determine whether the corresponding Global pragma mentions Input
24812 -- states with visible refinement and if so, ensure that at least one of
24813 -- its constituents appears as an Input item in Refined_Global.
24814 -- This routine may remove elements from In_Constits, In_Out_Constits,
24815 -- Out_Constits and Proof_In_Constits.
24817 procedure Check_Output_States
;
24818 -- Determine whether the corresponding Global pragma mentions Output
24819 -- states with visible refinement and if so, ensure that all of its
24820 -- constituents appear as Output items in Refined_Global.
24821 -- This routine may remove elements from In_Constits, In_Out_Constits,
24822 -- Out_Constits and Proof_In_Constits.
24824 procedure Check_Proof_In_States
;
24825 -- Determine whether the corresponding Global pragma mentions Proof_In
24826 -- states with visible refinement and if so, ensure that at least one of
24827 -- its constituents appears as a Proof_In item in Refined_Global.
24828 -- This routine may remove elements from In_Constits, In_Out_Constits,
24829 -- Out_Constits and Proof_In_Constits.
24831 procedure Check_Refined_Global_List
24833 Global_Mode
: Name_Id
:= Name_Input
);
24834 -- Verify the legality of a single global list declaration. Global_Mode
24835 -- denotes the current mode in effect.
24837 procedure Collect_Global_Items
24839 Mode
: Name_Id
:= Name_Input
);
24840 -- Gather all Input, In_Out, Output and Proof_In items from node List
24841 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
24842 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
24843 -- and Has_Proof_In_State are set when there is at least one abstract
24844 -- state with full or partial visible refinement available in the
24845 -- corresponding mode. Flag Has_Null_State is set when at least state
24846 -- has a null refinement. Mode denotes the current global mode in
24849 function Present_Then_Remove
24851 Item
: Entity_Id
) return Boolean;
24852 -- Search List for a particular entity Item. If Item has been found,
24853 -- remove it from List. This routine is used to strip lists In_Constits,
24854 -- In_Out_Constits and Out_Constits of valid constituents.
24856 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
24857 -- Same as function Present_Then_Remove, but do not report the presence
24858 -- of Item in List.
24860 procedure Report_Extra_Constituents
;
24861 -- Emit an error for each constituent found in lists In_Constits,
24862 -- In_Out_Constits and Out_Constits.
24864 procedure Report_Missing_Items
;
24865 -- Emit an error for each global item not repeated found in list
24868 -------------------------
24869 -- Check_In_Out_States --
24870 -------------------------
24872 procedure Check_In_Out_States
is
24873 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24874 -- Determine whether one of the following coverage scenarios is in
24876 -- 1) there is at least one constituent of mode In_Out or Output
24877 -- 2) there is at least one pair of constituents with modes Input
24878 -- and Output, or Proof_In and Output.
24879 -- 3) there is at least one constituent of mode Output and not all
24880 -- constituents are present.
24881 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
24883 -----------------------------
24884 -- Check_Constituent_Usage --
24885 -----------------------------
24887 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24888 Constits
: constant Elist_Id
:=
24889 Partial_Refinement_Constituents
(State_Id
);
24890 Constit_Elmt
: Elmt_Id
;
24891 Constit_Id
: Entity_Id
;
24892 Has_Missing
: Boolean := False;
24893 In_Out_Seen
: Boolean := False;
24894 Input_Seen
: Boolean := False;
24895 Output_Seen
: Boolean := False;
24896 Proof_In_Seen
: Boolean := False;
24899 -- Process all the constituents of the state and note their modes
24900 -- within the global refinement.
24902 if Present
(Constits
) then
24903 Constit_Elmt
:= First_Elmt
(Constits
);
24904 while Present
(Constit_Elmt
) loop
24905 Constit_Id
:= Node
(Constit_Elmt
);
24907 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
24908 Input_Seen
:= True;
24910 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
24911 In_Out_Seen
:= True;
24913 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
24914 Output_Seen
:= True;
24916 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
24918 Proof_In_Seen
:= True;
24921 Has_Missing
:= True;
24924 Next_Elmt
(Constit_Elmt
);
24928 -- An In_Out constituent is a valid completion
24930 if In_Out_Seen
then
24933 -- A pair of one Input/Proof_In and one Output constituent is a
24934 -- valid completion.
24936 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
24939 elsif Output_Seen
then
24941 -- A single Output constituent is a valid completion only when
24942 -- some of the other constituents are missing.
24944 if Has_Missing
then
24947 -- Otherwise all constituents are of mode Output
24951 ("global refinement of state & must include at least one "
24952 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
24956 -- The state lacks a completion. When full refinement is visible,
24957 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
24958 -- refinement is visible, emit an error if the abstract state
24959 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
24960 -- both are utilized, Check_State_And_Constituent_Use. will issue
24963 elsif not Input_Seen
24964 and then not In_Out_Seen
24965 and then not Output_Seen
24966 and then not Proof_In_Seen
24968 if Has_Visible_Refinement
(State_Id
)
24969 or else Contains
(Repeat_Items
, State_Id
)
24972 ("missing global refinement of state &", N
, State_Id
);
24975 -- Otherwise the state has a malformed completion where at least
24976 -- one of the constituents has a different mode.
24980 ("global refinement of state & redefines the mode of its "
24981 & "constituents", N
, State_Id
);
24983 end Check_Constituent_Usage
;
24987 Item_Elmt
: Elmt_Id
;
24988 Item_Id
: Entity_Id
;
24990 -- Start of processing for Check_In_Out_States
24993 -- Do not perform this check in an instance because it was already
24994 -- performed successfully in the generic template.
24996 if Is_Generic_Instance
(Spec_Id
) then
24999 -- Inspect the In_Out items of the corresponding Global pragma
25000 -- looking for a state with a visible refinement.
25002 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
25003 Item_Elmt
:= First_Elmt
(In_Out_Items
);
25004 while Present
(Item_Elmt
) loop
25005 Item_Id
:= Node
(Item_Elmt
);
25007 -- Ensure that one of the three coverage variants is satisfied
25009 if Ekind
(Item_Id
) = E_Abstract_State
25010 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25012 Check_Constituent_Usage
(Item_Id
);
25015 Next_Elmt
(Item_Elmt
);
25018 end Check_In_Out_States
;
25020 ------------------------
25021 -- Check_Input_States --
25022 ------------------------
25024 procedure Check_Input_States
is
25025 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25026 -- Determine whether at least one constituent of state State_Id with
25027 -- full or partial visible refinement is used and has mode Input.
25028 -- Ensure that the remaining constituents do not have In_Out or
25029 -- Output modes. Emit an error if this is not the case
25030 -- (SPARK RM 7.2.4(5)).
25032 -----------------------------
25033 -- Check_Constituent_Usage --
25034 -----------------------------
25036 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25037 Constits
: constant Elist_Id
:=
25038 Partial_Refinement_Constituents
(State_Id
);
25039 Constit_Elmt
: Elmt_Id
;
25040 Constit_Id
: Entity_Id
;
25041 In_Seen
: Boolean := False;
25044 if Present
(Constits
) then
25045 Constit_Elmt
:= First_Elmt
(Constits
);
25046 while Present
(Constit_Elmt
) loop
25047 Constit_Id
:= Node
(Constit_Elmt
);
25049 -- At least one of the constituents appears as an Input
25051 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25054 -- A Proof_In constituent can refine an Input state as long
25055 -- as there is at least one Input constituent present.
25057 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25061 -- The constituent appears in the global refinement, but has
25062 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25064 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25065 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25067 Error_Msg_Name_1
:= Chars
(State_Id
);
25069 ("constituent & of state % must have mode `Input` in "
25070 & "global refinement", N
, Constit_Id
);
25073 Next_Elmt
(Constit_Elmt
);
25077 -- Not one of the constituents appeared as Input. Always emit an
25078 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25079 -- When only partial refinement is visible, emit an error if the
25080 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25081 -- the case where both are utilized, an error will be issued in
25082 -- Check_State_And_Constituent_Use.
25085 and then (Has_Visible_Refinement
(State_Id
)
25086 or else Contains
(Repeat_Items
, State_Id
))
25089 ("global refinement of state & must include at least one "
25090 & "constituent of mode `Input`", N
, State_Id
);
25092 end Check_Constituent_Usage
;
25096 Item_Elmt
: Elmt_Id
;
25097 Item_Id
: Entity_Id
;
25099 -- Start of processing for Check_Input_States
25102 -- Do not perform this check in an instance because it was already
25103 -- performed successfully in the generic template.
25105 if Is_Generic_Instance
(Spec_Id
) then
25108 -- Inspect the Input items of the corresponding Global pragma looking
25109 -- for a state with a visible refinement.
25111 elsif Has_In_State
and then Present
(In_Items
) then
25112 Item_Elmt
:= First_Elmt
(In_Items
);
25113 while Present
(Item_Elmt
) loop
25114 Item_Id
:= Node
(Item_Elmt
);
25116 -- When full refinement is visible, ensure that at least one of
25117 -- the constituents is utilized and is of mode Input. When only
25118 -- partial refinement is visible, ensure that either one of
25119 -- the constituents is utilized and is of mode Input, or the
25120 -- abstract state is repeated and no constituent is utilized.
25122 if Ekind
(Item_Id
) = E_Abstract_State
25123 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25125 Check_Constituent_Usage
(Item_Id
);
25128 Next_Elmt
(Item_Elmt
);
25131 end Check_Input_States
;
25133 -------------------------
25134 -- Check_Output_States --
25135 -------------------------
25137 procedure Check_Output_States
is
25138 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25139 -- Determine whether all constituents of state State_Id with full
25140 -- visible refinement are used and have mode Output. Emit an error
25141 -- if this is not the case (SPARK RM 7.2.4(5)).
25143 -----------------------------
25144 -- Check_Constituent_Usage --
25145 -----------------------------
25147 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25148 Constits
: constant Elist_Id
:=
25149 Partial_Refinement_Constituents
(State_Id
);
25150 Only_Partial
: constant Boolean :=
25151 not Has_Visible_Refinement
(State_Id
);
25152 Constit_Elmt
: Elmt_Id
;
25153 Constit_Id
: Entity_Id
;
25154 Posted
: Boolean := False;
25157 if Present
(Constits
) then
25158 Constit_Elmt
:= First_Elmt
(Constits
);
25159 while Present
(Constit_Elmt
) loop
25160 Constit_Id
:= Node
(Constit_Elmt
);
25162 -- Issue an error when a constituent of State_Id is utilized
25163 -- and State_Id has only partial visible refinement
25164 -- (SPARK RM 7.2.4(3d)).
25166 if Only_Partial
then
25167 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
25168 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
25170 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25172 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25174 Error_Msg_Name_1
:= Chars
(State_Id
);
25176 ("constituent & of state % cannot be used in global "
25177 & "refinement", N
, Constit_Id
);
25178 Error_Msg_Name_1
:= Chars
(State_Id
);
25179 SPARK_Msg_N
("\use state % instead", N
);
25182 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25185 -- The constituent appears in the global refinement, but has
25186 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25188 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25189 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25190 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25192 Error_Msg_Name_1
:= Chars
(State_Id
);
25194 ("constituent & of state % must have mode `Output` in "
25195 & "global refinement", N
, Constit_Id
);
25197 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25203 ("`Output` state & must be replaced by all its "
25204 & "constituents in global refinement", N
, State_Id
);
25208 ("\constituent & is missing in output list",
25212 Next_Elmt
(Constit_Elmt
);
25215 end Check_Constituent_Usage
;
25219 Item_Elmt
: Elmt_Id
;
25220 Item_Id
: Entity_Id
;
25222 -- Start of processing for Check_Output_States
25225 -- Do not perform this check in an instance because it was already
25226 -- performed successfully in the generic template.
25228 if Is_Generic_Instance
(Spec_Id
) then
25231 -- Inspect the Output items of the corresponding Global pragma
25232 -- looking for a state with a visible refinement.
25234 elsif Has_Out_State
and then Present
(Out_Items
) then
25235 Item_Elmt
:= First_Elmt
(Out_Items
);
25236 while Present
(Item_Elmt
) loop
25237 Item_Id
:= Node
(Item_Elmt
);
25239 -- When full refinement is visible, ensure that all of the
25240 -- constituents are utilized and they have mode Output. When
25241 -- only partial refinement is visible, ensure that no
25242 -- constituent is utilized.
25244 if Ekind
(Item_Id
) = E_Abstract_State
25245 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25247 Check_Constituent_Usage
(Item_Id
);
25250 Next_Elmt
(Item_Elmt
);
25253 end Check_Output_States
;
25255 ---------------------------
25256 -- Check_Proof_In_States --
25257 ---------------------------
25259 procedure Check_Proof_In_States
is
25260 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25261 -- Determine whether at least one constituent of state State_Id with
25262 -- full or partial visible refinement is used and has mode Proof_In.
25263 -- Ensure that the remaining constituents do not have Input, In_Out,
25264 -- or Output modes. Emit an error if this is not the case
25265 -- (SPARK RM 7.2.4(5)).
25267 -----------------------------
25268 -- Check_Constituent_Usage --
25269 -----------------------------
25271 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25272 Constits
: constant Elist_Id
:=
25273 Partial_Refinement_Constituents
(State_Id
);
25274 Constit_Elmt
: Elmt_Id
;
25275 Constit_Id
: Entity_Id
;
25276 Proof_In_Seen
: Boolean := False;
25279 if Present
(Constits
) then
25280 Constit_Elmt
:= First_Elmt
(Constits
);
25281 while Present
(Constit_Elmt
) loop
25282 Constit_Id
:= Node
(Constit_Elmt
);
25284 -- At least one of the constituents appears as Proof_In
25286 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
25287 Proof_In_Seen
:= True;
25289 -- The constituent appears in the global refinement, but has
25290 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25292 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25293 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25294 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25296 Error_Msg_Name_1
:= Chars
(State_Id
);
25298 ("constituent & of state % must have mode `Proof_In` "
25299 & "in global refinement", N
, Constit_Id
);
25302 Next_Elmt
(Constit_Elmt
);
25306 -- Not one of the constituents appeared as Proof_In. Always emit
25307 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25308 -- When only partial refinement is visible, emit an error if the
25309 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25310 -- the case where both are utilized, an error will be issued by
25311 -- Check_State_And_Constituent_Use.
25313 if not Proof_In_Seen
25314 and then (Has_Visible_Refinement
(State_Id
)
25315 or else Contains
(Repeat_Items
, State_Id
))
25318 ("global refinement of state & must include at least one "
25319 & "constituent of mode `Proof_In`", N
, State_Id
);
25321 end Check_Constituent_Usage
;
25325 Item_Elmt
: Elmt_Id
;
25326 Item_Id
: Entity_Id
;
25328 -- Start of processing for Check_Proof_In_States
25331 -- Do not perform this check in an instance because it was already
25332 -- performed successfully in the generic template.
25334 if Is_Generic_Instance
(Spec_Id
) then
25337 -- Inspect the Proof_In items of the corresponding Global pragma
25338 -- looking for a state with a visible refinement.
25340 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
25341 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
25342 while Present
(Item_Elmt
) loop
25343 Item_Id
:= Node
(Item_Elmt
);
25345 -- Ensure that at least one of the constituents is utilized
25346 -- and is of mode Proof_In. When only partial refinement is
25347 -- visible, ensure that either one of the constituents is
25348 -- utilized and is of mode Proof_In, or the abstract state
25349 -- is repeated and no constituent is utilized.
25351 if Ekind
(Item_Id
) = E_Abstract_State
25352 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25354 Check_Constituent_Usage
(Item_Id
);
25357 Next_Elmt
(Item_Elmt
);
25360 end Check_Proof_In_States
;
25362 -------------------------------
25363 -- Check_Refined_Global_List --
25364 -------------------------------
25366 procedure Check_Refined_Global_List
25368 Global_Mode
: Name_Id
:= Name_Input
)
25370 procedure Check_Refined_Global_Item
25372 Global_Mode
: Name_Id
);
25373 -- Verify the legality of a single global item declaration. Parameter
25374 -- Global_Mode denotes the current mode in effect.
25376 -------------------------------
25377 -- Check_Refined_Global_Item --
25378 -------------------------------
25380 procedure Check_Refined_Global_Item
25382 Global_Mode
: Name_Id
)
25384 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
25386 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
25387 -- Issue a common error message for all mode mismatches. Expect
25388 -- denotes the expected mode.
25390 -----------------------------
25391 -- Inconsistent_Mode_Error --
25392 -----------------------------
25394 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
25397 ("global item & has inconsistent modes", Item
, Item_Id
);
25399 Error_Msg_Name_1
:= Global_Mode
;
25400 Error_Msg_Name_2
:= Expect
;
25401 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
25402 end Inconsistent_Mode_Error
;
25406 Enc_State
: Entity_Id
:= Empty
;
25407 -- Encapsulating state for constituent, Empty otherwise
25409 -- Start of processing for Check_Refined_Global_Item
25412 if Ekind_In
(Item_Id
, E_Abstract_State
,
25416 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
25419 -- When the state or object acts as a constituent of another
25420 -- state with a visible refinement, collect it for the state
25421 -- completeness checks performed later on. Note that the item
25422 -- acts as a constituent only when the encapsulating state is
25423 -- present in pragma Global.
25425 if Present
(Enc_State
)
25426 and then (Has_Visible_Refinement
(Enc_State
)
25427 or else Has_Partial_Visible_Refinement
(Enc_State
))
25428 and then Contains
(States
, Enc_State
)
25430 -- If the state has only partial visible refinement, remove it
25431 -- from the list of items that should be repeated from pragma
25434 if not Has_Visible_Refinement
(Enc_State
) then
25435 Present_Then_Remove
(Repeat_Items
, Enc_State
);
25438 if Global_Mode
= Name_Input
then
25439 Append_New_Elmt
(Item_Id
, In_Constits
);
25441 elsif Global_Mode
= Name_In_Out
then
25442 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
25444 elsif Global_Mode
= Name_Output
then
25445 Append_New_Elmt
(Item_Id
, Out_Constits
);
25447 elsif Global_Mode
= Name_Proof_In
then
25448 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
25451 -- When not a constituent, ensure that both occurrences of the
25452 -- item in pragmas Global and Refined_Global match. Also remove
25453 -- it when present from the list of items that should be repeated
25454 -- from pragma Global.
25457 Present_Then_Remove
(Repeat_Items
, Item_Id
);
25459 if Contains
(In_Items
, Item_Id
) then
25460 if Global_Mode
/= Name_Input
then
25461 Inconsistent_Mode_Error
(Name_Input
);
25464 elsif Contains
(In_Out_Items
, Item_Id
) then
25465 if Global_Mode
/= Name_In_Out
then
25466 Inconsistent_Mode_Error
(Name_In_Out
);
25469 elsif Contains
(Out_Items
, Item_Id
) then
25470 if Global_Mode
/= Name_Output
then
25471 Inconsistent_Mode_Error
(Name_Output
);
25474 elsif Contains
(Proof_In_Items
, Item_Id
) then
25477 -- The item does not appear in the corresponding Global pragma,
25478 -- it must be an extra (SPARK RM 7.2.4(3)).
25481 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
25484 end Check_Refined_Global_Item
;
25490 -- Start of processing for Check_Refined_Global_List
25493 -- Do not perform this check in an instance because it was already
25494 -- performed successfully in the generic template.
25496 if Is_Generic_Instance
(Spec_Id
) then
25499 elsif Nkind
(List
) = N_Null
then
25502 -- Single global item declaration
25504 elsif Nkind_In
(List
, N_Expanded_Name
,
25506 N_Selected_Component
)
25508 Check_Refined_Global_Item
(List
, Global_Mode
);
25510 -- Simple global list or moded global list declaration
25512 elsif Nkind
(List
) = N_Aggregate
then
25514 -- The declaration of a simple global list appear as a collection
25517 if Present
(Expressions
(List
)) then
25518 Item
:= First
(Expressions
(List
));
25519 while Present
(Item
) loop
25520 Check_Refined_Global_Item
(Item
, Global_Mode
);
25524 -- The declaration of a moded global list appears as a collection
25525 -- of component associations where individual choices denote
25528 elsif Present
(Component_Associations
(List
)) then
25529 Item
:= First
(Component_Associations
(List
));
25530 while Present
(Item
) loop
25531 Check_Refined_Global_List
25532 (List
=> Expression
(Item
),
25533 Global_Mode
=> Chars
(First
(Choices
(Item
))));
25541 raise Program_Error
;
25547 raise Program_Error
;
25549 end Check_Refined_Global_List
;
25551 --------------------------
25552 -- Collect_Global_Items --
25553 --------------------------
25555 procedure Collect_Global_Items
25557 Mode
: Name_Id
:= Name_Input
)
25559 procedure Collect_Global_Item
25561 Item_Mode
: Name_Id
);
25562 -- Add a single item to the appropriate list. Item_Mode denotes the
25563 -- current mode in effect.
25565 -------------------------
25566 -- Collect_Global_Item --
25567 -------------------------
25569 procedure Collect_Global_Item
25571 Item_Mode
: Name_Id
)
25573 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
25574 -- The above handles abstract views of variables and states built
25575 -- for limited with clauses.
25578 -- Signal that the global list contains at least one abstract
25579 -- state with a visible refinement. Note that the refinement may
25580 -- be null in which case there are no constituents.
25582 if Ekind
(Item_Id
) = E_Abstract_State
then
25583 if Has_Null_Visible_Refinement
(Item_Id
) then
25584 Has_Null_State
:= True;
25586 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
25587 Append_New_Elmt
(Item_Id
, States
);
25589 if Item_Mode
= Name_Input
then
25590 Has_In_State
:= True;
25591 elsif Item_Mode
= Name_In_Out
then
25592 Has_In_Out_State
:= True;
25593 elsif Item_Mode
= Name_Output
then
25594 Has_Out_State
:= True;
25595 elsif Item_Mode
= Name_Proof_In
then
25596 Has_Proof_In_State
:= True;
25601 -- Record global items without full visible refinement found in
25602 -- pragma Global which should be repeated in the global refinement
25603 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
25605 if Ekind
(Item_Id
) /= E_Abstract_State
25606 or else not Has_Visible_Refinement
(Item_Id
)
25608 Append_New_Elmt
(Item_Id
, Repeat_Items
);
25611 -- Add the item to the proper list
25613 if Item_Mode
= Name_Input
then
25614 Append_New_Elmt
(Item_Id
, In_Items
);
25615 elsif Item_Mode
= Name_In_Out
then
25616 Append_New_Elmt
(Item_Id
, In_Out_Items
);
25617 elsif Item_Mode
= Name_Output
then
25618 Append_New_Elmt
(Item_Id
, Out_Items
);
25619 elsif Item_Mode
= Name_Proof_In
then
25620 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
25622 end Collect_Global_Item
;
25628 -- Start of processing for Collect_Global_Items
25631 if Nkind
(List
) = N_Null
then
25634 -- Single global item declaration
25636 elsif Nkind_In
(List
, N_Expanded_Name
,
25638 N_Selected_Component
)
25640 Collect_Global_Item
(List
, Mode
);
25642 -- Single global list or moded global list declaration
25644 elsif Nkind
(List
) = N_Aggregate
then
25646 -- The declaration of a simple global list appear as a collection
25649 if Present
(Expressions
(List
)) then
25650 Item
:= First
(Expressions
(List
));
25651 while Present
(Item
) loop
25652 Collect_Global_Item
(Item
, Mode
);
25656 -- The declaration of a moded global list appears as a collection
25657 -- of component associations where individual choices denote mode.
25659 elsif Present
(Component_Associations
(List
)) then
25660 Item
:= First
(Component_Associations
(List
));
25661 while Present
(Item
) loop
25662 Collect_Global_Items
25663 (List
=> Expression
(Item
),
25664 Mode
=> Chars
(First
(Choices
(Item
))));
25672 raise Program_Error
;
25675 -- To accomodate partial decoration of disabled SPARK features, this
25676 -- routine may be called with illegal input. If this is the case, do
25677 -- not raise Program_Error.
25682 end Collect_Global_Items
;
25684 -------------------------
25685 -- Present_Then_Remove --
25686 -------------------------
25688 function Present_Then_Remove
25690 Item
: Entity_Id
) return Boolean
25695 if Present
(List
) then
25696 Elmt
:= First_Elmt
(List
);
25697 while Present
(Elmt
) loop
25698 if Node
(Elmt
) = Item
then
25699 Remove_Elmt
(List
, Elmt
);
25708 end Present_Then_Remove
;
25710 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
25713 Ignore
:= Present_Then_Remove
(List
, Item
);
25714 end Present_Then_Remove
;
25716 -------------------------------
25717 -- Report_Extra_Constituents --
25718 -------------------------------
25720 procedure Report_Extra_Constituents
is
25721 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
25722 -- Emit an error for every element of List
25724 ---------------------------------------
25725 -- Report_Extra_Constituents_In_List --
25726 ---------------------------------------
25728 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
25729 Constit_Elmt
: Elmt_Id
;
25732 if Present
(List
) then
25733 Constit_Elmt
:= First_Elmt
(List
);
25734 while Present
(Constit_Elmt
) loop
25735 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
25736 Next_Elmt
(Constit_Elmt
);
25739 end Report_Extra_Constituents_In_List
;
25741 -- Start of processing for Report_Extra_Constituents
25744 -- Do not perform this check in an instance because it was already
25745 -- performed successfully in the generic template.
25747 if Is_Generic_Instance
(Spec_Id
) then
25751 Report_Extra_Constituents_In_List
(In_Constits
);
25752 Report_Extra_Constituents_In_List
(In_Out_Constits
);
25753 Report_Extra_Constituents_In_List
(Out_Constits
);
25754 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
25756 end Report_Extra_Constituents
;
25758 --------------------------
25759 -- Report_Missing_Items --
25760 --------------------------
25762 procedure Report_Missing_Items
is
25763 Item_Elmt
: Elmt_Id
;
25764 Item_Id
: Entity_Id
;
25767 -- Do not perform this check in an instance because it was already
25768 -- performed successfully in the generic template.
25770 if Is_Generic_Instance
(Spec_Id
) then
25774 if Present
(Repeat_Items
) then
25775 Item_Elmt
:= First_Elmt
(Repeat_Items
);
25776 while Present
(Item_Elmt
) loop
25777 Item_Id
:= Node
(Item_Elmt
);
25778 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
25779 Next_Elmt
(Item_Elmt
);
25783 end Report_Missing_Items
;
25787 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25788 Errors
: constant Nat
:= Serious_Errors_Detected
;
25790 No_Constit
: Boolean;
25792 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
25795 -- Do not analyze the pragma multiple times
25797 if Is_Analyzed_Pragma
(N
) then
25801 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25803 -- Use the anonymous object as the proper spec when Refined_Global
25804 -- applies to the body of a single task type. The object carries the
25805 -- proper Chars as well as all non-refined versions of pragmas.
25807 if Is_Single_Concurrent_Type
(Spec_Id
) then
25808 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25811 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
25812 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
25814 -- The subprogram declaration lacks pragma Global. This renders
25815 -- Refined_Global useless as there is nothing to refine.
25817 if No
(Global
) then
25819 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25820 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
25824 -- Extract all relevant items from the corresponding Global pragma
25826 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
25828 -- Package and subprogram bodies are instantiated individually in
25829 -- a separate compiler pass. Due to this mode of instantiation, the
25830 -- refinement of a state may no longer be visible when a subprogram
25831 -- body contract is instantiated. Since the generic template is legal,
25832 -- do not perform this check in the instance to circumvent this oddity.
25834 if Is_Generic_Instance
(Spec_Id
) then
25837 -- Non-instance case
25840 -- The corresponding Global pragma must mention at least one
25841 -- state with a visible refinement at the point Refined_Global
25842 -- is processed. States with null refinements need Refined_Global
25843 -- pragma (SPARK RM 7.2.4(2)).
25845 if not Has_In_State
25846 and then not Has_In_Out_State
25847 and then not Has_Out_State
25848 and then not Has_Proof_In_State
25849 and then not Has_Null_State
25852 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25853 & "depend on abstract state with visible refinement"),
25857 -- The global refinement of inputs and outputs cannot be null when
25858 -- the corresponding Global pragma contains at least one item except
25859 -- in the case where we have states with null refinements.
25861 elsif Nkind
(Items
) = N_Null
25863 (Present
(In_Items
)
25864 or else Present
(In_Out_Items
)
25865 or else Present
(Out_Items
)
25866 or else Present
(Proof_In_Items
))
25867 and then not Has_Null_State
25870 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
25871 & "global items"), N
, Spec_Id
);
25876 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
25877 -- This ensures that the categorization of all refined global items is
25878 -- consistent with their role.
25880 Analyze_Global_In_Decl_Part
(N
);
25882 -- Perform all refinement checks with respect to completeness and mode
25885 if Serious_Errors_Detected
= Errors
then
25886 Check_Refined_Global_List
(Items
);
25889 -- Store the information that no constituent is used in the global
25890 -- refinement, prior to calling checking procedures which remove items
25891 -- from the list of constituents.
25895 and then No
(In_Out_Constits
)
25896 and then No
(Out_Constits
)
25897 and then No
(Proof_In_Constits
);
25899 -- For Input states with visible refinement, at least one constituent
25900 -- must be used as an Input in the global refinement.
25902 if Serious_Errors_Detected
= Errors
then
25903 Check_Input_States
;
25906 -- Verify all possible completion variants for In_Out states with
25907 -- visible refinement.
25909 if Serious_Errors_Detected
= Errors
then
25910 Check_In_Out_States
;
25913 -- For Output states with visible refinement, all constituents must be
25914 -- used as Outputs in the global refinement.
25916 if Serious_Errors_Detected
= Errors
then
25917 Check_Output_States
;
25920 -- For Proof_In states with visible refinement, at least one constituent
25921 -- must be used as Proof_In in the global refinement.
25923 if Serious_Errors_Detected
= Errors
then
25924 Check_Proof_In_States
;
25927 -- Emit errors for all constituents that belong to other states with
25928 -- visible refinement that do not appear in Global.
25930 if Serious_Errors_Detected
= Errors
then
25931 Report_Extra_Constituents
;
25934 -- Emit errors for all items in Global that are not repeated in the
25935 -- global refinement and for which there is no full visible refinement
25936 -- and, in the case of states with partial visible refinement, no
25937 -- constituent is mentioned in the global refinement.
25939 if Serious_Errors_Detected
= Errors
then
25940 Report_Missing_Items
;
25943 -- Emit an error if no constituent is used in the global refinement
25944 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
25945 -- one may be issued by the checking procedures. Do not perform this
25946 -- check in an instance because it was already performed successfully
25947 -- in the generic template.
25949 if Serious_Errors_Detected
= Errors
25950 and then not Is_Generic_Instance
(Spec_Id
)
25951 and then not Has_Null_State
25952 and then No_Constit
25954 SPARK_Msg_N
("missing refinement", N
);
25958 Set_Is_Analyzed_Pragma
(N
);
25959 end Analyze_Refined_Global_In_Decl_Part
;
25961 ----------------------------------------
25962 -- Analyze_Refined_State_In_Decl_Part --
25963 ----------------------------------------
25965 procedure Analyze_Refined_State_In_Decl_Part
25967 Freeze_Id
: Entity_Id
:= Empty
)
25969 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
25970 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25971 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
25973 Available_States
: Elist_Id
:= No_Elist
;
25974 -- A list of all abstract states defined in the package declaration that
25975 -- are available for refinement. The list is used to report unrefined
25978 Body_States
: Elist_Id
:= No_Elist
;
25979 -- A list of all hidden states that appear in the body of the related
25980 -- package. The list is used to report unused hidden states.
25982 Constituents_Seen
: Elist_Id
:= No_Elist
;
25983 -- A list that contains all constituents processed so far. The list is
25984 -- used to detect multiple uses of the same constituent.
25986 Freeze_Posted
: Boolean := False;
25987 -- A flag that controls the output of a freezing-related error (see use
25990 Refined_States_Seen
: Elist_Id
:= No_Elist
;
25991 -- A list that contains all refined states processed so far. The list is
25992 -- used to detect duplicate refinements.
25994 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
25995 -- Perform full analysis of a single refinement clause
25997 procedure Report_Unrefined_States
(States
: Elist_Id
);
25998 -- Emit errors for all unrefined abstract states found in list States
26000 -------------------------------
26001 -- Analyze_Refinement_Clause --
26002 -------------------------------
26004 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
26005 AR_Constit
: Entity_Id
:= Empty
;
26006 AW_Constit
: Entity_Id
:= Empty
;
26007 ER_Constit
: Entity_Id
:= Empty
;
26008 EW_Constit
: Entity_Id
:= Empty
;
26009 -- The entities of external constituents that contain one of the
26010 -- following enabled properties: Async_Readers, Async_Writers,
26011 -- Effective_Reads and Effective_Writes.
26013 External_Constit_Seen
: Boolean := False;
26014 -- Flag used to mark when at least one external constituent is part
26015 -- of the state refinement.
26017 Non_Null_Seen
: Boolean := False;
26018 Null_Seen
: Boolean := False;
26019 -- Flags used to detect multiple uses of null in a single clause or a
26020 -- mixture of null and non-null constituents.
26022 Part_Of_Constits
: Elist_Id
:= No_Elist
;
26023 -- A list of all candidate constituents subject to indicator Part_Of
26024 -- where the encapsulating state is the current state.
26027 State_Id
: Entity_Id
;
26028 -- The current state being refined
26030 procedure Analyze_Constituent
(Constit
: Node_Id
);
26031 -- Perform full analysis of a single constituent
26033 procedure Check_External_Property
26034 (Prop_Nam
: Name_Id
;
26036 Constit
: Entity_Id
);
26037 -- Determine whether a property denoted by name Prop_Nam is present
26038 -- in the refined state. Emit an error if this is not the case. Flag
26039 -- Enabled should be set when the property applies to the refined
26040 -- state. Constit denotes the constituent (if any) which introduces
26041 -- the property in the refinement.
26043 procedure Match_State
;
26044 -- Determine whether the state being refined appears in list
26045 -- Available_States. Emit an error when attempting to re-refine the
26046 -- state or when the state is not defined in the package declaration,
26047 -- otherwise remove the state from Available_States.
26049 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
26050 -- Emit errors for all unused Part_Of constituents in list Constits
26052 -------------------------
26053 -- Analyze_Constituent --
26054 -------------------------
26056 procedure Analyze_Constituent
(Constit
: Node_Id
) is
26057 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
26058 -- Determine whether constituent Constit denoted by its entity
26059 -- Constit_Id appears in Body_States. Emit an error when the
26060 -- constituent is not a valid hidden state of the related package
26061 -- or when it is used more than once. Otherwise remove the
26062 -- constituent from Body_States.
26064 -----------------------
26065 -- Match_Constituent --
26066 -----------------------
26068 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
26069 procedure Collect_Constituent
;
26070 -- Verify the legality of constituent Constit_Id and add it to
26071 -- the refinements of State_Id.
26073 -------------------------
26074 -- Collect_Constituent --
26075 -------------------------
26077 procedure Collect_Constituent
is
26078 Constits
: Elist_Id
;
26081 -- The Ghost policy in effect at the point of abstract state
26082 -- declaration and constituent must match (SPARK RM 6.9(15))
26084 Check_Ghost_Refinement
26085 (State
, State_Id
, Constit
, Constit_Id
);
26087 -- A synchronized state must be refined by a synchronized
26088 -- object or another synchronized state (SPARK RM 9.6).
26090 if Is_Synchronized_State
(State_Id
)
26091 and then not Is_Synchronized_Object
(Constit_Id
)
26092 and then not Is_Synchronized_State
(Constit_Id
)
26095 ("constituent of synchronized state & must be "
26096 & "synchronized", Constit
, State_Id
);
26099 -- Add the constituent to the list of processed items to aid
26100 -- with the detection of duplicates.
26102 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
26104 -- Collect the constituent in the list of refinement items
26105 -- and establish a relation between the refined state and
26108 Constits
:= Refinement_Constituents
(State_Id
);
26110 if No
(Constits
) then
26111 Constits
:= New_Elmt_List
;
26112 Set_Refinement_Constituents
(State_Id
, Constits
);
26115 Append_Elmt
(Constit_Id
, Constits
);
26116 Set_Encapsulating_State
(Constit_Id
, State_Id
);
26118 -- The state has at least one legal constituent, mark the
26119 -- start of the refinement region. The region ends when the
26120 -- body declarations end (see routine Analyze_Declarations).
26122 Set_Has_Visible_Refinement
(State_Id
);
26124 -- When the constituent is external, save its relevant
26125 -- property for further checks.
26127 if Async_Readers_Enabled
(Constit_Id
) then
26128 AR_Constit
:= Constit_Id
;
26129 External_Constit_Seen
:= True;
26132 if Async_Writers_Enabled
(Constit_Id
) then
26133 AW_Constit
:= Constit_Id
;
26134 External_Constit_Seen
:= True;
26137 if Effective_Reads_Enabled
(Constit_Id
) then
26138 ER_Constit
:= Constit_Id
;
26139 External_Constit_Seen
:= True;
26142 if Effective_Writes_Enabled
(Constit_Id
) then
26143 EW_Constit
:= Constit_Id
;
26144 External_Constit_Seen
:= True;
26146 end Collect_Constituent
;
26150 State_Elmt
: Elmt_Id
;
26152 -- Start of processing for Match_Constituent
26155 -- Detect a duplicate use of a constituent
26157 if Contains
(Constituents_Seen
, Constit_Id
) then
26159 ("duplicate use of constituent &", Constit
, Constit_Id
);
26163 -- The constituent is subject to a Part_Of indicator
26165 if Present
(Encapsulating_State
(Constit_Id
)) then
26166 if Encapsulating_State
(Constit_Id
) = State_Id
then
26167 Remove
(Part_Of_Constits
, Constit_Id
);
26168 Collect_Constituent
;
26170 -- The constituent is part of another state and is used
26171 -- incorrectly in the refinement of the current state.
26174 Error_Msg_Name_1
:= Chars
(State_Id
);
26176 ("& cannot act as constituent of state %",
26177 Constit
, Constit_Id
);
26179 ("\Part_Of indicator specifies encapsulator &",
26180 Constit
, Encapsulating_State
(Constit_Id
));
26183 -- The only other source of legal constituents is the body
26184 -- state space of the related package.
26187 if Present
(Body_States
) then
26188 State_Elmt
:= First_Elmt
(Body_States
);
26189 while Present
(State_Elmt
) loop
26191 -- Consume a valid constituent to signal that it has
26192 -- been encountered.
26194 if Node
(State_Elmt
) = Constit_Id
then
26195 Remove_Elmt
(Body_States
, State_Elmt
);
26196 Collect_Constituent
;
26200 Next_Elmt
(State_Elmt
);
26204 -- Constants are part of the hidden state of a package, but
26205 -- the compiler cannot determine whether they have variable
26206 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26207 -- hidden state. Accept the constant quietly even if it is
26208 -- a visible state or lacks a Part_Of indicator.
26210 if Ekind
(Constit_Id
) = E_Constant
then
26211 Collect_Constituent
;
26213 -- If we get here, then the constituent is not a hidden
26214 -- state of the related package and may not be used in a
26215 -- refinement (SPARK RM 7.2.2(9)).
26218 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26220 ("cannot use & in refinement, constituent is not a "
26221 & "hidden state of package %", Constit
, Constit_Id
);
26224 end Match_Constituent
;
26228 Constit_Id
: Entity_Id
;
26229 Constits
: Elist_Id
;
26231 -- Start of processing for Analyze_Constituent
26234 -- Detect multiple uses of null in a single refinement clause or a
26235 -- mixture of null and non-null constituents.
26237 if Nkind
(Constit
) = N_Null
then
26240 ("multiple null constituents not allowed", Constit
);
26242 elsif Non_Null_Seen
then
26244 ("cannot mix null and non-null constituents", Constit
);
26249 -- Collect the constituent in the list of refinement items
26251 Constits
:= Refinement_Constituents
(State_Id
);
26253 if No
(Constits
) then
26254 Constits
:= New_Elmt_List
;
26255 Set_Refinement_Constituents
(State_Id
, Constits
);
26258 Append_Elmt
(Constit
, Constits
);
26260 -- The state has at least one legal constituent, mark the
26261 -- start of the refinement region. The region ends when the
26262 -- body declarations end (see Analyze_Declarations).
26264 Set_Has_Visible_Refinement
(State_Id
);
26267 -- Non-null constituents
26270 Non_Null_Seen
:= True;
26274 ("cannot mix null and non-null constituents", Constit
);
26278 Resolve_State
(Constit
);
26280 -- Ensure that the constituent denotes a valid state or a
26281 -- whole object (SPARK RM 7.2.2(5)).
26283 if Is_Entity_Name
(Constit
) then
26284 Constit_Id
:= Entity_Of
(Constit
);
26286 -- When a constituent is declared after a subprogram body
26287 -- that caused "freezing" of the related contract where
26288 -- pragma Refined_State resides, the constituent appears
26289 -- undefined and carries Any_Id as its entity.
26291 -- package body Pack
26292 -- with Refined_State => (State => Constit)
26295 -- with Refined_Global => (Input => Constit)
26303 if Constit_Id
= Any_Id
then
26304 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
26306 -- Emit a specialized info message when the contract of
26307 -- the related package body was "frozen" by another body.
26308 -- Note that it is not possible to precisely identify why
26309 -- the constituent is undefined because it is not visible
26310 -- when pragma Refined_State is analyzed. This message is
26311 -- a reasonable approximation.
26313 if Present
(Freeze_Id
) and then not Freeze_Posted
then
26314 Freeze_Posted
:= True;
26316 Error_Msg_Name_1
:= Chars
(Body_Id
);
26317 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
26319 ("body & declared # freezes the contract of %",
26322 ("\all constituents must be declared before body #",
26325 -- A misplaced constituent is a critical error because
26326 -- pragma Refined_Depends or Refined_Global depends on
26327 -- the proper link between a state and a constituent.
26328 -- Stop the compilation, as this leads to a multitude
26329 -- of misleading cascaded errors.
26331 raise Program_Error
;
26334 -- The constituent is a valid state or object
26336 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
26340 Match_Constituent
(Constit_Id
);
26342 -- The variable may eventually become a constituent of a
26343 -- single protected/task type. Record the reference now
26344 -- and verify its legality when analyzing the contract of
26345 -- the variable (SPARK RM 9.3).
26347 if Ekind
(Constit_Id
) = E_Variable
then
26348 Record_Possible_Part_Of_Reference
26349 (Var_Id
=> Constit_Id
,
26353 -- Otherwise the constituent is illegal
26357 ("constituent & must denote object or state",
26358 Constit
, Constit_Id
);
26361 -- The constituent is illegal
26364 SPARK_Msg_N
("malformed constituent", Constit
);
26367 end Analyze_Constituent
;
26369 -----------------------------
26370 -- Check_External_Property --
26371 -----------------------------
26373 procedure Check_External_Property
26374 (Prop_Nam
: Name_Id
;
26376 Constit
: Entity_Id
)
26379 -- The property is missing in the declaration of the state, but
26380 -- a constituent is introducing it in the state refinement
26381 -- (SPARK RM 7.2.8(2)).
26383 if not Enabled
and then Present
(Constit
) then
26384 Error_Msg_Name_1
:= Prop_Nam
;
26385 Error_Msg_Name_2
:= Chars
(State_Id
);
26387 ("constituent & introduces external property % in refinement "
26388 & "of state %", State
, Constit
);
26390 Error_Msg_Sloc
:= Sloc
(State_Id
);
26392 ("\property is missing in abstract state declaration #",
26395 end Check_External_Property
;
26401 procedure Match_State
is
26402 State_Elmt
: Elmt_Id
;
26405 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
26407 if Contains
(Refined_States_Seen
, State_Id
) then
26409 ("duplicate refinement of state &", State
, State_Id
);
26413 -- Inspect the abstract states defined in the package declaration
26414 -- looking for a match.
26416 State_Elmt
:= First_Elmt
(Available_States
);
26417 while Present
(State_Elmt
) loop
26419 -- A valid abstract state is being refined in the body. Add
26420 -- the state to the list of processed refined states to aid
26421 -- with the detection of duplicate refinements. Remove the
26422 -- state from Available_States to signal that it has already
26425 if Node
(State_Elmt
) = State_Id
then
26426 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
26427 Remove_Elmt
(Available_States
, State_Elmt
);
26431 Next_Elmt
(State_Elmt
);
26434 -- If we get here, we are refining a state that is not defined in
26435 -- the package declaration.
26437 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26439 ("cannot refine state, & is not defined in package %",
26443 --------------------------------
26444 -- Report_Unused_Constituents --
26445 --------------------------------
26447 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
26448 Constit_Elmt
: Elmt_Id
;
26449 Constit_Id
: Entity_Id
;
26450 Posted
: Boolean := False;
26453 if Present
(Constits
) then
26454 Constit_Elmt
:= First_Elmt
(Constits
);
26455 while Present
(Constit_Elmt
) loop
26456 Constit_Id
:= Node
(Constit_Elmt
);
26458 -- Generate an error message of the form:
26460 -- state ... has unused Part_Of constituents
26461 -- abstract state ... defined at ...
26462 -- constant ... defined at ...
26463 -- variable ... defined at ...
26468 ("state & has unused Part_Of constituents",
26472 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
26474 if Ekind
(Constit_Id
) = E_Abstract_State
then
26476 ("\abstract state & defined #", State
, Constit_Id
);
26478 elsif Ekind
(Constit_Id
) = E_Constant
then
26480 ("\constant & defined #", State
, Constit_Id
);
26483 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
26484 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
26487 Next_Elmt
(Constit_Elmt
);
26490 end Report_Unused_Constituents
;
26492 -- Local declarations
26494 Body_Ref
: Node_Id
;
26495 Body_Ref_Elmt
: Elmt_Id
;
26497 Extra_State
: Node_Id
;
26499 -- Start of processing for Analyze_Refinement_Clause
26502 -- A refinement clause appears as a component association where the
26503 -- sole choice is the state and the expressions are the constituents.
26504 -- This is a syntax error, always report.
26506 if Nkind
(Clause
) /= N_Component_Association
then
26507 Error_Msg_N
("malformed state refinement clause", Clause
);
26511 -- Analyze the state name of a refinement clause
26513 State
:= First
(Choices
(Clause
));
26516 Resolve_State
(State
);
26518 -- Ensure that the state name denotes a valid abstract state that is
26519 -- defined in the spec of the related package.
26521 if Is_Entity_Name
(State
) then
26522 State_Id
:= Entity_Of
(State
);
26524 -- When the abstract state is undefined, it appears as Any_Id. Do
26525 -- not continue with the analysis of the clause.
26527 if State_Id
= Any_Id
then
26530 -- Catch any attempts to re-refine a state or refine a state that
26531 -- is not defined in the package declaration.
26533 elsif Ekind
(State_Id
) = E_Abstract_State
then
26537 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
26541 -- References to a state with visible refinement are illegal.
26542 -- When nested packages are involved, detecting such references is
26543 -- tricky because pragma Refined_State is analyzed later than the
26544 -- offending pragma Depends or Global. References that occur in
26545 -- such nested context are stored in a list. Emit errors for all
26546 -- references found in Body_References (SPARK RM 6.1.4(8)).
26548 if Present
(Body_References
(State_Id
)) then
26549 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
26550 while Present
(Body_Ref_Elmt
) loop
26551 Body_Ref
:= Node
(Body_Ref_Elmt
);
26553 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
26554 Error_Msg_Sloc
:= Sloc
(State
);
26555 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
26557 Next_Elmt
(Body_Ref_Elmt
);
26561 -- The state name is illegal. This is a syntax error, always report.
26564 Error_Msg_N
("malformed state name in refinement clause", State
);
26568 -- A refinement clause may only refine one state at a time
26570 Extra_State
:= Next
(State
);
26572 if Present
(Extra_State
) then
26574 ("refinement clause cannot cover multiple states", Extra_State
);
26577 -- Replicate the Part_Of constituents of the refined state because
26578 -- the algorithm will consume items.
26580 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
26582 -- Analyze all constituents of the refinement. Multiple constituents
26583 -- appear as an aggregate.
26585 Constit
:= Expression
(Clause
);
26587 if Nkind
(Constit
) = N_Aggregate
then
26588 if Present
(Component_Associations
(Constit
)) then
26590 ("constituents of refinement clause must appear in "
26591 & "positional form", Constit
);
26593 else pragma Assert
(Present
(Expressions
(Constit
)));
26594 Constit
:= First
(Expressions
(Constit
));
26595 while Present
(Constit
) loop
26596 Analyze_Constituent
(Constit
);
26601 -- Various forms of a single constituent. Note that these may include
26602 -- malformed constituents.
26605 Analyze_Constituent
(Constit
);
26608 -- Verify that external constituents do not introduce new external
26609 -- property in the state refinement (SPARK RM 7.2.8(2)).
26611 if Is_External_State
(State_Id
) then
26612 Check_External_Property
26613 (Prop_Nam
=> Name_Async_Readers
,
26614 Enabled
=> Async_Readers_Enabled
(State_Id
),
26615 Constit
=> AR_Constit
);
26617 Check_External_Property
26618 (Prop_Nam
=> Name_Async_Writers
,
26619 Enabled
=> Async_Writers_Enabled
(State_Id
),
26620 Constit
=> AW_Constit
);
26622 Check_External_Property
26623 (Prop_Nam
=> Name_Effective_Reads
,
26624 Enabled
=> Effective_Reads_Enabled
(State_Id
),
26625 Constit
=> ER_Constit
);
26627 Check_External_Property
26628 (Prop_Nam
=> Name_Effective_Writes
,
26629 Enabled
=> Effective_Writes_Enabled
(State_Id
),
26630 Constit
=> EW_Constit
);
26632 -- When a refined state is not external, it should not have external
26633 -- constituents (SPARK RM 7.2.8(1)).
26635 elsif External_Constit_Seen
then
26637 ("non-external state & cannot contain external constituents in "
26638 & "refinement", State
, State_Id
);
26641 -- Ensure that all Part_Of candidate constituents have been mentioned
26642 -- in the refinement clause.
26644 Report_Unused_Constituents
(Part_Of_Constits
);
26645 end Analyze_Refinement_Clause
;
26647 -----------------------------
26648 -- Report_Unrefined_States --
26649 -----------------------------
26651 procedure Report_Unrefined_States
(States
: Elist_Id
) is
26652 State_Elmt
: Elmt_Id
;
26655 if Present
(States
) then
26656 State_Elmt
:= First_Elmt
(States
);
26657 while Present
(State_Elmt
) loop
26659 ("abstract state & must be refined", Node
(State_Elmt
));
26661 Next_Elmt
(State_Elmt
);
26664 end Report_Unrefined_States
;
26666 -- Local declarations
26668 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
26671 -- Start of processing for Analyze_Refined_State_In_Decl_Part
26674 -- Do not analyze the pragma multiple times
26676 if Is_Analyzed_Pragma
(N
) then
26680 -- Replicate the abstract states declared by the package because the
26681 -- matching algorithm will consume states.
26683 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
26685 -- Gather all abstract states and objects declared in the visible
26686 -- state space of the package body. These items must be utilized as
26687 -- constituents in a state refinement.
26689 Body_States
:= Collect_Body_States
(Body_Id
);
26691 -- Multiple non-null state refinements appear as an aggregate
26693 if Nkind
(Clauses
) = N_Aggregate
then
26694 if Present
(Expressions
(Clauses
)) then
26696 ("state refinements must appear as component associations",
26699 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
26700 Clause
:= First
(Component_Associations
(Clauses
));
26701 while Present
(Clause
) loop
26702 Analyze_Refinement_Clause
(Clause
);
26707 -- Various forms of a single state refinement. Note that these may
26708 -- include malformed refinements.
26711 Analyze_Refinement_Clause
(Clauses
);
26714 -- List all abstract states that were left unrefined
26716 Report_Unrefined_States
(Available_States
);
26718 Set_Is_Analyzed_Pragma
(N
);
26719 end Analyze_Refined_State_In_Decl_Part
;
26721 ------------------------------------
26722 -- Analyze_Test_Case_In_Decl_Part --
26723 ------------------------------------
26725 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
26726 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26727 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
26729 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
26730 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
26731 -- denoted by Arg_Nam.
26733 ------------------------------
26734 -- Preanalyze_Test_Case_Arg --
26735 ------------------------------
26737 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
26741 -- Preanalyze the original aspect argument for ASIS or for a generic
26742 -- subprogram to properly capture global references.
26744 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
26748 Arg_Nam
=> Arg_Nam
,
26749 From_Aspect
=> True);
26751 if Present
(Arg
) then
26752 Preanalyze_Assert_Expression
26753 (Expression
(Arg
), Standard_Boolean
);
26757 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
26759 if Present
(Arg
) then
26760 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
26762 end Preanalyze_Test_Case_Arg
;
26766 Restore_Scope
: Boolean := False;
26768 -- Start of processing for Analyze_Test_Case_In_Decl_Part
26771 -- Do not analyze the pragma multiple times
26773 if Is_Analyzed_Pragma
(N
) then
26777 -- Ensure that the formal parameters are visible when analyzing all
26778 -- clauses. This falls out of the general rule of aspects pertaining
26779 -- to subprogram declarations.
26781 if not In_Open_Scopes
(Spec_Id
) then
26782 Restore_Scope
:= True;
26783 Push_Scope
(Spec_Id
);
26785 if Is_Generic_Subprogram
(Spec_Id
) then
26786 Install_Generic_Formals
(Spec_Id
);
26788 Install_Formals
(Spec_Id
);
26792 Preanalyze_Test_Case_Arg
(Name_Requires
);
26793 Preanalyze_Test_Case_Arg
(Name_Ensures
);
26795 if Restore_Scope
then
26799 -- Currently it is not possible to inline pre/postconditions on a
26800 -- subprogram subject to pragma Inline_Always.
26802 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
26804 Set_Is_Analyzed_Pragma
(N
);
26805 end Analyze_Test_Case_In_Decl_Part
;
26811 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
26816 if Present
(List
) then
26817 Elmt
:= First_Elmt
(List
);
26818 while Present
(Elmt
) loop
26819 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
26822 Id
:= Entity_Of
(Node
(Elmt
));
26825 if Id
= Item_Id
then
26836 -----------------------------------
26837 -- Build_Pragma_Check_Equivalent --
26838 -----------------------------------
26840 function Build_Pragma_Check_Equivalent
26842 Subp_Id
: Entity_Id
:= Empty
;
26843 Inher_Id
: Entity_Id
:= Empty
;
26844 Keep_Pragma_Id
: Boolean := False) return Node_Id
26846 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
26847 -- Detect whether node N references a formal parameter subject to
26848 -- pragma Unreferenced. If this is the case, set Comes_From_Source
26849 -- to False to suppress the generation of a reference when analyzing
26852 ------------------------
26853 -- Suppress_Reference --
26854 ------------------------
26856 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
26857 Formal
: Entity_Id
;
26860 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
26861 Formal
:= Entity
(N
);
26863 -- The formal parameter is subject to pragma Unreferenced. Prevent
26864 -- the generation of references by resetting the Comes_From_Source
26867 if Is_Formal
(Formal
)
26868 and then Has_Pragma_Unreferenced
(Formal
)
26870 Set_Comes_From_Source
(N
, False);
26875 end Suppress_Reference
;
26877 procedure Suppress_References
is
26878 new Traverse_Proc
(Suppress_Reference
);
26882 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
26883 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
26884 Check_Prag
: Node_Id
;
26888 -- Start of processing for Build_Pragma_Check_Equivalent
26891 -- When the pre- or postcondition is inherited, map the formals of the
26892 -- inherited subprogram to those of the current subprogram. In addition,
26893 -- map primitive operations of the parent type into the corresponding
26894 -- primitive operations of the descendant.
26896 if Present
(Inher_Id
) then
26897 pragma Assert
(Present
(Subp_Id
));
26899 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
26901 -- Use generic machinery to copy inherited pragma, as if it were an
26902 -- instantiation, resetting source locations appropriately, so that
26903 -- expressions inside the inherited pragma use chained locations.
26904 -- This is used in particular in GNATprove to locate precisely
26905 -- messages on a given inherited pragma.
26907 Set_Copied_Sloc_For_Inherited_Pragma
26908 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
26909 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
26911 -- Build the inherited class-wide condition
26913 Build_Class_Wide_Expression
26914 (Check_Prag
, Subp_Id
, Inher_Id
, Adjust_Sloc
=> True);
26916 -- If not an inherited condition simply copy the original pragma
26919 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
26922 -- Mark the pragma as being internally generated and reset the Analyzed
26925 Set_Analyzed
(Check_Prag
, False);
26926 Set_Comes_From_Source
(Check_Prag
, False);
26928 -- The tree of the original pragma may contain references to the
26929 -- formal parameters of the related subprogram. At the same time
26930 -- the corresponding body may mark the formals as unreferenced:
26932 -- procedure Proc (Formal : ...)
26933 -- with Pre => Formal ...;
26935 -- procedure Proc (Formal : ...) is
26936 -- pragma Unreferenced (Formal);
26939 -- This creates problems because all pragma Check equivalents are
26940 -- analyzed at the end of the body declarations. Since all source
26941 -- references have already been accounted for, reset any references
26942 -- to such formals in the generated pragma Check equivalent.
26944 Suppress_References
(Check_Prag
);
26946 if Present
(Corresponding_Aspect
(Prag
)) then
26947 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
26952 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
26953 -- the copied pragma in the newly created pragma, convert the copy into
26954 -- pragma Check by correcting the name and adding a check_kind argument.
26956 if not Keep_Pragma_Id
then
26957 Set_Class_Present
(Check_Prag
, False);
26959 Set_Pragma_Identifier
26960 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
26962 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
26963 Make_Pragma_Argument_Association
(Loc
,
26964 Expression
=> Make_Identifier
(Loc
, Nam
)));
26967 -- Update the error message when the pragma is inherited
26969 if Present
(Inher_Id
) then
26970 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
26972 if Chars
(Msg_Arg
) = Name_Message
then
26973 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
26975 -- Insert "inherited" to improve the error message
26977 if Name_Buffer
(1 .. 8) = "failed p" then
26978 Insert_Str_In_Name_Buffer
("inherited ", 8);
26979 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
26985 end Build_Pragma_Check_Equivalent
;
26987 -----------------------------
26988 -- Check_Applicable_Policy --
26989 -----------------------------
26991 procedure Check_Applicable_Policy
(N
: Node_Id
) is
26995 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
26998 -- No effect if not valid assertion kind name
27000 if not Is_Valid_Assertion_Kind
(Ename
) then
27004 -- Loop through entries in check policy list
27006 PP
:= Opt
.Check_Policy_List
;
27007 while Present
(PP
) loop
27009 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27010 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27014 or else Pnm
= Name_Assertion
27015 or else (Pnm
= Name_Statement_Assertions
27016 and then Nam_In
(Ename
, Name_Assert
,
27017 Name_Assert_And_Cut
,
27019 Name_Loop_Invariant
,
27020 Name_Loop_Variant
))
27022 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
27028 Set_Is_Ignored
(N
, True);
27029 Set_Is_Checked
(N
, False);
27034 Set_Is_Checked
(N
, True);
27035 Set_Is_Ignored
(N
, False);
27037 when Name_Disable
=>
27038 Set_Is_Ignored
(N
, True);
27039 Set_Is_Checked
(N
, False);
27040 Set_Is_Disabled
(N
, True);
27042 -- That should be exhaustive, the null here is a defence
27043 -- against a malformed tree from previous errors.
27052 PP
:= Next_Pragma
(PP
);
27056 -- If there are no specific entries that matched, then we let the
27057 -- setting of assertions govern. Note that this provides the needed
27058 -- compatibility with the RM for the cases of assertion, invariant,
27059 -- precondition, predicate, and postcondition.
27061 if Assertions_Enabled
then
27062 Set_Is_Checked
(N
, True);
27063 Set_Is_Ignored
(N
, False);
27065 Set_Is_Checked
(N
, False);
27066 Set_Is_Ignored
(N
, True);
27068 end Check_Applicable_Policy
;
27070 -------------------------------
27071 -- Check_External_Properties --
27072 -------------------------------
27074 procedure Check_External_Properties
27082 -- All properties enabled
27084 if AR
and AW
and ER
and EW
then
27087 -- Async_Readers + Effective_Writes
27088 -- Async_Readers + Async_Writers + Effective_Writes
27090 elsif AR
and EW
and not ER
then
27093 -- Async_Writers + Effective_Reads
27094 -- Async_Readers + Async_Writers + Effective_Reads
27096 elsif AW
and ER
and not EW
then
27099 -- Async_Readers + Async_Writers
27101 elsif AR
and AW
and not ER
and not EW
then
27106 elsif AR
and not AW
and not ER
and not EW
then
27111 elsif AW
and not AR
and not ER
and not EW
then
27116 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27119 end Check_External_Properties
;
27125 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
27129 -- Loop through entries in check policy list
27131 PP
:= Opt
.Check_Policy_List
;
27132 while Present
(PP
) loop
27134 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27135 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27139 or else (Pnm
= Name_Assertion
27140 and then Is_Valid_Assertion_Kind
(Nam
))
27141 or else (Pnm
= Name_Statement_Assertions
27142 and then Nam_In
(Nam
, Name_Assert
,
27143 Name_Assert_And_Cut
,
27145 Name_Loop_Invariant
,
27146 Name_Loop_Variant
))
27148 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
27157 return Name_Ignore
;
27159 when Name_Disable
=>
27160 return Name_Disable
;
27163 raise Program_Error
;
27167 PP
:= Next_Pragma
(PP
);
27172 -- If there are no specific entries that matched, then we let the
27173 -- setting of assertions govern. Note that this provides the needed
27174 -- compatibility with the RM for the cases of assertion, invariant,
27175 -- precondition, predicate, and postcondition.
27177 if Assertions_Enabled
then
27180 return Name_Ignore
;
27184 ---------------------------
27185 -- Check_Missing_Part_Of --
27186 ---------------------------
27188 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
27189 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
27190 -- Determine whether a package denoted by Pack_Id declares at least one
27193 -----------------------
27194 -- Has_Visible_State --
27195 -----------------------
27197 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
27198 Item_Id
: Entity_Id
;
27201 -- Traverse the entity chain of the package trying to find at least
27202 -- one visible abstract state, variable or a package [instantiation]
27203 -- that declares a visible state.
27205 Item_Id
:= First_Entity
(Pack_Id
);
27206 while Present
(Item_Id
)
27207 and then not In_Private_Part
(Item_Id
)
27209 -- Do not consider internally generated items
27211 if not Comes_From_Source
(Item_Id
) then
27214 -- A visible state has been found
27216 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
27219 -- Recursively peek into nested packages and instantiations
27221 elsif Ekind
(Item_Id
) = E_Package
27222 and then Has_Visible_State
(Item_Id
)
27227 Next_Entity
(Item_Id
);
27231 end Has_Visible_State
;
27235 Pack_Id
: Entity_Id
;
27236 Placement
: State_Space_Kind
;
27238 -- Start of processing for Check_Missing_Part_Of
27241 -- Do not consider abstract states, variables or package instantiations
27242 -- coming from an instance as those always inherit the Part_Of indicator
27243 -- of the instance itself.
27245 if In_Instance
then
27248 -- Do not consider internally generated entities as these can never
27249 -- have a Part_Of indicator.
27251 elsif not Comes_From_Source
(Item_Id
) then
27254 -- Perform these checks only when SPARK_Mode is enabled as they will
27255 -- interfere with standard Ada rules and produce false positives.
27257 elsif SPARK_Mode
/= On
then
27260 -- Do not consider constants, because the compiler cannot accurately
27261 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27262 -- act as a hidden state of a package.
27264 elsif Ekind
(Item_Id
) = E_Constant
then
27268 -- Find where the abstract state, variable or package instantiation
27269 -- lives with respect to the state space.
27271 Find_Placement_In_State_Space
27272 (Item_Id
=> Item_Id
,
27273 Placement
=> Placement
,
27274 Pack_Id
=> Pack_Id
);
27276 -- Items that appear in a non-package construct (subprogram, block, etc)
27277 -- do not require a Part_Of indicator because they can never act as a
27280 if Placement
= Not_In_Package
then
27283 -- An item declared in the body state space of a package always act as a
27284 -- constituent and does not need explicit Part_Of indicator.
27286 elsif Placement
= Body_State_Space
then
27289 -- In general an item declared in the visible state space of a package
27290 -- does not require a Part_Of indicator. The only exception is when the
27291 -- related package is a private child unit in which case Part_Of must
27292 -- denote a state in the parent unit or in one of its descendants.
27294 elsif Placement
= Visible_State_Space
then
27295 if Is_Child_Unit
(Pack_Id
)
27296 and then Is_Private_Descendant
(Pack_Id
)
27298 -- A package instantiation does not need a Part_Of indicator when
27299 -- the related generic template has no visible state.
27301 if Ekind
(Item_Id
) = E_Package
27302 and then Is_Generic_Instance
(Item_Id
)
27303 and then not Has_Visible_State
(Item_Id
)
27307 -- All other cases require Part_Of
27311 ("indicator Part_Of is required in this context "
27312 & "(SPARK RM 7.2.6(3))", Item_Id
);
27313 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27315 ("\& is declared in the visible part of private child "
27316 & "unit %", Item_Id
);
27320 -- When the item appears in the private state space of a packge, it must
27321 -- be a part of some state declared by the said package.
27323 else pragma Assert
(Placement
= Private_State_Space
);
27325 -- The related package does not declare a state, the item cannot act
27326 -- as a Part_Of constituent.
27328 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
27331 -- A package instantiation does not need a Part_Of indicator when the
27332 -- related generic template has no visible state.
27334 elsif Ekind
(Pack_Id
) = E_Package
27335 and then Is_Generic_Instance
(Pack_Id
)
27336 and then not Has_Visible_State
(Pack_Id
)
27340 -- All other cases require Part_Of
27344 ("indicator Part_Of is required in this context "
27345 & "(SPARK RM 7.2.6(2))", Item_Id
);
27346 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27348 ("\& is declared in the private part of package %", Item_Id
);
27351 end Check_Missing_Part_Of
;
27353 ---------------------------------------------------
27354 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27355 ---------------------------------------------------
27357 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27359 Spec_Id
: Entity_Id
)
27362 if Warn_On_Redundant_Constructs
27363 and then Has_Pragma_Inline_Always
(Spec_Id
)
27365 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27367 if From_Aspect_Specification
(Prag
) then
27369 ("aspect % not enforced on inlined subprogram &?r?",
27370 Corresponding_Aspect
(Prag
), Spec_Id
);
27373 ("pragma % not enforced on inlined subprogram &?r?",
27377 end Check_Postcondition_Use_In_Inlined_Subprogram
;
27379 -------------------------------------
27380 -- Check_State_And_Constituent_Use --
27381 -------------------------------------
27383 procedure Check_State_And_Constituent_Use
27384 (States
: Elist_Id
;
27385 Constits
: Elist_Id
;
27388 Constit_Elmt
: Elmt_Id
;
27389 Constit_Id
: Entity_Id
;
27390 State_Id
: Entity_Id
;
27393 -- Nothing to do if there are no states or constituents
27395 if No
(States
) or else No
(Constits
) then
27399 -- Inspect the list of constituents and try to determine whether its
27400 -- encapsulating state is in list States.
27402 Constit_Elmt
:= First_Elmt
(Constits
);
27403 while Present
(Constit_Elmt
) loop
27404 Constit_Id
:= Node
(Constit_Elmt
);
27406 -- Determine whether the constituent is part of an encapsulating
27407 -- state that appears in the same context and if this is the case,
27408 -- emit an error (SPARK RM 7.2.6(7)).
27410 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
27412 if Present
(State_Id
) then
27413 Error_Msg_Name_1
:= Chars
(Constit_Id
);
27415 ("cannot mention state & and its constituent % in the same "
27416 & "context", Context
, State_Id
);
27420 Next_Elmt
(Constit_Elmt
);
27422 end Check_State_And_Constituent_Use
;
27424 ---------------------------------------------
27425 -- Collect_Inherited_Class_Wide_Conditions --
27426 ---------------------------------------------
27428 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
27429 Parent_Subp
: constant Entity_Id
:= Overridden_Operation
(Subp
);
27430 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
27431 In_Spec_Expr
: Boolean;
27432 Installed
: Boolean;
27434 New_Prag
: Node_Id
;
27437 Installed
:= False;
27439 -- Iterate over the contract of the overridden subprogram to find all
27440 -- inherited class-wide pre- and postconditions.
27442 if Present
(Prags
) then
27443 Prag
:= Pre_Post_Conditions
(Prags
);
27445 while Present
(Prag
) loop
27446 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
27447 Name_Precondition
, Name_Postcondition
)
27448 and then Class_Present
(Prag
)
27450 -- The generated pragma must be analyzed in the context of
27451 -- the subprogram, to make its formals visible. In addition,
27452 -- we must inhibit freezing and full analysis because the
27453 -- controlling type of the subprogram is not frozen yet, and
27454 -- may have further primitives.
27456 if not Installed
then
27459 Install_Formals
(Subp
);
27460 In_Spec_Expr
:= In_Spec_Expression
;
27461 In_Spec_Expression
:= True;
27465 Build_Pragma_Check_Equivalent
27466 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
27468 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
27469 Preanalyze
(New_Prag
);
27471 -- Prevent further analysis in subsequent processing of the
27472 -- current list of declarations
27474 Set_Analyzed
(New_Prag
);
27477 Prag
:= Next_Pragma
(Prag
);
27481 In_Spec_Expression
:= In_Spec_Expr
;
27485 end Collect_Inherited_Class_Wide_Conditions
;
27487 ---------------------------------------
27488 -- Collect_Subprogram_Inputs_Outputs --
27489 ---------------------------------------
27491 procedure Collect_Subprogram_Inputs_Outputs
27492 (Subp_Id
: Entity_Id
;
27493 Synthesize
: Boolean := False;
27494 Subp_Inputs
: in out Elist_Id
;
27495 Subp_Outputs
: in out Elist_Id
;
27496 Global_Seen
: out Boolean)
27498 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
27499 -- Collect all relevant items from a dependency clause
27501 procedure Collect_Global_List
27503 Mode
: Name_Id
:= Name_Input
);
27504 -- Collect all relevant items from a global list
27506 -------------------------------
27507 -- Collect_Dependency_Clause --
27508 -------------------------------
27510 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
27511 procedure Collect_Dependency_Item
27513 Is_Input
: Boolean);
27514 -- Add an item to the proper subprogram input or output collection
27516 -----------------------------
27517 -- Collect_Dependency_Item --
27518 -----------------------------
27520 procedure Collect_Dependency_Item
27522 Is_Input
: Boolean)
27527 -- Nothing to collect when the item is null
27529 if Nkind
(Item
) = N_Null
then
27532 -- Ditto for attribute 'Result
27534 elsif Is_Attribute_Result
(Item
) then
27537 -- Multiple items appear as an aggregate
27539 elsif Nkind
(Item
) = N_Aggregate
then
27540 Extra
:= First
(Expressions
(Item
));
27541 while Present
(Extra
) loop
27542 Collect_Dependency_Item
(Extra
, Is_Input
);
27546 -- Otherwise this is a solitary item
27550 Append_New_Elmt
(Item
, Subp_Inputs
);
27552 Append_New_Elmt
(Item
, Subp_Outputs
);
27555 end Collect_Dependency_Item
;
27557 -- Start of processing for Collect_Dependency_Clause
27560 if Nkind
(Clause
) = N_Null
then
27563 -- A dependency cause appears as component association
27565 elsif Nkind
(Clause
) = N_Component_Association
then
27566 Collect_Dependency_Item
27567 (Item
=> Expression
(Clause
),
27570 Collect_Dependency_Item
27571 (Item
=> First
(Choices
(Clause
)),
27572 Is_Input
=> False);
27574 -- To accomodate partial decoration of disabled SPARK features, this
27575 -- routine may be called with illegal input. If this is the case, do
27576 -- not raise Program_Error.
27581 end Collect_Dependency_Clause
;
27583 -------------------------
27584 -- Collect_Global_List --
27585 -------------------------
27587 procedure Collect_Global_List
27589 Mode
: Name_Id
:= Name_Input
)
27591 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
27592 -- Add an item to the proper subprogram input or output collection
27594 -------------------------
27595 -- Collect_Global_Item --
27596 -------------------------
27598 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
27600 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
27601 Append_New_Elmt
(Item
, Subp_Inputs
);
27604 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
27605 Append_New_Elmt
(Item
, Subp_Outputs
);
27607 end Collect_Global_Item
;
27614 -- Start of processing for Collect_Global_List
27617 if Nkind
(List
) = N_Null
then
27620 -- Single global item declaration
27622 elsif Nkind_In
(List
, N_Expanded_Name
,
27624 N_Selected_Component
)
27626 Collect_Global_Item
(List
, Mode
);
27628 -- Simple global list or moded global list declaration
27630 elsif Nkind
(List
) = N_Aggregate
then
27631 if Present
(Expressions
(List
)) then
27632 Item
:= First
(Expressions
(List
));
27633 while Present
(Item
) loop
27634 Collect_Global_Item
(Item
, Mode
);
27639 Assoc
:= First
(Component_Associations
(List
));
27640 while Present
(Assoc
) loop
27641 Collect_Global_List
27642 (List
=> Expression
(Assoc
),
27643 Mode
=> Chars
(First
(Choices
(Assoc
))));
27648 -- To accomodate partial decoration of disabled SPARK features, this
27649 -- routine may be called with illegal input. If this is the case, do
27650 -- not raise Program_Error.
27655 end Collect_Global_List
;
27662 Formal
: Entity_Id
;
27664 Spec_Id
: Entity_Id
;
27665 Subp_Decl
: Node_Id
;
27668 -- Start of processing for Collect_Subprogram_Inputs_Outputs
27671 Global_Seen
:= False;
27673 -- Process all formal parameters of entries, [generic] subprograms, and
27676 if Ekind_In
(Subp_Id
, E_Entry
,
27679 E_Generic_Function
,
27680 E_Generic_Procedure
,
27684 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
27685 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27687 -- Process all [generic] formal parameters
27689 Formal
:= First_Entity
(Spec_Id
);
27690 while Present
(Formal
) loop
27691 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
27692 E_In_Out_Parameter
,
27695 Append_New_Elmt
(Formal
, Subp_Inputs
);
27698 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
27699 E_In_Out_Parameter
,
27702 Append_New_Elmt
(Formal
, Subp_Outputs
);
27704 -- Out parameters can act as inputs when the related type is
27705 -- tagged, unconstrained array, unconstrained record, or record
27706 -- with unconstrained components.
27708 if Ekind
(Formal
) = E_Out_Parameter
27709 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
27711 Append_New_Elmt
(Formal
, Subp_Inputs
);
27715 Next_Entity
(Formal
);
27718 -- Otherwise the input denotes a task type, a task body, or the
27719 -- anonymous object created for a single task type.
27721 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
27722 or else Is_Single_Task_Object
(Subp_Id
)
27724 Subp_Decl
:= Declaration_Node
(Subp_Id
);
27725 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27728 -- When processing an entry, subprogram or task body, look for pragmas
27729 -- Refined_Depends and Refined_Global as they specify the inputs and
27732 if Is_Entry_Body
(Subp_Id
)
27733 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
27735 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
27736 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
27738 -- Subprogram declaration or stand alone body case, look for pragmas
27739 -- Depends and Global
27742 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
27743 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
27746 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
27747 -- because it provides finer granularity of inputs and outputs.
27749 if Present
(Global
) then
27750 Global_Seen
:= True;
27751 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
27753 -- When the related subprogram lacks pragma [Refined_]Global, fall back
27754 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
27755 -- the inputs and outputs from [Refined_]Depends.
27757 elsif Synthesize
and then Present
(Depends
) then
27758 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
27760 -- Multiple dependency clauses appear as an aggregate
27762 if Nkind
(Clauses
) = N_Aggregate
then
27763 Clause
:= First
(Component_Associations
(Clauses
));
27764 while Present
(Clause
) loop
27765 Collect_Dependency_Clause
(Clause
);
27769 -- Otherwise this is a single dependency clause
27772 Collect_Dependency_Clause
(Clauses
);
27776 -- The current instance of a protected type acts as a formal parameter
27777 -- of mode IN for functions and IN OUT for entries and procedures
27778 -- (SPARK RM 6.1.4).
27780 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
27781 Typ
:= Scope
(Spec_Id
);
27783 -- Use the anonymous object when the type is single protected
27785 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27786 Typ
:= Anonymous_Object
(Typ
);
27789 Append_New_Elmt
(Typ
, Subp_Inputs
);
27791 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
27792 Append_New_Elmt
(Typ
, Subp_Outputs
);
27795 -- The current instance of a task type acts as a formal parameter of
27796 -- mode IN OUT (SPARK RM 6.1.4).
27798 elsif Ekind
(Spec_Id
) = E_Task_Type
then
27801 -- Use the anonymous object when the type is single task
27803 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
27804 Typ
:= Anonymous_Object
(Typ
);
27807 Append_New_Elmt
(Typ
, Subp_Inputs
);
27808 Append_New_Elmt
(Typ
, Subp_Outputs
);
27810 elsif Is_Single_Task_Object
(Spec_Id
) then
27811 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
27812 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
27814 end Collect_Subprogram_Inputs_Outputs
;
27816 ---------------------------
27817 -- Contract_Freeze_Error --
27818 ---------------------------
27820 procedure Contract_Freeze_Error
27821 (Contract_Id
: Entity_Id
;
27822 Freeze_Id
: Entity_Id
)
27825 Error_Msg_Name_1
:= Chars
(Contract_Id
);
27826 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
27829 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
27831 ("\all contractual items must be declared before body #", Contract_Id
);
27832 end Contract_Freeze_Error
;
27834 ---------------------------------
27835 -- Delay_Config_Pragma_Analyze --
27836 ---------------------------------
27838 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
27840 return Nam_In
(Pragma_Name_Unmapped
(N
),
27841 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
27842 end Delay_Config_Pragma_Analyze
;
27844 -----------------------
27845 -- Duplication_Error --
27846 -----------------------
27848 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
27849 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
27850 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
27853 Error_Msg_Sloc
:= Sloc
(Prev
);
27854 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27856 -- Emit a precise message to distinguish between source pragmas and
27857 -- pragmas generated from aspects. The ordering of the two pragmas is
27861 -- Prag -- duplicate
27863 -- No error is emitted when both pragmas come from aspects because this
27864 -- is already detected by the general aspect analysis mechanism.
27866 if Prag_From_Asp
and Prev_From_Asp
then
27868 elsif Prag_From_Asp
then
27869 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
27870 elsif Prev_From_Asp
then
27871 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
27873 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
27875 end Duplication_Error
;
27877 ------------------------------
27878 -- Find_Encapsulating_State --
27879 ------------------------------
27881 function Find_Encapsulating_State
27882 (States
: Elist_Id
;
27883 Constit_Id
: Entity_Id
) return Entity_Id
27885 State_Id
: Entity_Id
;
27888 -- Since a constituent may be part of a larger constituent set, climb
27889 -- the encapsulating state chain looking for a state that appears in
27892 State_Id
:= Encapsulating_State
(Constit_Id
);
27893 while Present
(State_Id
) loop
27894 if Contains
(States
, State_Id
) then
27898 State_Id
:= Encapsulating_State
(State_Id
);
27902 end Find_Encapsulating_State
;
27904 --------------------------
27905 -- Find_Related_Context --
27906 --------------------------
27908 function Find_Related_Context
27910 Do_Checks
: Boolean := False) return Node_Id
27915 Stmt
:= Prev
(Prag
);
27916 while Present
(Stmt
) loop
27918 -- Skip prior pragmas, but check for duplicates
27920 if Nkind
(Stmt
) = N_Pragma
then
27922 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
27929 -- Skip internally generated code
27931 elsif not Comes_From_Source
(Stmt
) then
27933 -- The anonymous object created for a single concurrent type is a
27934 -- suitable context.
27936 if Nkind
(Stmt
) = N_Object_Declaration
27937 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
27942 -- Return the current source construct
27952 end Find_Related_Context
;
27954 --------------------------------------
27955 -- Find_Related_Declaration_Or_Body --
27956 --------------------------------------
27958 function Find_Related_Declaration_Or_Body
27960 Do_Checks
: Boolean := False) return Node_Id
27962 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
27964 procedure Expression_Function_Error
;
27965 -- Emit an error concerning pragma Prag that illegaly applies to an
27966 -- expression function.
27968 -------------------------------
27969 -- Expression_Function_Error --
27970 -------------------------------
27972 procedure Expression_Function_Error
is
27974 Error_Msg_Name_1
:= Prag_Nam
;
27976 -- Emit a precise message to distinguish between source pragmas and
27977 -- pragmas generated from aspects.
27979 if From_Aspect_Specification
(Prag
) then
27981 ("aspect % cannot apply to a stand alone expression function",
27985 ("pragma % cannot apply to a stand alone expression function",
27988 end Expression_Function_Error
;
27992 Context
: constant Node_Id
:= Parent
(Prag
);
27995 Look_For_Body
: constant Boolean :=
27996 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
27997 Name_Refined_Global
,
27998 Name_Refined_Post
);
27999 -- Refinement pragmas must be associated with a subprogram body [stub]
28001 -- Start of processing for Find_Related_Declaration_Or_Body
28004 Stmt
:= Prev
(Prag
);
28005 while Present
(Stmt
) loop
28007 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28008 -- by splitting a complex pre/postcondition are not considered to
28011 if Nkind
(Stmt
) = N_Pragma
then
28013 and then not Split_PPC
(Stmt
)
28014 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
28021 -- Emit an error when a refinement pragma appears on an expression
28022 -- function without a completion.
28025 and then Look_For_Body
28026 and then Nkind
(Stmt
) = N_Subprogram_Declaration
28027 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
28028 and then not Has_Completion
(Defining_Entity
(Stmt
))
28030 Expression_Function_Error
;
28033 -- The refinement pragma applies to a subprogram body stub
28035 elsif Look_For_Body
28036 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
28040 -- Skip internally generated code
28042 elsif not Comes_From_Source
(Stmt
) then
28044 -- The anonymous object created for a single concurrent type is a
28045 -- suitable context.
28047 if Nkind
(Stmt
) = N_Object_Declaration
28048 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28052 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
28054 -- The subprogram declaration is an internally generated spec
28055 -- for an expression function.
28057 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28060 -- The subprogram is actually an instance housed within an
28061 -- anonymous wrapper package.
28063 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28068 -- Return the current construct which is either a subprogram body,
28069 -- a subprogram declaration or is illegal.
28078 -- If we fall through, then the pragma was either the first declaration
28079 -- or it was preceded by other pragmas and no source constructs.
28081 -- The pragma is associated with a library-level subprogram
28083 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
28084 return Unit
(Parent
(Context
));
28086 -- The pragma appears inside the declarations of an entry body
28088 elsif Nkind
(Context
) = N_Entry_Body
then
28091 -- The pragma appears inside the statements of a subprogram body. This
28092 -- placement is the result of subprogram contract expansion.
28094 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
28095 return Parent
(Context
);
28097 -- The pragma appears inside the declarative part of a subprogram body
28099 elsif Nkind
(Context
) = N_Subprogram_Body
then
28102 -- The pragma appears inside the declarative part of a task body
28104 elsif Nkind
(Context
) = N_Task_Body
then
28107 -- The pragma is a byproduct of aspect expansion, return the related
28108 -- context of the original aspect. This case has a lower priority as
28109 -- the above circuitry pinpoints precisely the related context.
28111 elsif Present
(Corresponding_Aspect
(Prag
)) then
28112 return Parent
(Corresponding_Aspect
(Prag
));
28114 -- No candidate subprogram [body] found
28119 end Find_Related_Declaration_Or_Body
;
28121 ----------------------------------
28122 -- Find_Related_Package_Or_Body --
28123 ----------------------------------
28125 function Find_Related_Package_Or_Body
28127 Do_Checks
: Boolean := False) return Node_Id
28129 Context
: constant Node_Id
:= Parent
(Prag
);
28130 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28134 Stmt
:= Prev
(Prag
);
28135 while Present
(Stmt
) loop
28137 -- Skip prior pragmas, but check for duplicates
28139 if Nkind
(Stmt
) = N_Pragma
then
28140 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
28146 -- Skip internally generated code
28148 elsif not Comes_From_Source
(Stmt
) then
28149 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
28151 -- The subprogram declaration is an internally generated spec
28152 -- for an expression function.
28154 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28157 -- The subprogram is actually an instance housed within an
28158 -- anonymous wrapper package.
28160 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28165 -- Return the current source construct which is illegal
28174 -- If we fall through, then the pragma was either the first declaration
28175 -- or it was preceded by other pragmas and no source constructs.
28177 -- The pragma is associated with a package. The immediate context in
28178 -- this case is the specification of the package.
28180 if Nkind
(Context
) = N_Package_Specification
then
28181 return Parent
(Context
);
28183 -- The pragma appears in the declarations of a package body
28185 elsif Nkind
(Context
) = N_Package_Body
then
28188 -- The pragma appears in the statements of a package body
28190 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
28191 and then Nkind
(Parent
(Context
)) = N_Package_Body
28193 return Parent
(Context
);
28195 -- The pragma is a byproduct of aspect expansion, return the related
28196 -- context of the original aspect. This case has a lower priority as
28197 -- the above circuitry pinpoints precisely the related context.
28199 elsif Present
(Corresponding_Aspect
(Prag
)) then
28200 return Parent
(Corresponding_Aspect
(Prag
));
28202 -- No candidate packge [body] found
28207 end Find_Related_Package_Or_Body
;
28213 function Get_Argument
28215 Context_Id
: Entity_Id
:= Empty
) return Node_Id
28217 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
28220 -- Use the expression of the original aspect when compiling for ASIS or
28221 -- when analyzing the template of a generic unit. In both cases the
28222 -- aspect's tree must be decorated to allow for ASIS queries or to save
28223 -- the global references in the generic context.
28225 if From_Aspect_Specification
(Prag
)
28226 and then (ASIS_Mode
or else (Present
(Context_Id
)
28227 and then Is_Generic_Unit
(Context_Id
)))
28229 return Corresponding_Aspect
(Prag
);
28231 -- Otherwise use the expression of the pragma
28233 elsif Present
(Args
) then
28234 return First
(Args
);
28241 -------------------------
28242 -- Get_Base_Subprogram --
28243 -------------------------
28245 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
28246 Result
: Entity_Id
;
28249 -- Follow subprogram renaming chain
28253 if Is_Subprogram
(Result
)
28255 Nkind
(Parent
(Declaration_Node
(Result
))) =
28256 N_Subprogram_Renaming_Declaration
28257 and then Present
(Alias
(Result
))
28259 Result
:= Alias
(Result
);
28263 end Get_Base_Subprogram
;
28265 -----------------------
28266 -- Get_SPARK_Mode_Type --
28267 -----------------------
28269 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
28271 if N
= Name_On
then
28273 elsif N
= Name_Off
then
28276 -- Any other argument is illegal
28279 raise Program_Error
;
28281 end Get_SPARK_Mode_Type
;
28283 ------------------------------------
28284 -- Get_SPARK_Mode_From_Annotation --
28285 ------------------------------------
28287 function Get_SPARK_Mode_From_Annotation
28288 (N
: Node_Id
) return SPARK_Mode_Type
28293 if Nkind
(N
) = N_Aspect_Specification
then
28294 Mode
:= Expression
(N
);
28296 else pragma Assert
(Nkind
(N
) = N_Pragma
);
28297 Mode
:= First
(Pragma_Argument_Associations
(N
));
28299 if Present
(Mode
) then
28300 Mode
:= Get_Pragma_Arg
(Mode
);
28304 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28306 if Present
(Mode
) then
28307 if Nkind
(Mode
) = N_Identifier
then
28308 return Get_SPARK_Mode_Type
(Chars
(Mode
));
28310 -- In case of a malformed aspect or pragma, return the default None
28316 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28321 end Get_SPARK_Mode_From_Annotation
;
28323 ---------------------------
28324 -- Has_Extra_Parentheses --
28325 ---------------------------
28327 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
28331 -- The aggregate should not have an expression list because a clause
28332 -- is always interpreted as a component association. The only way an
28333 -- expression list can sneak in is by adding extra parentheses around
28334 -- the individual clauses:
28336 -- Depends (Output => Input) -- proper form
28337 -- Depends ((Output => Input)) -- extra parentheses
28339 -- Since the extra parentheses are not allowed by the syntax of the
28340 -- pragma, flag them now to avoid emitting misleading errors down the
28343 if Nkind
(Clause
) = N_Aggregate
28344 and then Present
(Expressions
(Clause
))
28346 Expr
:= First
(Expressions
(Clause
));
28347 while Present
(Expr
) loop
28349 -- A dependency clause surrounded by extra parentheses appears
28350 -- as an aggregate of component associations with an optional
28351 -- Paren_Count set.
28353 if Nkind
(Expr
) = N_Aggregate
28354 and then Present
(Component_Associations
(Expr
))
28357 ("dependency clause contains extra parentheses", Expr
);
28359 -- Otherwise the expression is a malformed construct
28362 SPARK_Msg_N
("malformed dependency clause", Expr
);
28372 end Has_Extra_Parentheses
;
28378 procedure Initialize
is
28389 Dummy
:= Dummy
+ 1;
28392 -----------------------------
28393 -- Is_Config_Static_String --
28394 -----------------------------
28396 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28398 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
28399 -- This is an internal recursive function that is just like the outer
28400 -- function except that it adds the string to the name buffer rather
28401 -- than placing the string in the name buffer.
28403 ------------------------------
28404 -- Add_Config_Static_String --
28405 ------------------------------
28407 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28414 if Nkind
(N
) = N_Op_Concat
then
28415 if Add_Config_Static_String
(Left_Opnd
(N
)) then
28416 N
:= Right_Opnd
(N
);
28422 if Nkind
(N
) /= N_String_Literal
then
28423 Error_Msg_N
("string literal expected for pragma argument", N
);
28427 for J
in 1 .. String_Length
(Strval
(N
)) loop
28428 C
:= Get_String_Char
(Strval
(N
), J
);
28430 if not In_Character_Range
(C
) then
28432 ("string literal contains invalid wide character",
28433 Sloc
(N
) + 1 + Source_Ptr
(J
));
28437 Add_Char_To_Name_Buffer
(Get_Character
(C
));
28442 end Add_Config_Static_String
;
28444 -- Start of processing for Is_Config_Static_String
28449 return Add_Config_Static_String
(Arg
);
28450 end Is_Config_Static_String
;
28452 ---------------------
28453 -- Is_CCT_Instance --
28454 ---------------------
28456 function Is_CCT_Instance
28457 (Ref_Id
: Entity_Id
;
28458 Context_Id
: Entity_Id
) return Boolean
28464 -- When the reference denotes a single protected type, the context is
28465 -- either a protected subprogram or its body.
28467 if Is_Single_Protected_Object
(Ref_Id
) then
28468 Typ
:= Scope
(Context_Id
);
28471 Ekind
(Typ
) = E_Protected_Type
28472 and then Present
(Anonymous_Object
(Typ
))
28473 and then Anonymous_Object
(Typ
) = Ref_Id
;
28475 -- When the reference denotes a single task type, the context is either
28476 -- the same type or if inside the body, the anonymous task type.
28478 elsif Is_Single_Task_Object
(Ref_Id
) then
28479 if Ekind
(Context_Id
) = E_Task_Type
then
28481 Present
(Anonymous_Object
(Context_Id
))
28482 and then Anonymous_Object
(Context_Id
) = Ref_Id
;
28484 return Ref_Id
= Context_Id
;
28487 -- Otherwise the reference denotes a protected or a task type. Climb the
28488 -- scope chain looking for an enclosing concurrent type that matches the
28489 -- referenced entity.
28492 pragma Assert
(Ekind_In
(Ref_Id
, E_Protected_Type
, E_Task_Type
));
28494 S
:= Current_Scope
;
28495 while Present
(S
) and then S
/= Standard_Standard
loop
28496 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
)
28497 and then S
= Ref_Id
28507 end Is_CCT_Instance
;
28509 -------------------------------
28510 -- Is_Elaboration_SPARK_Mode --
28511 -------------------------------
28513 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
28516 (Nkind
(N
) = N_Pragma
28517 and then Pragma_Name
(N
) = Name_SPARK_Mode
28518 and then Is_List_Member
(N
));
28520 -- Pragma SPARK_Mode affects the elaboration of a package body when it
28521 -- appears in the statement part of the body.
28524 Present
(Parent
(N
))
28525 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
28526 and then List_Containing
(N
) = Statements
(Parent
(N
))
28527 and then Present
(Parent
(Parent
(N
)))
28528 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
28529 end Is_Elaboration_SPARK_Mode
;
28531 -----------------------
28532 -- Is_Enabled_Pragma --
28533 -----------------------
28535 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
28539 if Present
(Prag
) then
28540 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
28542 if Present
(Arg
) then
28543 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
28545 -- The lack of a Boolean argument automatically enables the pragma
28551 -- The pragma is missing, therefore it is not enabled
28556 end Is_Enabled_Pragma
;
28558 -----------------------------------------
28559 -- Is_Non_Significant_Pragma_Reference --
28560 -----------------------------------------
28562 -- This function makes use of the following static table which indicates
28563 -- whether appearance of some name in a given pragma is to be considered
28564 -- as a reference for the purposes of warnings about unreferenced objects.
28566 -- -1 indicates that appearence in any argument is significant
28567 -- 0 indicates that appearance in any argument is not significant
28568 -- +n indicates that appearance as argument n is significant, but all
28569 -- other arguments are not significant
28570 -- 9n arguments from n on are significant, before n insignificant
28572 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
28573 (Pragma_Abort_Defer
=> -1,
28574 Pragma_Abstract_State
=> -1,
28575 Pragma_Ada_83
=> -1,
28576 Pragma_Ada_95
=> -1,
28577 Pragma_Ada_05
=> -1,
28578 Pragma_Ada_2005
=> -1,
28579 Pragma_Ada_12
=> -1,
28580 Pragma_Ada_2012
=> -1,
28581 Pragma_All_Calls_Remote
=> -1,
28582 Pragma_Allow_Integer_Address
=> -1,
28583 Pragma_Annotate
=> 93,
28584 Pragma_Assert
=> -1,
28585 Pragma_Assert_And_Cut
=> -1,
28586 Pragma_Assertion_Policy
=> 0,
28587 Pragma_Assume
=> -1,
28588 Pragma_Assume_No_Invalid_Values
=> 0,
28589 Pragma_Async_Readers
=> 0,
28590 Pragma_Async_Writers
=> 0,
28591 Pragma_Asynchronous
=> 0,
28592 Pragma_Atomic
=> 0,
28593 Pragma_Atomic_Components
=> 0,
28594 Pragma_Attach_Handler
=> -1,
28595 Pragma_Attribute_Definition
=> 92,
28596 Pragma_Check
=> -1,
28597 Pragma_Check_Float_Overflow
=> 0,
28598 Pragma_Check_Name
=> 0,
28599 Pragma_Check_Policy
=> 0,
28600 Pragma_CPP_Class
=> 0,
28601 Pragma_CPP_Constructor
=> 0,
28602 Pragma_CPP_Virtual
=> 0,
28603 Pragma_CPP_Vtable
=> 0,
28605 Pragma_C_Pass_By_Copy
=> 0,
28606 Pragma_Comment
=> -1,
28607 Pragma_Common_Object
=> 0,
28608 Pragma_Compile_Time_Error
=> -1,
28609 Pragma_Compile_Time_Warning
=> -1,
28610 Pragma_Compiler_Unit
=> -1,
28611 Pragma_Compiler_Unit_Warning
=> -1,
28612 Pragma_Complete_Representation
=> 0,
28613 Pragma_Complex_Representation
=> 0,
28614 Pragma_Component_Alignment
=> 0,
28615 Pragma_Constant_After_Elaboration
=> 0,
28616 Pragma_Contract_Cases
=> -1,
28617 Pragma_Controlled
=> 0,
28618 Pragma_Convention
=> 0,
28619 Pragma_Convention_Identifier
=> 0,
28620 Pragma_Debug
=> -1,
28621 Pragma_Debug_Policy
=> 0,
28622 Pragma_Detect_Blocking
=> 0,
28623 Pragma_Default_Initial_Condition
=> -1,
28624 Pragma_Default_Scalar_Storage_Order
=> 0,
28625 Pragma_Default_Storage_Pool
=> 0,
28626 Pragma_Depends
=> -1,
28627 Pragma_Disable_Atomic_Synchronization
=> 0,
28628 Pragma_Discard_Names
=> 0,
28629 Pragma_Dispatching_Domain
=> -1,
28630 Pragma_Effective_Reads
=> 0,
28631 Pragma_Effective_Writes
=> 0,
28632 Pragma_Elaborate
=> 0,
28633 Pragma_Elaborate_All
=> 0,
28634 Pragma_Elaborate_Body
=> 0,
28635 Pragma_Elaboration_Checks
=> 0,
28636 Pragma_Eliminate
=> 0,
28637 Pragma_Enable_Atomic_Synchronization
=> 0,
28638 Pragma_Export
=> -1,
28639 Pragma_Export_Function
=> -1,
28640 Pragma_Export_Object
=> -1,
28641 Pragma_Export_Procedure
=> -1,
28642 Pragma_Export_Value
=> -1,
28643 Pragma_Export_Valued_Procedure
=> -1,
28644 Pragma_Extend_System
=> -1,
28645 Pragma_Extensions_Allowed
=> 0,
28646 Pragma_Extensions_Visible
=> 0,
28647 Pragma_External
=> -1,
28648 Pragma_Favor_Top_Level
=> 0,
28649 Pragma_External_Name_Casing
=> 0,
28650 Pragma_Fast_Math
=> 0,
28651 Pragma_Finalize_Storage_Only
=> 0,
28653 Pragma_Global
=> -1,
28654 Pragma_Ident
=> -1,
28655 Pragma_Ignore_Pragma
=> 0,
28656 Pragma_Implementation_Defined
=> -1,
28657 Pragma_Implemented
=> -1,
28658 Pragma_Implicit_Packing
=> 0,
28659 Pragma_Import
=> 93,
28660 Pragma_Import_Function
=> 0,
28661 Pragma_Import_Object
=> 0,
28662 Pragma_Import_Procedure
=> 0,
28663 Pragma_Import_Valued_Procedure
=> 0,
28664 Pragma_Independent
=> 0,
28665 Pragma_Independent_Components
=> 0,
28666 Pragma_Initial_Condition
=> -1,
28667 Pragma_Initialize_Scalars
=> 0,
28668 Pragma_Initializes
=> -1,
28669 Pragma_Inline
=> 0,
28670 Pragma_Inline_Always
=> 0,
28671 Pragma_Inline_Generic
=> 0,
28672 Pragma_Inspection_Point
=> -1,
28673 Pragma_Interface
=> 92,
28674 Pragma_Interface_Name
=> 0,
28675 Pragma_Interrupt_Handler
=> -1,
28676 Pragma_Interrupt_Priority
=> -1,
28677 Pragma_Interrupt_State
=> -1,
28678 Pragma_Invariant
=> -1,
28679 Pragma_Keep_Names
=> 0,
28680 Pragma_License
=> 0,
28681 Pragma_Link_With
=> -1,
28682 Pragma_Linker_Alias
=> -1,
28683 Pragma_Linker_Constructor
=> -1,
28684 Pragma_Linker_Destructor
=> -1,
28685 Pragma_Linker_Options
=> -1,
28686 Pragma_Linker_Section
=> 0,
28688 Pragma_Lock_Free
=> 0,
28689 Pragma_Locking_Policy
=> 0,
28690 Pragma_Loop_Invariant
=> -1,
28691 Pragma_Loop_Optimize
=> 0,
28692 Pragma_Loop_Variant
=> -1,
28693 Pragma_Machine_Attribute
=> -1,
28695 Pragma_Main_Storage
=> -1,
28696 Pragma_Max_Queue_Length
=> 0,
28697 Pragma_Memory_Size
=> 0,
28698 Pragma_No_Return
=> 0,
28699 Pragma_No_Body
=> 0,
28700 Pragma_No_Elaboration_Code_All
=> 0,
28701 Pragma_No_Inline
=> 0,
28702 Pragma_No_Run_Time
=> -1,
28703 Pragma_No_Strict_Aliasing
=> -1,
28704 Pragma_No_Tagged_Streams
=> 0,
28705 Pragma_Normalize_Scalars
=> 0,
28706 Pragma_Obsolescent
=> 0,
28707 Pragma_Optimize
=> 0,
28708 Pragma_Optimize_Alignment
=> 0,
28709 Pragma_Overflow_Mode
=> 0,
28710 Pragma_Overriding_Renamings
=> 0,
28711 Pragma_Ordered
=> 0,
28714 Pragma_Part_Of
=> 0,
28715 Pragma_Partition_Elaboration_Policy
=> 0,
28716 Pragma_Passive
=> 0,
28717 Pragma_Persistent_BSS
=> 0,
28718 Pragma_Polling
=> 0,
28719 Pragma_Prefix_Exception_Messages
=> 0,
28721 Pragma_Postcondition
=> -1,
28722 Pragma_Post_Class
=> -1,
28724 Pragma_Precondition
=> -1,
28725 Pragma_Predicate
=> -1,
28726 Pragma_Predicate_Failure
=> -1,
28727 Pragma_Preelaborable_Initialization
=> -1,
28728 Pragma_Preelaborate
=> 0,
28729 Pragma_Pre_Class
=> -1,
28730 Pragma_Priority
=> -1,
28731 Pragma_Priority_Specific_Dispatching
=> 0,
28732 Pragma_Profile
=> 0,
28733 Pragma_Profile_Warnings
=> 0,
28734 Pragma_Propagate_Exceptions
=> 0,
28735 Pragma_Provide_Shift_Operators
=> 0,
28736 Pragma_Psect_Object
=> 0,
28738 Pragma_Pure_Function
=> 0,
28739 Pragma_Queuing_Policy
=> 0,
28740 Pragma_Rational
=> 0,
28741 Pragma_Ravenscar
=> 0,
28742 Pragma_Refined_Depends
=> -1,
28743 Pragma_Refined_Global
=> -1,
28744 Pragma_Refined_Post
=> -1,
28745 Pragma_Refined_State
=> -1,
28746 Pragma_Relative_Deadline
=> 0,
28747 Pragma_Rename_Pragma
=> 0,
28748 Pragma_Remote_Access_Type
=> -1,
28749 Pragma_Remote_Call_Interface
=> -1,
28750 Pragma_Remote_Types
=> -1,
28751 Pragma_Restricted_Run_Time
=> 0,
28752 Pragma_Restriction_Warnings
=> 0,
28753 Pragma_Restrictions
=> 0,
28754 Pragma_Reviewable
=> -1,
28755 Pragma_Secondary_Stack_Size
=> -1,
28756 Pragma_Short_Circuit_And_Or
=> 0,
28757 Pragma_Share_Generic
=> 0,
28758 Pragma_Shared
=> 0,
28759 Pragma_Shared_Passive
=> 0,
28760 Pragma_Short_Descriptors
=> 0,
28761 Pragma_Simple_Storage_Pool_Type
=> 0,
28762 Pragma_Source_File_Name
=> 0,
28763 Pragma_Source_File_Name_Project
=> 0,
28764 Pragma_Source_Reference
=> 0,
28765 Pragma_SPARK_Mode
=> 0,
28766 Pragma_Storage_Size
=> -1,
28767 Pragma_Storage_Unit
=> 0,
28768 Pragma_Static_Elaboration_Desired
=> 0,
28769 Pragma_Stream_Convert
=> 0,
28770 Pragma_Style_Checks
=> 0,
28771 Pragma_Subtitle
=> 0,
28772 Pragma_Suppress
=> 0,
28773 Pragma_Suppress_Exception_Locations
=> 0,
28774 Pragma_Suppress_All
=> 0,
28775 Pragma_Suppress_Debug_Info
=> 0,
28776 Pragma_Suppress_Initialization
=> 0,
28777 Pragma_System_Name
=> 0,
28778 Pragma_Task_Dispatching_Policy
=> 0,
28779 Pragma_Task_Info
=> -1,
28780 Pragma_Task_Name
=> -1,
28781 Pragma_Task_Storage
=> -1,
28782 Pragma_Test_Case
=> -1,
28783 Pragma_Thread_Local_Storage
=> -1,
28784 Pragma_Time_Slice
=> -1,
28786 Pragma_Type_Invariant
=> -1,
28787 Pragma_Type_Invariant_Class
=> -1,
28788 Pragma_Unchecked_Union
=> 0,
28789 Pragma_Unevaluated_Use_Of_Old
=> 0,
28790 Pragma_Unimplemented_Unit
=> 0,
28791 Pragma_Universal_Aliasing
=> 0,
28792 Pragma_Universal_Data
=> 0,
28793 Pragma_Unmodified
=> 0,
28794 Pragma_Unreferenced
=> 0,
28795 Pragma_Unreferenced_Objects
=> 0,
28796 Pragma_Unreserve_All_Interrupts
=> 0,
28797 Pragma_Unsuppress
=> 0,
28798 Pragma_Unused
=> 0,
28799 Pragma_Use_VADS_Size
=> 0,
28800 Pragma_Validity_Checks
=> 0,
28801 Pragma_Volatile
=> 0,
28802 Pragma_Volatile_Components
=> 0,
28803 Pragma_Volatile_Full_Access
=> 0,
28804 Pragma_Volatile_Function
=> 0,
28805 Pragma_Warning_As_Error
=> 0,
28806 Pragma_Warnings
=> 0,
28807 Pragma_Weak_External
=> 0,
28808 Pragma_Wide_Character_Encoding
=> 0,
28809 Unknown_Pragma
=> 0);
28811 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
28817 function Arg_No
return Nat
;
28818 -- Returns an integer showing what argument we are in. A value of
28819 -- zero means we are not in any of the arguments.
28825 function Arg_No
return Nat
is
28830 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
28844 -- Start of processing for Non_Significant_Pragma_Reference
28849 if Nkind
(P
) /= N_Pragma_Argument_Association
then
28853 Id
:= Get_Pragma_Id
(Parent
(P
));
28854 C
:= Sig_Flags
(Id
);
28869 return AN
< (C
- 90);
28875 end Is_Non_Significant_Pragma_Reference
;
28877 ------------------------------
28878 -- Is_Pragma_String_Literal --
28879 ------------------------------
28881 -- This function returns true if the corresponding pragma argument is a
28882 -- static string expression. These are the only cases in which string
28883 -- literals can appear as pragma arguments. We also allow a string literal
28884 -- as the first argument to pragma Assert (although it will of course
28885 -- always generate a type error).
28887 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
28888 Pragn
: constant Node_Id
:= Parent
(Par
);
28889 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
28890 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
28896 N
:= First
(Assoc
);
28903 if Pname
= Name_Assert
then
28906 elsif Pname
= Name_Export
then
28909 elsif Pname
= Name_Ident
then
28912 elsif Pname
= Name_Import
then
28915 elsif Pname
= Name_Interface_Name
then
28918 elsif Pname
= Name_Linker_Alias
then
28921 elsif Pname
= Name_Linker_Section
then
28924 elsif Pname
= Name_Machine_Attribute
then
28927 elsif Pname
= Name_Source_File_Name
then
28930 elsif Pname
= Name_Source_Reference
then
28933 elsif Pname
= Name_Title
then
28936 elsif Pname
= Name_Subtitle
then
28942 end Is_Pragma_String_Literal
;
28944 ---------------------------
28945 -- Is_Private_SPARK_Mode --
28946 ---------------------------
28948 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
28951 (Nkind
(N
) = N_Pragma
28952 and then Pragma_Name
(N
) = Name_SPARK_Mode
28953 and then Is_List_Member
(N
));
28955 -- For pragma SPARK_Mode to be private, it has to appear in the private
28956 -- declarations of a package.
28959 Present
(Parent
(N
))
28960 and then Nkind
(Parent
(N
)) = N_Package_Specification
28961 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
28962 end Is_Private_SPARK_Mode
;
28964 -------------------------------------
28965 -- Is_Unconstrained_Or_Tagged_Item --
28966 -------------------------------------
28968 function Is_Unconstrained_Or_Tagged_Item
28969 (Item
: Entity_Id
) return Boolean
28971 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
28972 -- Determine whether record type Typ has at least one unconstrained
28975 ---------------------------------
28976 -- Has_Unconstrained_Component --
28977 ---------------------------------
28979 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
28983 Comp
:= First_Component
(Typ
);
28984 while Present
(Comp
) loop
28985 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
28989 Next_Component
(Comp
);
28993 end Has_Unconstrained_Component
;
28997 Typ
: constant Entity_Id
:= Etype
(Item
);
28999 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29002 if Is_Tagged_Type
(Typ
) then
29005 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
29008 elsif Is_Record_Type
(Typ
) then
29009 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
29012 return Has_Unconstrained_Component
(Typ
);
29015 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
29021 end Is_Unconstrained_Or_Tagged_Item
;
29023 -----------------------------
29024 -- Is_Valid_Assertion_Kind --
29025 -----------------------------
29027 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
29034 | Name_Assertion_Policy
29035 | Name_Static_Predicate
29036 | Name_Dynamic_Predicate
29041 | Name_Type_Invariant
29042 | Name_uType_Invariant
29046 | Name_Assert_And_Cut
29048 | Name_Contract_Cases
29050 | Name_Default_Initial_Condition
29052 | Name_Initial_Condition
29055 | Name_Loop_Invariant
29056 | Name_Loop_Variant
29057 | Name_Postcondition
29058 | Name_Precondition
29060 | Name_Refined_Post
29061 | Name_Statement_Assertions
29068 end Is_Valid_Assertion_Kind
;
29070 --------------------------------------
29071 -- Process_Compilation_Unit_Pragmas --
29072 --------------------------------------
29074 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
29076 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29077 -- strange because it comes at the end of the unit. Rational has the
29078 -- same name for a pragma, but treats it as a program unit pragma, In
29079 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29080 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29081 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29082 -- the context clause to ensure the correct processing.
29084 if Has_Pragma_Suppress_All
(N
) then
29085 Prepend_To
(Context_Items
(N
),
29086 Make_Pragma
(Sloc
(N
),
29087 Chars
=> Name_Suppress
,
29088 Pragma_Argument_Associations
=> New_List
(
29089 Make_Pragma_Argument_Association
(Sloc
(N
),
29090 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
29093 -- Nothing else to do at the current time
29095 end Process_Compilation_Unit_Pragmas
;
29097 -------------------------------------------
29098 -- Process_Compile_Time_Warning_Or_Error --
29099 -------------------------------------------
29101 procedure Process_Compile_Time_Warning_Or_Error
29105 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
29106 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
29107 Arg2
: constant Node_Id
:= Next
(Arg1
);
29110 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
29112 if Compile_Time_Known_Value
(Arg1x
) then
29113 if Is_True
(Expr_Value
(Arg1x
)) then
29115 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29116 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
29117 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
29118 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
29119 Str_Len
: constant Nat
:= String_Length
(Str
);
29121 Force
: constant Boolean :=
29122 Prag_Id
= Pragma_Compile_Time_Warning
29123 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
29124 and then (Ekind
(Cent
) /= E_Package
29125 or else not In_Private_Part
(Cent
));
29126 -- Set True if this is the warning case, and we are in the
29127 -- visible part of a package spec, or in a subprogram spec,
29128 -- in which case we want to force the client to see the
29129 -- warning, even though it is not in the main unit.
29137 -- Loop through segments of message separated by line feeds.
29138 -- We output these segments as separate messages with
29139 -- continuation marks for all but the first.
29144 Error_Msg_Strlen
:= 0;
29146 -- Loop to copy characters from argument to error message
29150 exit when Ptr
> Str_Len
;
29151 CC
:= Get_String_Char
(Str
, Ptr
);
29154 -- Ignore wide chars ??? else store character
29156 if In_Character_Range
(CC
) then
29157 C
:= Get_Character
(CC
);
29158 exit when C
= ASCII
.LF
;
29159 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
29160 Error_Msg_String
(Error_Msg_Strlen
) := C
;
29164 -- Here with one line ready to go
29166 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
29168 -- If this is a warning in a spec, then we want clients
29169 -- to see the warning, so mark the message with the
29170 -- special sequence !! to force the warning. In the case
29171 -- of a package spec, we do not force this if we are in
29172 -- the private part of the spec.
29175 if Cont
= False then
29176 Error_Msg
("<<~!!", Eloc
);
29179 Error_Msg
("\<<~!!", Eloc
);
29182 -- Error, rather than warning, or in a body, so we do not
29183 -- need to force visibility for client (error will be
29184 -- output in any case, and this is the situation in which
29185 -- we do not want a client to get a warning, since the
29186 -- warning is in the body or the spec private part).
29189 if Cont
= False then
29190 Error_Msg
("<<~", Eloc
);
29193 Error_Msg
("\<<~", Eloc
);
29197 exit when Ptr
> Str_Len
;
29202 end Process_Compile_Time_Warning_Or_Error
;
29204 ------------------------------------
29205 -- Record_Possible_Body_Reference --
29206 ------------------------------------
29208 procedure Record_Possible_Body_Reference
29209 (State_Id
: Entity_Id
;
29213 Spec_Id
: Entity_Id
;
29216 -- Ensure that we are dealing with a reference to a state
29218 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
29220 -- Climb the tree starting from the reference looking for a package body
29221 -- whose spec declares the referenced state. This criteria automatically
29222 -- excludes references in package specs which are legal. Note that it is
29223 -- not wise to emit an error now as the package body may lack pragma
29224 -- Refined_State or the referenced state may not be mentioned in the
29225 -- refinement. This approach avoids the generation of misleading errors.
29228 while Present
(Context
) loop
29229 if Nkind
(Context
) = N_Package_Body
then
29230 Spec_Id
:= Corresponding_Spec
(Context
);
29232 if Present
(Abstract_States
(Spec_Id
))
29233 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
29235 if No
(Body_References
(State_Id
)) then
29236 Set_Body_References
(State_Id
, New_Elmt_List
);
29239 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
29244 Context
:= Parent
(Context
);
29246 end Record_Possible_Body_Reference
;
29248 ------------------------------------------
29249 -- Relocate_Pragmas_To_Anonymous_Object --
29250 ------------------------------------------
29252 procedure Relocate_Pragmas_To_Anonymous_Object
29253 (Typ_Decl
: Node_Id
;
29254 Obj_Decl
: Node_Id
)
29258 Next_Decl
: Node_Id
;
29261 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
29262 Def
:= Protected_Definition
(Typ_Decl
);
29264 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
29265 Def
:= Task_Definition
(Typ_Decl
);
29268 -- The concurrent definition has a visible declaration list. Inspect it
29269 -- and relocate all canidate pragmas.
29271 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
29272 Decl
:= First
(Visible_Declarations
(Def
));
29273 while Present
(Decl
) loop
29275 -- Preserve the following declaration for iteration purposes due
29276 -- to possible relocation of a pragma.
29278 Next_Decl
:= Next
(Decl
);
29280 if Nkind
(Decl
) = N_Pragma
29281 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
29284 Insert_After
(Obj_Decl
, Decl
);
29286 -- Skip internally generated code
29288 elsif not Comes_From_Source
(Decl
) then
29291 -- No candidate pragmas are available for relocation
29300 end Relocate_Pragmas_To_Anonymous_Object
;
29302 ------------------------------
29303 -- Relocate_Pragmas_To_Body --
29304 ------------------------------
29306 procedure Relocate_Pragmas_To_Body
29307 (Subp_Body
: Node_Id
;
29308 Target_Body
: Node_Id
:= Empty
)
29310 procedure Relocate_Pragma
(Prag
: Node_Id
);
29311 -- Remove a single pragma from its current list and add it to the
29312 -- declarations of the proper body (either Subp_Body or Target_Body).
29314 ---------------------
29315 -- Relocate_Pragma --
29316 ---------------------
29318 procedure Relocate_Pragma
(Prag
: Node_Id
) is
29323 -- When subprogram stubs or expression functions are involves, the
29324 -- destination declaration list belongs to the proper body.
29326 if Present
(Target_Body
) then
29327 Target
:= Target_Body
;
29329 Target
:= Subp_Body
;
29332 Decls
:= Declarations
(Target
);
29336 Set_Declarations
(Target
, Decls
);
29339 -- Unhook the pragma from its current list
29342 Prepend
(Prag
, Decls
);
29343 end Relocate_Pragma
;
29347 Body_Id
: constant Entity_Id
:=
29348 Defining_Unit_Name
(Specification
(Subp_Body
));
29349 Next_Stmt
: Node_Id
;
29352 -- Start of processing for Relocate_Pragmas_To_Body
29355 -- Do not process a body that comes from a separate unit as no construct
29356 -- can possibly follow it.
29358 if not Is_List_Member
(Subp_Body
) then
29361 -- Do not relocate pragmas that follow a stub if the stub does not have
29364 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
29365 and then No
(Target_Body
)
29369 -- Do not process internally generated routine _Postconditions
29371 elsif Ekind
(Body_Id
) = E_Procedure
29372 and then Chars
(Body_Id
) = Name_uPostconditions
29377 -- Look at what is following the body. We are interested in certain kind
29378 -- of pragmas (either from source or byproducts of expansion) that can
29379 -- apply to a body [stub].
29381 Stmt
:= Next
(Subp_Body
);
29382 while Present
(Stmt
) loop
29384 -- Preserve the following statement for iteration purposes due to a
29385 -- possible relocation of a pragma.
29387 Next_Stmt
:= Next
(Stmt
);
29389 -- Move a candidate pragma following the body to the declarations of
29392 if Nkind
(Stmt
) = N_Pragma
29393 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
29395 Relocate_Pragma
(Stmt
);
29397 -- Skip internally generated code
29399 elsif not Comes_From_Source
(Stmt
) then
29402 -- No candidate pragmas are available for relocation
29410 end Relocate_Pragmas_To_Body
;
29412 -------------------
29413 -- Resolve_State --
29414 -------------------
29416 procedure Resolve_State
(N
: Node_Id
) is
29421 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
29422 Func
:= Entity
(N
);
29424 -- Handle overloading of state names by functions. Traverse the
29425 -- homonym chain looking for an abstract state.
29427 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
29428 State
:= Homonym
(Func
);
29429 while Present
(State
) loop
29431 -- Resolve the overloading by setting the proper entity of the
29432 -- reference to that of the state.
29434 if Ekind
(State
) = E_Abstract_State
then
29435 Set_Etype
(N
, Standard_Void_Type
);
29436 Set_Entity
(N
, State
);
29437 Set_Associated_Node
(N
, State
);
29441 State
:= Homonym
(State
);
29444 -- A function can never act as a state. If the homonym chain does
29445 -- not contain a corresponding state, then something went wrong in
29446 -- the overloading mechanism.
29448 raise Program_Error
;
29453 ----------------------------
29454 -- Rewrite_Assertion_Kind --
29455 ----------------------------
29457 procedure Rewrite_Assertion_Kind
29459 From_Policy
: Boolean := False)
29465 if Nkind
(N
) = N_Attribute_Reference
29466 and then Attribute_Name
(N
) = Name_Class
29467 and then Nkind
(Prefix
(N
)) = N_Identifier
29469 case Chars
(Prefix
(N
)) is
29476 when Name_Type_Invariant
=>
29477 Nam
:= Name_uType_Invariant
;
29479 when Name_Invariant
=>
29480 Nam
:= Name_uInvariant
;
29486 -- Recommend standard use of aspect names Pre/Post
29488 elsif Nkind
(N
) = N_Identifier
29489 and then From_Policy
29490 and then Serious_Errors_Detected
= 0
29491 and then not ASIS_Mode
29493 if Chars
(N
) = Name_Precondition
29494 or else Chars
(N
) = Name_Postcondition
29496 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
29498 ("\use Assertion_Policy and aspect names Pre/Post for "
29499 & "Ada2012 conformance?", N
);
29505 if Nam
/= No_Name
then
29506 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
29508 end Rewrite_Assertion_Kind
;
29516 Dummy
:= Dummy
+ 1;
29519 --------------------------------
29520 -- Set_Encoded_Interface_Name --
29521 --------------------------------
29523 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
29524 Str
: constant String_Id
:= Strval
(S
);
29525 Len
: constant Nat
:= String_Length
(Str
);
29530 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
29533 -- Stores encoded value of character code CC. The encoding we use an
29534 -- underscore followed by four lower case hex digits.
29540 procedure Encode
is
29542 Store_String_Char
(Get_Char_Code
('_'));
29544 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
29546 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
29548 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
29550 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
29553 -- Start of processing for Set_Encoded_Interface_Name
29556 -- If first character is asterisk, this is a link name, and we leave it
29557 -- completely unmodified. We also ignore null strings (the latter case
29558 -- happens only in error cases).
29561 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
29563 Set_Interface_Name
(E
, S
);
29568 CC
:= Get_String_Char
(Str
, J
);
29570 exit when not In_Character_Range
(CC
);
29572 C
:= Get_Character
(CC
);
29574 exit when C
/= '_' and then C
/= '$'
29575 and then C
not in '0' .. '9'
29576 and then C
not in 'a' .. 'z'
29577 and then C
not in 'A' .. 'Z';
29580 Set_Interface_Name
(E
, S
);
29588 -- Here we need to encode. The encoding we use as follows:
29589 -- three underscores + four hex digits (lower case)
29593 for J
in 1 .. String_Length
(Str
) loop
29594 CC
:= Get_String_Char
(Str
, J
);
29596 if not In_Character_Range
(CC
) then
29599 C
:= Get_Character
(CC
);
29601 if C
= '_' or else C
= '$'
29602 or else C
in '0' .. '9'
29603 or else C
in 'a' .. 'z'
29604 or else C
in 'A' .. 'Z'
29606 Store_String_Char
(CC
);
29613 Set_Interface_Name
(E
,
29614 Make_String_Literal
(Sloc
(S
),
29615 Strval
=> End_String
));
29617 end Set_Encoded_Interface_Name
;
29619 ------------------------
29620 -- Set_Elab_Unit_Name --
29621 ------------------------
29623 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
29628 if Nkind
(N
) = N_Identifier
29629 and then Nkind
(With_Item
) = N_Identifier
29631 Set_Entity
(N
, Entity
(With_Item
));
29633 elsif Nkind
(N
) = N_Selected_Component
then
29634 Change_Selected_Component_To_Expanded_Name
(N
);
29635 Set_Entity
(N
, Entity
(With_Item
));
29636 Set_Entity
(Selector_Name
(N
), Entity
(N
));
29638 Pref
:= Prefix
(N
);
29639 Scop
:= Scope
(Entity
(N
));
29640 while Nkind
(Pref
) = N_Selected_Component
loop
29641 Change_Selected_Component_To_Expanded_Name
(Pref
);
29642 Set_Entity
(Selector_Name
(Pref
), Scop
);
29643 Set_Entity
(Pref
, Scop
);
29644 Pref
:= Prefix
(Pref
);
29645 Scop
:= Scope
(Scop
);
29648 Set_Entity
(Pref
, Scop
);
29651 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
29652 end Set_Elab_Unit_Name
;
29654 -------------------
29655 -- Test_Case_Arg --
29656 -------------------
29658 function Test_Case_Arg
29661 From_Aspect
: Boolean := False) return Node_Id
29663 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
29668 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
29673 -- The caller requests the aspect argument
29675 if From_Aspect
then
29676 if Present
(Aspect
)
29677 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
29679 Args
:= Expression
(Aspect
);
29681 -- "Name" and "Mode" may appear without an identifier as a
29682 -- positional association.
29684 if Present
(Expressions
(Args
)) then
29685 Arg
:= First
(Expressions
(Args
));
29687 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29695 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29700 -- Some or all arguments may appear as component associatons
29702 if Present
(Component_Associations
(Args
)) then
29703 Arg
:= First
(Component_Associations
(Args
));
29704 while Present
(Arg
) loop
29705 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
29714 -- Otherwise retrieve the argument directly from the pragma
29717 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29719 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
29723 -- Skip argument "Name"
29727 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
29731 -- Skip argument "Mode"
29735 -- Arguments "Requires" and "Ensures" are optional and may not be
29738 while Present
(Arg
) loop
29739 if Chars
(Arg
) = Arg_Nam
then