1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1992-2017, Free Software Foundation, Inc. --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING3. If not, go to --
19 -- http://www.gnu.org/licenses for a complete copy of the license. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
26 -- This unit contains the semantic processing for all pragmas, both language
27 -- and implementation defined. For most pragmas, the parser only does the
28 -- most basic job of checking the syntax, so Sem_Prag also contains the code
29 -- to complete the syntax checks. Certain pragmas are handled partially or
30 -- completely by the parser (see Par.Prag for further details).
32 with Aspects
; use Aspects
;
33 with Atree
; use Atree
;
34 with Casing
; use Casing
;
35 with Checks
; use Checks
;
36 with Contracts
; use Contracts
;
37 with Csets
; use Csets
;
38 with Debug
; use Debug
;
39 with Einfo
; use Einfo
;
40 with Elists
; use Elists
;
41 with Errout
; use Errout
;
42 with Exp_Dist
; use Exp_Dist
;
43 with Exp_Util
; use Exp_Util
;
44 with Freeze
; use Freeze
;
45 with Ghost
; use Ghost
;
46 with Gnatvsn
; use Gnatvsn
;
48 with Lib
.Writ
; use Lib
.Writ
;
49 with Lib
.Xref
; use Lib
.Xref
;
50 with Namet
.Sp
; use Namet
.Sp
;
51 with Nlists
; use Nlists
;
52 with Nmake
; use Nmake
;
53 with Output
; use Output
;
54 with Par_SCO
; use Par_SCO
;
55 with Restrict
; use Restrict
;
56 with Rident
; use Rident
;
57 with Rtsfind
; use Rtsfind
;
59 with Sem_Aux
; use Sem_Aux
;
60 with Sem_Ch3
; use Sem_Ch3
;
61 with Sem_Ch6
; use Sem_Ch6
;
62 with Sem_Ch8
; use Sem_Ch8
;
63 with Sem_Ch12
; use Sem_Ch12
;
64 with Sem_Ch13
; use Sem_Ch13
;
65 with Sem_Disp
; use Sem_Disp
;
66 with Sem_Dist
; use Sem_Dist
;
67 with Sem_Elim
; use Sem_Elim
;
68 with Sem_Eval
; use Sem_Eval
;
69 with Sem_Intr
; use Sem_Intr
;
70 with Sem_Mech
; use Sem_Mech
;
71 with Sem_Res
; use Sem_Res
;
72 with Sem_Type
; use Sem_Type
;
73 with Sem_Util
; use Sem_Util
;
74 with Sem_Warn
; use Sem_Warn
;
75 with Stand
; use Stand
;
76 with Sinfo
; use Sinfo
;
77 with Sinfo
.CN
; use Sinfo
.CN
;
78 with Sinput
; use Sinput
;
79 with Stringt
; use Stringt
;
80 with Stylesw
; use Stylesw
;
82 with Targparm
; use Targparm
;
83 with Tbuild
; use Tbuild
;
85 with Uintp
; use Uintp
;
86 with Uname
; use Uname
;
87 with Urealp
; use Urealp
;
88 with Validsw
; use Validsw
;
89 with Warnsw
; use Warnsw
;
91 package body Sem_Prag
is
93 ----------------------------------------------
94 -- Common Handling of Import-Export Pragmas --
95 ----------------------------------------------
97 -- In the following section, a number of Import_xxx and Export_xxx pragmas
98 -- are defined by GNAT. These are compatible with the DEC pragmas of the
99 -- same name, and all have the following common form and processing:
102 -- [Internal =>] LOCAL_NAME
103 -- [, [External =>] EXTERNAL_SYMBOL]
104 -- [, other optional parameters ]);
107 -- [Internal =>] LOCAL_NAME
108 -- [, [External =>] EXTERNAL_SYMBOL]
109 -- [, other optional parameters ]);
111 -- EXTERNAL_SYMBOL ::=
113 -- | static_string_EXPRESSION
115 -- The internal LOCAL_NAME designates the entity that is imported or
116 -- exported, and must refer to an entity in the current declarative
117 -- part (as required by the rules for LOCAL_NAME).
119 -- The external linker name is designated by the External parameter if
120 -- given, or the Internal parameter if not (if there is no External
121 -- parameter, the External parameter is a copy of the Internal name).
123 -- If the External parameter is given as a string, then this string is
124 -- treated as an external name (exactly as though it had been given as an
125 -- External_Name parameter for a normal Import pragma).
127 -- If the External parameter is given as an identifier (or there is no
128 -- External parameter, so that the Internal identifier is used), then
129 -- the external name is the characters of the identifier, translated
130 -- to all lower case letters.
132 -- Note: the external name specified or implied by any of these special
133 -- Import_xxx or Export_xxx pragmas override an external or link name
134 -- specified in a previous Import or Export pragma.
136 -- Note: these and all other DEC-compatible GNAT pragmas allow full use of
137 -- named notation, following the standard rules for subprogram calls, i.e.
138 -- parameters can be given in any order if named notation is used, and
139 -- positional and named notation can be mixed, subject to the rule that all
140 -- positional parameters must appear first.
142 -- Note: All these pragmas are implemented exactly following the DEC design
143 -- and implementation and are intended to be fully compatible with the use
144 -- of these pragmas in the DEC Ada compiler.
146 --------------------------------------------
147 -- Checking for Duplicated External Names --
148 --------------------------------------------
150 -- It is suspicious if two separate Export pragmas use the same external
151 -- name. The following table is used to diagnose this situation so that
152 -- an appropriate warning can be issued.
154 -- The Node_Id stored is for the N_String_Literal node created to hold
155 -- the value of the external name. The Sloc of this node is used to
156 -- cross-reference the location of the duplication.
158 package Externals
is new Table
.Table
(
159 Table_Component_Type
=> Node_Id
,
160 Table_Index_Type
=> Int
,
161 Table_Low_Bound
=> 0,
162 Table_Initial
=> 100,
163 Table_Increment
=> 100,
164 Table_Name
=> "Name_Externals");
166 -------------------------------------
167 -- Local Subprograms and Variables --
168 -------------------------------------
170 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
;
171 -- This routine is used for possible casing adjustment of an explicit
172 -- external name supplied as a string literal (the node N), according to
173 -- the casing requirement of Opt.External_Name_Casing. If this is set to
174 -- As_Is, then the string literal is returned unchanged, but if it is set
175 -- to Uppercase or Lowercase, then a new string literal with appropriate
176 -- casing is constructed.
178 procedure Analyze_Part_Of
182 Encap_Id
: out Entity_Id
;
183 Legal
: out Boolean);
184 -- Subsidiary to Analyze_Part_Of_In_Decl_Part, Analyze_Part_Of_Option and
185 -- Analyze_Pragma. Perform full analysis of indicator Part_Of. Indic is the
186 -- Part_Of indicator. Item_Id is the entity of an abstract state, object or
187 -- package instantiation. Encap denotes the encapsulating state or single
188 -- concurrent type. Encap_Id is the entity of Encap. Flag Legal is set when
189 -- the indicator is legal.
191 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean;
192 -- Subsidiary to analysis of pragmas Depends, Global and Refined_Depends.
193 -- Query whether a particular item appears in a mixed list of nodes and
194 -- entities. It is assumed that all nodes in the list have entities.
196 procedure Check_Postcondition_Use_In_Inlined_Subprogram
198 Spec_Id
: Entity_Id
);
199 -- Subsidiary to the analysis of pragmas Contract_Cases, Postcondition,
200 -- Precondition, Refined_Post and Test_Case. Emit a warning when pragma
201 -- Prag is associated with subprogram Spec_Id subject to Inline_Always.
203 procedure Check_State_And_Constituent_Use
207 -- Subsidiary to the analysis of pragmas [Refined_]Depends, [Refined_]
208 -- Global and Initializes. Determine whether a state from list States and a
209 -- corresponding constituent from list Constits (if any) appear in the same
210 -- context denoted by Context. If this is the case, emit an error.
212 procedure Contract_Freeze_Error
213 (Contract_Id
: Entity_Id
;
214 Freeze_Id
: Entity_Id
);
215 -- Subsidiary to the analysis of pragmas Contract_Cases, Part_Of, Post, and
216 -- Pre. Emit a freezing-related error message where Freeze_Id is the entity
217 -- of a body which caused contract "freezing" and Contract_Id denotes the
218 -- entity of the affected contstruct.
220 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
);
221 -- Subsidiary to all Find_Related_xxx routines. Emit an error on pragma
222 -- Prag that duplicates previous pragma Prev.
224 function Find_Encapsulating_State
226 Constit_Id
: Entity_Id
) return Entity_Id
;
227 -- Given the entity of a constituent Constit_Id, find the corresponding
228 -- encapsulating state which appears in States. The routine returns Empty
229 -- if no such state is found.
231 function Find_Related_Context
233 Do_Checks
: Boolean := False) return Node_Id
;
234 -- Subsidiary to the analysis of pragmas
237 -- Constant_After_Elaboration
241 -- Find the first source declaration or statement found while traversing
242 -- the previous node chain starting from pragma Prag. If flag Do_Checks is
243 -- set, the routine reports duplicate pragmas. The routine returns Empty
244 -- when reaching the start of the node chain.
246 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
;
247 -- If Def_Id refers to a renamed subprogram, then the base subprogram (the
248 -- original one, following the renaming chain) is returned. Otherwise the
249 -- entity is returned unchanged. Should be in Einfo???
251 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
;
252 -- Subsidiary to the analysis of pragma SPARK_Mode as well as subprogram
253 -- Get_SPARK_Mode_From_Annotation. Convert a name into a corresponding
254 -- value of type SPARK_Mode_Type.
256 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean;
257 -- Subsidiary to the analysis of pragmas Depends and Refined_Depends.
258 -- Determine whether dependency clause Clause is surrounded by extra
259 -- parentheses. If this is the case, issue an error message.
261 function Is_CCT_Instance
263 Context_Id
: Entity_Id
) return Boolean;
264 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
265 -- Global. Determine whether entity Ref_Id denotes the current instance of
266 -- a concurrent type. Context_Id denotes the associated context where the
269 function Is_Unconstrained_Or_Tagged_Item
(Item
: Entity_Id
) return Boolean;
270 -- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
271 -- pragma Depends. Determine whether the type of dependency item Item is
272 -- tagged, unconstrained array, unconstrained record or a record with at
273 -- least one unconstrained component.
275 procedure Record_Possible_Body_Reference
276 (State_Id
: Entity_Id
;
278 -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
279 -- Global. Given an abstract state denoted by State_Id and a reference Ref
280 -- to it, determine whether the reference appears in a package body that
281 -- will eventually refine the state. If this is the case, record the
282 -- reference for future checks (see Analyze_Refined_State_In_Decls).
284 procedure Resolve_State
(N
: Node_Id
);
285 -- Handle the overloading of state names by functions. When N denotes a
286 -- function, this routine finds the corresponding state and sets the entity
287 -- of N to that of the state.
289 procedure Rewrite_Assertion_Kind
291 From_Policy
: Boolean := False);
292 -- If N is Pre'Class, Post'Class, Invariant'Class, or Type_Invariant'Class,
293 -- then it is rewritten as an identifier with the corresponding special
294 -- name _Pre, _Post, _Invariant, or _Type_Invariant. Used by pragmas Check
295 -- and Check_Policy. If the names are Precondition or Postcondition, this
296 -- combination is deprecated in favor of Assertion_Policy and Ada2012
297 -- Aspect names. The parameter From_Policy indicates that the pragma
298 -- is the old non-standard Check_Policy and not a rewritten pragma.
300 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
);
301 -- Place semantic information on the argument of an Elaborate/Elaborate_All
302 -- pragma. Entity name for unit and its parents is taken from item in
303 -- previous with_clause that mentions the unit.
305 Dummy
: Integer := 0;
306 pragma Volatile
(Dummy
);
307 -- Dummy volatile integer used in bodies of ip/rv to prevent optimization
310 pragma No_Inline
(ip
);
311 -- A dummy procedure called when pragma Inspection_Point is analyzed. This
312 -- is just to help debugging the front end. If a pragma Inspection_Point
313 -- is added to a source program, then breaking on ip will get you to that
314 -- point in the program.
317 pragma No_Inline
(rv
);
318 -- This is a dummy function called by the processing for pragma Reviewable.
319 -- It is there for assisting front end debugging. By placing a Reviewable
320 -- pragma in the source program, a breakpoint on rv catches this place in
321 -- the source, allowing convenient stepping to the point of interest.
323 -------------------------------
324 -- Adjust_External_Name_Case --
325 -------------------------------
327 function Adjust_External_Name_Case
(N
: Node_Id
) return Node_Id
is
331 -- Adjust case of literal if required
333 if Opt
.External_Name_Exp_Casing
= As_Is
then
337 -- Copy existing string
343 for J
in 1 .. String_Length
(Strval
(N
)) loop
344 CC
:= Get_String_Char
(Strval
(N
), J
);
346 if Opt
.External_Name_Exp_Casing
= Uppercase
347 and then CC
>= Get_Char_Code
('a')
348 and then CC
<= Get_Char_Code
('z')
350 Store_String_Char
(CC
- 32);
352 elsif Opt
.External_Name_Exp_Casing
= Lowercase
353 and then CC
>= Get_Char_Code
('A')
354 and then CC
<= Get_Char_Code
('Z')
356 Store_String_Char
(CC
+ 32);
359 Store_String_Char
(CC
);
364 Make_String_Literal
(Sloc
(N
),
365 Strval
=> End_String
);
367 end Adjust_External_Name_Case
;
369 -----------------------------------------
370 -- Analyze_Contract_Cases_In_Decl_Part --
371 -----------------------------------------
373 -- WARNING: This routine manages Ghost regions. Return statements must be
374 -- replaced by gotos which jump to the end of the routine and restore the
377 procedure Analyze_Contract_Cases_In_Decl_Part
379 Freeze_Id
: Entity_Id
:= Empty
)
381 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
382 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
384 Others_Seen
: Boolean := False;
385 -- This flag is set when an "others" choice is encountered. It is used
386 -- to detect multiple illegal occurrences of "others".
388 procedure Analyze_Contract_Case
(CCase
: Node_Id
);
389 -- Verify the legality of a single contract case
391 ---------------------------
392 -- Analyze_Contract_Case --
393 ---------------------------
395 procedure Analyze_Contract_Case
(CCase
: Node_Id
) is
396 Case_Guard
: Node_Id
;
399 Extra_Guard
: Node_Id
;
402 if Nkind
(CCase
) = N_Component_Association
then
403 Case_Guard
:= First
(Choices
(CCase
));
404 Conseq
:= Expression
(CCase
);
406 -- Each contract case must have exactly one case guard
408 Extra_Guard
:= Next
(Case_Guard
);
410 if Present
(Extra_Guard
) then
412 ("contract case must have exactly one case guard",
416 -- Check placement of OTHERS if available (SPARK RM 6.1.3(1))
418 if Nkind
(Case_Guard
) = N_Others_Choice
then
421 ("only one others choice allowed in contract cases",
427 elsif Others_Seen
then
429 ("others must be the last choice in contract cases", N
);
432 -- Preanalyze the case guard and consequence
434 if Nkind
(Case_Guard
) /= N_Others_Choice
then
435 Errors
:= Serious_Errors_Detected
;
436 Preanalyze_Assert_Expression
(Case_Guard
, Standard_Boolean
);
438 -- Emit a clarification message when the case guard contains
439 -- at least one undefined reference, possibly due to contract
442 if Errors
/= Serious_Errors_Detected
443 and then Present
(Freeze_Id
)
444 and then Has_Undefined_Reference
(Case_Guard
)
446 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
450 Errors
:= Serious_Errors_Detected
;
451 Preanalyze_Assert_Expression
(Conseq
, Standard_Boolean
);
453 -- Emit a clarification message when the consequence contains
454 -- at least one undefined reference, possibly due to contract
457 if Errors
/= Serious_Errors_Detected
458 and then Present
(Freeze_Id
)
459 and then Has_Undefined_Reference
(Conseq
)
461 Contract_Freeze_Error
(Spec_Id
, Freeze_Id
);
464 -- The contract case is malformed
467 Error_Msg_N
("wrong syntax in contract case", CCase
);
469 end Analyze_Contract_Case
;
473 CCases
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
475 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
476 -- Save the Ghost mode to restore on exit
479 Restore_Scope
: Boolean := False;
481 -- Start of processing for Analyze_Contract_Cases_In_Decl_Part
484 -- Do not analyze the pragma multiple times
486 if Is_Analyzed_Pragma
(N
) then
490 -- Set the Ghost mode in effect from the pragma. Due to the delayed
491 -- analysis of the pragma, the Ghost mode at point of declaration and
492 -- point of analysis may not necessarily be the same. Use the mode in
493 -- effect at the point of declaration.
497 -- Single and multiple contract cases must appear in aggregate form. If
498 -- this is not the case, then either the parser of the analysis of the
499 -- pragma failed to produce an aggregate.
501 pragma Assert
(Nkind
(CCases
) = N_Aggregate
);
503 if Present
(Component_Associations
(CCases
)) then
505 -- Ensure that the formal parameters are visible when analyzing all
506 -- clauses. This falls out of the general rule of aspects pertaining
507 -- to subprogram declarations.
509 if not In_Open_Scopes
(Spec_Id
) then
510 Restore_Scope
:= True;
511 Push_Scope
(Spec_Id
);
513 if Is_Generic_Subprogram
(Spec_Id
) then
514 Install_Generic_Formals
(Spec_Id
);
516 Install_Formals
(Spec_Id
);
520 CCase
:= First
(Component_Associations
(CCases
));
521 while Present
(CCase
) loop
522 Analyze_Contract_Case
(CCase
);
526 if Restore_Scope
then
530 -- Currently it is not possible to inline pre/postconditions on a
531 -- subprogram subject to pragma Inline_Always.
533 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
535 -- Otherwise the pragma is illegal
538 Error_Msg_N
("wrong syntax for constract cases", N
);
541 Set_Is_Analyzed_Pragma
(N
);
543 Restore_Ghost_Mode
(Saved_GM
);
544 end Analyze_Contract_Cases_In_Decl_Part
;
546 ----------------------------------
547 -- Analyze_Depends_In_Decl_Part --
548 ----------------------------------
550 procedure Analyze_Depends_In_Decl_Part
(N
: Node_Id
) is
551 Loc
: constant Source_Ptr
:= Sloc
(N
);
552 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
553 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
555 All_Inputs_Seen
: Elist_Id
:= No_Elist
;
556 -- A list containing the entities of all the inputs processed so far.
557 -- The list is populated with unique entities because the same input
558 -- may appear in multiple input lists.
560 All_Outputs_Seen
: Elist_Id
:= No_Elist
;
561 -- A list containing the entities of all the outputs processed so far.
562 -- The list is populated with unique entities because output items are
563 -- unique in a dependence relation.
565 Constits_Seen
: Elist_Id
:= No_Elist
;
566 -- A list containing the entities of all constituents processed so far.
567 -- It aids in detecting illegal usage of a state and a corresponding
568 -- constituent in pragma [Refinde_]Depends.
570 Global_Seen
: Boolean := False;
571 -- A flag set when pragma Global has been processed
573 Null_Output_Seen
: Boolean := False;
574 -- A flag used to track the legality of a null output
576 Result_Seen
: Boolean := False;
577 -- A flag set when Spec_Id'Result is processed
579 States_Seen
: Elist_Id
:= No_Elist
;
580 -- A list containing the entities of all states processed so far. It
581 -- helps in detecting illegal usage of a state and a corresponding
582 -- constituent in pragma [Refined_]Depends.
584 Subp_Inputs
: Elist_Id
:= No_Elist
;
585 Subp_Outputs
: Elist_Id
:= No_Elist
;
586 -- Two lists containing the full set of inputs and output of the related
587 -- subprograms. Note that these lists contain both nodes and entities.
589 Task_Input_Seen
: Boolean := False;
590 Task_Output_Seen
: Boolean := False;
591 -- Flags used to track the implicit dependence of a task unit on itself
593 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
);
594 -- Subsidiary routine to Check_Role and Check_Usage. Add the item kind
595 -- to the name buffer. The individual kinds are as follows:
596 -- E_Abstract_State - "state"
597 -- E_Constant - "constant"
598 -- E_Discriminant - "discriminant"
599 -- E_Generic_In_Out_Parameter - "generic parameter"
600 -- E_Generic_In_Parameter - "generic parameter"
601 -- E_In_Parameter - "parameter"
602 -- E_In_Out_Parameter - "parameter"
603 -- E_Loop_Parameter - "loop parameter"
604 -- E_Out_Parameter - "parameter"
605 -- E_Protected_Type - "current instance of protected type"
606 -- E_Task_Type - "current instance of task type"
607 -- E_Variable - "global"
609 procedure Analyze_Dependency_Clause
612 -- Verify the legality of a single dependency clause. Flag Is_Last
613 -- denotes whether Clause is the last clause in the relation.
615 procedure Check_Function_Return
;
616 -- Verify that Funtion'Result appears as one of the outputs
617 -- (SPARK RM 6.1.5(10)).
624 -- Ensure that an item fulfills its designated input and/or output role
625 -- as specified by pragma Global (if any) or the enclosing context. If
626 -- this is not the case, emit an error. Item and Item_Id denote the
627 -- attributes of an item. Flag Is_Input should be set when item comes
628 -- from an input list. Flag Self_Ref should be set when the item is an
629 -- output and the dependency clause has operator "+".
631 procedure Check_Usage
632 (Subp_Items
: Elist_Id
;
633 Used_Items
: Elist_Id
;
635 -- Verify that all items from Subp_Items appear in Used_Items. Emit an
636 -- error if this is not the case.
638 procedure Normalize_Clause
(Clause
: Node_Id
);
639 -- Remove a self-dependency "+" from the input list of a clause
641 -----------------------------
642 -- Add_Item_To_Name_Buffer --
643 -----------------------------
645 procedure Add_Item_To_Name_Buffer
(Item_Id
: Entity_Id
) is
647 if Ekind
(Item_Id
) = E_Abstract_State
then
648 Add_Str_To_Name_Buffer
("state");
650 elsif Ekind
(Item_Id
) = E_Constant
then
651 Add_Str_To_Name_Buffer
("constant");
653 elsif Ekind
(Item_Id
) = E_Discriminant
then
654 Add_Str_To_Name_Buffer
("discriminant");
656 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
657 E_Generic_In_Parameter
)
659 Add_Str_To_Name_Buffer
("generic parameter");
661 elsif Is_Formal
(Item_Id
) then
662 Add_Str_To_Name_Buffer
("parameter");
664 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
665 Add_Str_To_Name_Buffer
("loop parameter");
667 elsif Ekind
(Item_Id
) = E_Protected_Type
668 or else Is_Single_Protected_Object
(Item_Id
)
670 Add_Str_To_Name_Buffer
("current instance of protected type");
672 elsif Ekind
(Item_Id
) = E_Task_Type
673 or else Is_Single_Task_Object
(Item_Id
)
675 Add_Str_To_Name_Buffer
("current instance of task type");
677 elsif Ekind
(Item_Id
) = E_Variable
then
678 Add_Str_To_Name_Buffer
("global");
680 -- The routine should not be called with non-SPARK items
685 end Add_Item_To_Name_Buffer
;
687 -------------------------------
688 -- Analyze_Dependency_Clause --
689 -------------------------------
691 procedure Analyze_Dependency_Clause
695 procedure Analyze_Input_List
(Inputs
: Node_Id
);
696 -- Verify the legality of a single input list
698 procedure Analyze_Input_Output
703 Seen
: in out Elist_Id
;
704 Null_Seen
: in out Boolean;
705 Non_Null_Seen
: in out Boolean);
706 -- Verify the legality of a single input or output item. Flag
707 -- Is_Input should be set whenever Item is an input, False when it
708 -- denotes an output. Flag Self_Ref should be set when the item is an
709 -- output and the dependency clause has a "+". Flag Top_Level should
710 -- be set whenever Item appears immediately within an input or output
711 -- list. Seen is a collection of all abstract states, objects and
712 -- formals processed so far. Flag Null_Seen denotes whether a null
713 -- input or output has been encountered. Flag Non_Null_Seen denotes
714 -- whether a non-null input or output has been encountered.
716 ------------------------
717 -- Analyze_Input_List --
718 ------------------------
720 procedure Analyze_Input_List
(Inputs
: Node_Id
) is
721 Inputs_Seen
: Elist_Id
:= No_Elist
;
722 -- A list containing the entities of all inputs that appear in the
723 -- current input list.
725 Non_Null_Input_Seen
: Boolean := False;
726 Null_Input_Seen
: Boolean := False;
727 -- Flags used to check the legality of an input list
732 -- Multiple inputs appear as an aggregate
734 if Nkind
(Inputs
) = N_Aggregate
then
735 if Present
(Component_Associations
(Inputs
)) then
737 ("nested dependency relations not allowed", Inputs
);
739 elsif Present
(Expressions
(Inputs
)) then
740 Input
:= First
(Expressions
(Inputs
));
741 while Present
(Input
) loop
748 Null_Seen
=> Null_Input_Seen
,
749 Non_Null_Seen
=> Non_Null_Input_Seen
);
754 -- Syntax error, always report
757 Error_Msg_N
("malformed input dependency list", Inputs
);
760 -- Process a solitary input
769 Null_Seen
=> Null_Input_Seen
,
770 Non_Null_Seen
=> Non_Null_Input_Seen
);
773 -- Detect an illegal dependency clause of the form
777 if Null_Output_Seen
and then Null_Input_Seen
then
779 ("null dependency clause cannot have a null input list",
782 end Analyze_Input_List
;
784 --------------------------
785 -- Analyze_Input_Output --
786 --------------------------
788 procedure Analyze_Input_Output
793 Seen
: in out Elist_Id
;
794 Null_Seen
: in out Boolean;
795 Non_Null_Seen
: in out Boolean)
797 procedure Current_Task_Instance_Seen
;
798 -- Set the appropriate global flag when the current instance of a
799 -- task unit is encountered.
801 --------------------------------
802 -- Current_Task_Instance_Seen --
803 --------------------------------
805 procedure Current_Task_Instance_Seen
is
808 Task_Input_Seen
:= True;
810 Task_Output_Seen
:= True;
812 end Current_Task_Instance_Seen
;
816 Is_Output
: constant Boolean := not Is_Input
;
820 -- Start of processing for Analyze_Input_Output
823 -- Multiple input or output items appear as an aggregate
825 if Nkind
(Item
) = N_Aggregate
then
826 if not Top_Level
then
827 SPARK_Msg_N
("nested grouping of items not allowed", Item
);
829 elsif Present
(Component_Associations
(Item
)) then
831 ("nested dependency relations not allowed", Item
);
833 -- Recursively analyze the grouped items
835 elsif Present
(Expressions
(Item
)) then
836 Grouped
:= First
(Expressions
(Item
));
837 while Present
(Grouped
) loop
840 Is_Input
=> Is_Input
,
841 Self_Ref
=> Self_Ref
,
844 Null_Seen
=> Null_Seen
,
845 Non_Null_Seen
=> Non_Null_Seen
);
850 -- Syntax error, always report
853 Error_Msg_N
("malformed dependency list", Item
);
856 -- Process attribute 'Result in the context of a dependency clause
858 elsif Is_Attribute_Result
(Item
) then
859 Non_Null_Seen
:= True;
863 -- Attribute 'Result is allowed to appear on the output side of
864 -- a dependency clause (SPARK RM 6.1.5(6)).
867 SPARK_Msg_N
("function result cannot act as input", Item
);
871 ("cannot mix null and non-null dependency items", Item
);
877 -- Detect multiple uses of null in a single dependency list or
878 -- throughout the whole relation. Verify the placement of a null
879 -- output list relative to the other clauses (SPARK RM 6.1.5(12)).
881 elsif Nkind
(Item
) = N_Null
then
884 ("multiple null dependency relations not allowed", Item
);
886 elsif Non_Null_Seen
then
888 ("cannot mix null and non-null dependency items", Item
);
896 ("null output list must be the last clause in a "
897 & "dependency relation", Item
);
899 -- Catch a useless dependence of the form:
904 ("useless dependence, null depends on itself", Item
);
912 Non_Null_Seen
:= True;
915 SPARK_Msg_N
("cannot mix null and non-null items", Item
);
919 Resolve_State
(Item
);
921 -- Find the entity of the item. If this is a renaming, climb
922 -- the renaming chain to reach the root object. Renamings of
923 -- non-entire objects do not yield an entity (Empty).
925 Item_Id
:= Entity_Of
(Item
);
927 if Present
(Item_Id
) then
931 if Ekind_In
(Item_Id
, E_Constant
, E_Loop_Parameter
)
934 -- Current instances of concurrent types
936 Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
)
941 Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
942 E_Generic_In_Parameter
,
950 Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
)
952 -- The item denotes a concurrent type. Note that single
953 -- protected/task types are not considered here because
954 -- they behave as objects in the context of pragma
955 -- [Refined_]Depends.
957 if Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
959 -- This use is legal as long as the concurrent type is
960 -- the current instance of an enclosing type.
962 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
964 -- The dependence of a task unit on itself is
965 -- implicit and may or may not be explicitly
966 -- specified (SPARK RM 6.1.4).
968 if Ekind
(Item_Id
) = E_Task_Type
then
969 Current_Task_Instance_Seen
;
972 -- Otherwise this is not the current instance
976 ("invalid use of subtype mark in dependency "
980 -- The dependency of a task unit on itself is implicit
981 -- and may or may not be explicitly specified
984 elsif Is_Single_Task_Object
(Item_Id
)
985 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
987 Current_Task_Instance_Seen
;
990 -- Ensure that the item fulfills its role as input and/or
991 -- output as specified by pragma Global or the enclosing
994 Check_Role
(Item
, Item_Id
, Is_Input
, Self_Ref
);
996 -- Detect multiple uses of the same state, variable or
997 -- formal parameter. If this is not the case, add the
998 -- item to the list of processed relations.
1000 if Contains
(Seen
, Item_Id
) then
1002 ("duplicate use of item &", Item
, Item_Id
);
1004 Append_New_Elmt
(Item_Id
, Seen
);
1007 -- Detect illegal use of an input related to a null
1008 -- output. Such input items cannot appear in other
1009 -- input lists (SPARK RM 6.1.5(13)).
1012 and then Null_Output_Seen
1013 and then Contains
(All_Inputs_Seen
, Item_Id
)
1016 ("input of a null output list cannot appear in "
1017 & "multiple input lists", Item
);
1020 -- Add an input or a self-referential output to the list
1021 -- of all processed inputs.
1023 if Is_Input
or else Self_Ref
then
1024 Append_New_Elmt
(Item_Id
, All_Inputs_Seen
);
1027 -- State related checks (SPARK RM 6.1.5(3))
1029 if Ekind
(Item_Id
) = E_Abstract_State
then
1031 -- Package and subprogram bodies are instantiated
1032 -- individually in a separate compiler pass. Due to
1033 -- this mode of instantiation, the refinement of a
1034 -- state may no longer be visible when a subprogram
1035 -- body contract is instantiated. Since the generic
1036 -- template is legal, do not perform this check in
1037 -- the instance to circumvent this oddity.
1039 if Is_Generic_Instance
(Spec_Id
) then
1042 -- An abstract state with visible refinement cannot
1043 -- appear in pragma [Refined_]Depends as its place
1044 -- must be taken by some of its constituents
1045 -- (SPARK RM 6.1.4(7)).
1047 elsif Has_Visible_Refinement
(Item_Id
) then
1049 ("cannot mention state & in dependence relation",
1051 SPARK_Msg_N
("\use its constituents instead", Item
);
1054 -- If the reference to the abstract state appears in
1055 -- an enclosing package body that will eventually
1056 -- refine the state, record the reference for future
1060 Record_Possible_Body_Reference
1061 (State_Id
=> Item_Id
,
1066 -- When the item renames an entire object, replace the
1067 -- item with a reference to the object.
1069 if Entity
(Item
) /= Item_Id
then
1071 New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
1075 -- Add the entity of the current item to the list of
1078 if Ekind
(Item_Id
) = E_Abstract_State
then
1079 Append_New_Elmt
(Item_Id
, States_Seen
);
1081 -- The variable may eventually become a constituent of a
1082 -- single protected/task type. Record the reference now
1083 -- and verify its legality when analyzing the contract of
1084 -- the variable (SPARK RM 9.3).
1086 elsif Ekind
(Item_Id
) = E_Variable
then
1087 Record_Possible_Part_Of_Reference
1092 if Ekind_In
(Item_Id
, E_Abstract_State
,
1095 and then Present
(Encapsulating_State
(Item_Id
))
1097 Append_New_Elmt
(Item_Id
, Constits_Seen
);
1100 -- All other input/output items are illegal
1101 -- (SPARK RM 6.1.5(1)).
1105 ("item must denote parameter, variable, state or "
1106 & "current instance of concurren type", Item
);
1109 -- All other input/output items are illegal
1110 -- (SPARK RM 6.1.5(1)). This is a syntax error, always report.
1114 ("item must denote parameter, variable, state or current "
1115 & "instance of concurrent type", Item
);
1118 end Analyze_Input_Output
;
1126 Non_Null_Output_Seen
: Boolean := False;
1127 -- Flag used to check the legality of an output list
1129 -- Start of processing for Analyze_Dependency_Clause
1132 Inputs
:= Expression
(Clause
);
1135 -- An input list with a self-dependency appears as operator "+" where
1136 -- the actuals inputs are the right operand.
1138 if Nkind
(Inputs
) = N_Op_Plus
then
1139 Inputs
:= Right_Opnd
(Inputs
);
1143 -- Process the output_list of a dependency_clause
1145 Output
:= First
(Choices
(Clause
));
1146 while Present
(Output
) loop
1147 Analyze_Input_Output
1150 Self_Ref
=> Self_Ref
,
1152 Seen
=> All_Outputs_Seen
,
1153 Null_Seen
=> Null_Output_Seen
,
1154 Non_Null_Seen
=> Non_Null_Output_Seen
);
1159 -- Process the input_list of a dependency_clause
1161 Analyze_Input_List
(Inputs
);
1162 end Analyze_Dependency_Clause
;
1164 ---------------------------
1165 -- Check_Function_Return --
1166 ---------------------------
1168 procedure Check_Function_Return
is
1170 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
1171 and then not Result_Seen
1174 ("result of & must appear in exactly one output list",
1177 end Check_Function_Return
;
1183 procedure Check_Role
1185 Item_Id
: Entity_Id
;
1190 (Item_Is_Input
: out Boolean;
1191 Item_Is_Output
: out Boolean);
1192 -- Find the input/output role of Item_Id. Flags Item_Is_Input and
1193 -- Item_Is_Output are set depending on the role.
1195 procedure Role_Error
1196 (Item_Is_Input
: Boolean;
1197 Item_Is_Output
: Boolean);
1198 -- Emit an error message concerning the incorrect use of Item in
1199 -- pragma [Refined_]Depends. Flags Item_Is_Input and Item_Is_Output
1200 -- denote whether the item is an input and/or an output.
1207 (Item_Is_Input
: out Boolean;
1208 Item_Is_Output
: out Boolean)
1211 Item_Is_Input
:= False;
1212 Item_Is_Output
:= False;
1216 if Ekind
(Item_Id
) = E_Abstract_State
then
1218 -- When pragma Global is present, the mode of the state may be
1219 -- further constrained by setting a more restrictive mode.
1222 if Appears_In
(Subp_Inputs
, Item_Id
) then
1223 Item_Is_Input
:= True;
1226 if Appears_In
(Subp_Outputs
, Item_Id
) then
1227 Item_Is_Output
:= True;
1230 -- Otherwise the state has a default IN OUT mode
1233 Item_Is_Input
:= True;
1234 Item_Is_Output
:= True;
1239 elsif Ekind_In
(Item_Id
, E_Constant
,
1243 Item_Is_Input
:= True;
1247 elsif Ekind_In
(Item_Id
, E_Generic_In_Parameter
,
1250 Item_Is_Input
:= True;
1252 elsif Ekind_In
(Item_Id
, E_Generic_In_Out_Parameter
,
1255 Item_Is_Input
:= True;
1256 Item_Is_Output
:= True;
1258 elsif Ekind
(Item_Id
) = E_Out_Parameter
then
1259 if Scope
(Item_Id
) = Spec_Id
then
1261 -- An OUT parameter of the related subprogram has mode IN
1262 -- if its type is unconstrained or tagged because array
1263 -- bounds, discriminants or tags can be read.
1265 if Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1266 Item_Is_Input
:= True;
1269 Item_Is_Output
:= True;
1271 -- An OUT parameter of an enclosing subprogram behaves as a
1272 -- read-write variable in which case the mode is IN OUT.
1275 Item_Is_Input
:= True;
1276 Item_Is_Output
:= True;
1281 elsif Ekind
(Item_Id
) = E_Protected_Type
then
1283 -- A protected type acts as a formal parameter of mode IN when
1284 -- it applies to a protected function.
1286 if Ekind
(Spec_Id
) = E_Function
then
1287 Item_Is_Input
:= True;
1289 -- Otherwise the protected type acts as a formal of mode IN OUT
1292 Item_Is_Input
:= True;
1293 Item_Is_Output
:= True;
1298 elsif Ekind
(Item_Id
) = E_Task_Type
then
1299 Item_Is_Input
:= True;
1300 Item_Is_Output
:= True;
1304 else pragma Assert
(Ekind
(Item_Id
) = E_Variable
);
1306 -- When pragma Global is present, the mode of the variable may
1307 -- be further constrained by setting a more restrictive mode.
1311 -- A variable has mode IN when its type is unconstrained or
1312 -- tagged because array bounds, discriminants or tags can be
1315 if Appears_In
(Subp_Inputs
, Item_Id
)
1316 or else Is_Unconstrained_Or_Tagged_Item
(Item_Id
)
1318 Item_Is_Input
:= True;
1321 if Appears_In
(Subp_Outputs
, Item_Id
) then
1322 Item_Is_Output
:= True;
1325 -- Otherwise the variable has a default IN OUT mode
1328 Item_Is_Input
:= True;
1329 Item_Is_Output
:= True;
1338 procedure Role_Error
1339 (Item_Is_Input
: Boolean;
1340 Item_Is_Output
: Boolean)
1342 Error_Msg
: Name_Id
;
1347 -- When the item is not part of the input and the output set of
1348 -- the related subprogram, then it appears as extra in pragma
1349 -- [Refined_]Depends.
1351 if not Item_Is_Input
and then not Item_Is_Output
then
1352 Add_Item_To_Name_Buffer
(Item_Id
);
1353 Add_Str_To_Name_Buffer
1354 (" & cannot appear in dependence relation");
1356 Error_Msg
:= Name_Find
;
1357 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1359 Error_Msg_Name_1
:= Chars
(Spec_Id
);
1361 (Fix_Msg
(Spec_Id
, "\& is not part of the input or output "
1362 & "set of subprogram %"), Item
, Item_Id
);
1364 -- The mode of the item and its role in pragma [Refined_]Depends
1365 -- are in conflict. Construct a detailed message explaining the
1366 -- illegality (SPARK RM 6.1.5(5-6)).
1369 if Item_Is_Input
then
1370 Add_Str_To_Name_Buffer
("read-only");
1372 Add_Str_To_Name_Buffer
("write-only");
1375 Add_Char_To_Name_Buffer
(' ');
1376 Add_Item_To_Name_Buffer
(Item_Id
);
1377 Add_Str_To_Name_Buffer
(" & cannot appear as ");
1379 if Item_Is_Input
then
1380 Add_Str_To_Name_Buffer
("output");
1382 Add_Str_To_Name_Buffer
("input");
1385 Add_Str_To_Name_Buffer
(" in dependence relation");
1386 Error_Msg
:= Name_Find
;
1387 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), Item
, Item_Id
);
1393 Item_Is_Input
: Boolean;
1394 Item_Is_Output
: Boolean;
1396 -- Start of processing for Check_Role
1399 Find_Role
(Item_Is_Input
, Item_Is_Output
);
1404 if not Item_Is_Input
then
1405 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1408 -- Self-referential item
1411 if not Item_Is_Input
or else not Item_Is_Output
then
1412 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1417 elsif not Item_Is_Output
then
1418 Role_Error
(Item_Is_Input
, Item_Is_Output
);
1426 procedure Check_Usage
1427 (Subp_Items
: Elist_Id
;
1428 Used_Items
: Elist_Id
;
1431 procedure Usage_Error
(Item_Id
: Entity_Id
);
1432 -- Emit an error concerning the illegal usage of an item
1438 procedure Usage_Error
(Item_Id
: Entity_Id
) is
1439 Error_Msg
: Name_Id
;
1446 -- Unconstrained and tagged items are not part of the explicit
1447 -- input set of the related subprogram, they do not have to be
1448 -- present in a dependence relation and should not be flagged
1449 -- (SPARK RM 6.1.5(8)).
1451 if not Is_Unconstrained_Or_Tagged_Item
(Item_Id
) then
1454 Add_Item_To_Name_Buffer
(Item_Id
);
1455 Add_Str_To_Name_Buffer
1456 (" & is missing from input dependence list");
1458 Error_Msg
:= Name_Find
;
1459 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1462 -- Output case (SPARK RM 6.1.5(10))
1467 Add_Item_To_Name_Buffer
(Item_Id
);
1468 Add_Str_To_Name_Buffer
1469 (" & is missing from output dependence list");
1471 Error_Msg
:= Name_Find
;
1472 SPARK_Msg_NE
(Get_Name_String
(Error_Msg
), N
, Item_Id
);
1480 Item_Id
: Entity_Id
;
1482 -- Start of processing for Check_Usage
1485 if No
(Subp_Items
) then
1489 -- Each input or output of the subprogram must appear in a dependency
1492 Elmt
:= First_Elmt
(Subp_Items
);
1493 while Present
(Elmt
) loop
1494 Item
:= Node
(Elmt
);
1496 if Nkind
(Item
) = N_Defining_Identifier
then
1499 Item_Id
:= Entity_Of
(Item
);
1502 -- The item does not appear in a dependency
1504 if Present
(Item_Id
)
1505 and then not Contains
(Used_Items
, Item_Id
)
1507 if Is_Formal
(Item_Id
) then
1508 Usage_Error
(Item_Id
);
1510 -- The current instance of a protected type behaves as a formal
1511 -- parameter (SPARK RM 6.1.4).
1513 elsif Ekind
(Item_Id
) = E_Protected_Type
1514 or else Is_Single_Protected_Object
(Item_Id
)
1516 Usage_Error
(Item_Id
);
1518 -- The current instance of a task type behaves as a formal
1519 -- parameter (SPARK RM 6.1.4).
1521 elsif Ekind
(Item_Id
) = E_Task_Type
1522 or else Is_Single_Task_Object
(Item_Id
)
1524 -- The dependence of a task unit on itself is implicit and
1525 -- may or may not be explicitly specified (SPARK RM 6.1.4).
1526 -- Emit an error if only one input/output is present.
1528 if Task_Input_Seen
/= Task_Output_Seen
then
1529 Usage_Error
(Item_Id
);
1532 -- States and global objects are not used properly only when
1533 -- the subprogram is subject to pragma Global.
1535 elsif Global_Seen
then
1536 Usage_Error
(Item_Id
);
1544 ----------------------
1545 -- Normalize_Clause --
1546 ----------------------
1548 procedure Normalize_Clause
(Clause
: Node_Id
) is
1549 procedure Create_Or_Modify_Clause
1555 Multiple
: Boolean);
1556 -- Create a brand new clause to represent the self-reference or
1557 -- modify the input and/or output lists of an existing clause. Output
1558 -- denotes a self-referencial output. Outputs is the output list of a
1559 -- clause. Inputs is the input list of a clause. After denotes the
1560 -- clause after which the new clause is to be inserted. Flag In_Place
1561 -- should be set when normalizing the last output of an output list.
1562 -- Flag Multiple should be set when Output comes from a list with
1565 -----------------------------
1566 -- Create_Or_Modify_Clause --
1567 -----------------------------
1569 procedure Create_Or_Modify_Clause
1577 procedure Propagate_Output
1580 -- Handle the various cases of output propagation to the input
1581 -- list. Output denotes a self-referencial output item. Inputs
1582 -- is the input list of a clause.
1584 ----------------------
1585 -- Propagate_Output --
1586 ----------------------
1588 procedure Propagate_Output
1592 function In_Input_List
1594 Inputs
: List_Id
) return Boolean;
1595 -- Determine whether a particulat item appears in the input
1596 -- list of a clause.
1602 function In_Input_List
1604 Inputs
: List_Id
) return Boolean
1609 Elmt
:= First
(Inputs
);
1610 while Present
(Elmt
) loop
1611 if Entity_Of
(Elmt
) = Item
then
1623 Output_Id
: constant Entity_Id
:= Entity_Of
(Output
);
1626 -- Start of processing for Propagate_Output
1629 -- The clause is of the form:
1631 -- (Output =>+ null)
1633 -- Remove null input and replace it with a copy of the output:
1635 -- (Output => Output)
1637 if Nkind
(Inputs
) = N_Null
then
1638 Rewrite
(Inputs
, New_Copy_Tree
(Output
));
1640 -- The clause is of the form:
1642 -- (Output =>+ (Input1, ..., InputN))
1644 -- Determine whether the output is not already mentioned in the
1645 -- input list and if not, add it to the list of inputs:
1647 -- (Output => (Output, Input1, ..., InputN))
1649 elsif Nkind
(Inputs
) = N_Aggregate
then
1650 Grouped
:= Expressions
(Inputs
);
1652 if not In_Input_List
1656 Prepend_To
(Grouped
, New_Copy_Tree
(Output
));
1659 -- The clause is of the form:
1661 -- (Output =>+ Input)
1663 -- If the input does not mention the output, group the two
1666 -- (Output => (Output, Input))
1668 elsif Entity_Of
(Inputs
) /= Output_Id
then
1670 Make_Aggregate
(Loc
,
1671 Expressions
=> New_List
(
1672 New_Copy_Tree
(Output
),
1673 New_Copy_Tree
(Inputs
))));
1675 end Propagate_Output
;
1679 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
1680 New_Clause
: Node_Id
;
1682 -- Start of processing for Create_Or_Modify_Clause
1685 -- A null output depending on itself does not require any
1688 if Nkind
(Output
) = N_Null
then
1691 -- A function result cannot depend on itself because it cannot
1692 -- appear in the input list of a relation (SPARK RM 6.1.5(10)).
1694 elsif Is_Attribute_Result
(Output
) then
1695 SPARK_Msg_N
("function result cannot depend on itself", Output
);
1699 -- When performing the transformation in place, simply add the
1700 -- output to the list of inputs (if not already there). This
1701 -- case arises when dealing with the last output of an output
1702 -- list. Perform the normalization in place to avoid generating
1703 -- a malformed tree.
1706 Propagate_Output
(Output
, Inputs
);
1708 -- A list with multiple outputs is slowly trimmed until only
1709 -- one element remains. When this happens, replace aggregate
1710 -- with the element itself.
1714 Rewrite
(Outputs
, Output
);
1720 -- Unchain the output from its output list as it will appear in
1721 -- a new clause. Note that we cannot simply rewrite the output
1722 -- as null because this will violate the semantics of pragma
1727 -- Generate a new clause of the form:
1728 -- (Output => Inputs)
1731 Make_Component_Association
(Loc
,
1732 Choices
=> New_List
(Output
),
1733 Expression
=> New_Copy_Tree
(Inputs
));
1735 -- The new clause contains replicated content that has already
1736 -- been analyzed. There is not need to reanalyze or renormalize
1739 Set_Analyzed
(New_Clause
);
1742 (Output
=> First
(Choices
(New_Clause
)),
1743 Inputs
=> Expression
(New_Clause
));
1745 Insert_After
(After
, New_Clause
);
1747 end Create_Or_Modify_Clause
;
1751 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
1753 Last_Output
: Node_Id
;
1754 Next_Output
: Node_Id
;
1757 -- Start of processing for Normalize_Clause
1760 -- A self-dependency appears as operator "+". Remove the "+" from the
1761 -- tree by moving the real inputs to their proper place.
1763 if Nkind
(Expression
(Clause
)) = N_Op_Plus
then
1764 Rewrite
(Expression
(Clause
), Right_Opnd
(Expression
(Clause
)));
1765 Inputs
:= Expression
(Clause
);
1767 -- Multiple outputs appear as an aggregate
1769 if Nkind
(Outputs
) = N_Aggregate
then
1770 Last_Output
:= Last
(Expressions
(Outputs
));
1772 Output
:= First
(Expressions
(Outputs
));
1773 while Present
(Output
) loop
1775 -- Normalization may remove an output from its list,
1776 -- preserve the subsequent output now.
1778 Next_Output
:= Next
(Output
);
1780 Create_Or_Modify_Clause
1785 In_Place
=> Output
= Last_Output
,
1788 Output
:= Next_Output
;
1794 Create_Or_Modify_Clause
1803 end Normalize_Clause
;
1807 Deps
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
1808 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
1812 Last_Clause
: Node_Id
;
1813 Restore_Scope
: Boolean := False;
1815 -- Start of processing for Analyze_Depends_In_Decl_Part
1818 -- Do not analyze the pragma multiple times
1820 if Is_Analyzed_Pragma
(N
) then
1824 -- Empty dependency list
1826 if Nkind
(Deps
) = N_Null
then
1828 -- Gather all states, objects and formal parameters that the
1829 -- subprogram may depend on. These items are obtained from the
1830 -- parameter profile or pragma [Refined_]Global (if available).
1832 Collect_Subprogram_Inputs_Outputs
1833 (Subp_Id
=> Subp_Id
,
1834 Subp_Inputs
=> Subp_Inputs
,
1835 Subp_Outputs
=> Subp_Outputs
,
1836 Global_Seen
=> Global_Seen
);
1838 -- Verify that every input or output of the subprogram appear in a
1841 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1842 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1843 Check_Function_Return
;
1845 -- Dependency clauses appear as component associations of an aggregate
1847 elsif Nkind
(Deps
) = N_Aggregate
then
1849 -- Do not attempt to perform analysis of a syntactically illegal
1850 -- clause as this will lead to misleading errors.
1852 if Has_Extra_Parentheses
(Deps
) then
1856 if Present
(Component_Associations
(Deps
)) then
1857 Last_Clause
:= Last
(Component_Associations
(Deps
));
1859 -- Gather all states, objects and formal parameters that the
1860 -- subprogram may depend on. These items are obtained from the
1861 -- parameter profile or pragma [Refined_]Global (if available).
1863 Collect_Subprogram_Inputs_Outputs
1864 (Subp_Id
=> Subp_Id
,
1865 Subp_Inputs
=> Subp_Inputs
,
1866 Subp_Outputs
=> Subp_Outputs
,
1867 Global_Seen
=> Global_Seen
);
1869 -- When pragma [Refined_]Depends appears on a single concurrent
1870 -- type, it is relocated to the anonymous object.
1872 if Is_Single_Concurrent_Object
(Spec_Id
) then
1875 -- Ensure that the formal parameters are visible when analyzing
1876 -- all clauses. This falls out of the general rule of aspects
1877 -- pertaining to subprogram declarations.
1879 elsif not In_Open_Scopes
(Spec_Id
) then
1880 Restore_Scope
:= True;
1881 Push_Scope
(Spec_Id
);
1883 if Ekind
(Spec_Id
) = E_Task_Type
then
1884 if Has_Discriminants
(Spec_Id
) then
1885 Install_Discriminants
(Spec_Id
);
1888 elsif Is_Generic_Subprogram
(Spec_Id
) then
1889 Install_Generic_Formals
(Spec_Id
);
1892 Install_Formals
(Spec_Id
);
1896 Clause
:= First
(Component_Associations
(Deps
));
1897 while Present
(Clause
) loop
1898 Errors
:= Serious_Errors_Detected
;
1900 -- The normalization mechanism may create extra clauses that
1901 -- contain replicated input and output names. There is no need
1902 -- to reanalyze them.
1904 if not Analyzed
(Clause
) then
1905 Set_Analyzed
(Clause
);
1907 Analyze_Dependency_Clause
1909 Is_Last
=> Clause
= Last_Clause
);
1912 -- Do not normalize a clause if errors were detected (count
1913 -- of Serious_Errors has increased) because the inputs and/or
1914 -- outputs may denote illegal items. Normalization is disabled
1915 -- in ASIS mode as it alters the tree by introducing new nodes
1916 -- similar to expansion.
1918 if Serious_Errors_Detected
= Errors
and then not ASIS_Mode
then
1919 Normalize_Clause
(Clause
);
1925 if Restore_Scope
then
1929 -- Verify that every input or output of the subprogram appear in a
1932 Check_Usage
(Subp_Inputs
, All_Inputs_Seen
, True);
1933 Check_Usage
(Subp_Outputs
, All_Outputs_Seen
, False);
1934 Check_Function_Return
;
1936 -- The dependency list is malformed. This is a syntax error, always
1940 Error_Msg_N
("malformed dependency relation", Deps
);
1944 -- The top level dependency relation is malformed. This is a syntax
1945 -- error, always report.
1948 Error_Msg_N
("malformed dependency relation", Deps
);
1952 -- Ensure that a state and a corresponding constituent do not appear
1953 -- together in pragma [Refined_]Depends.
1955 Check_State_And_Constituent_Use
1956 (States
=> States_Seen
,
1957 Constits
=> Constits_Seen
,
1961 Set_Is_Analyzed_Pragma
(N
);
1962 end Analyze_Depends_In_Decl_Part
;
1964 --------------------------------------------
1965 -- Analyze_External_Property_In_Decl_Part --
1966 --------------------------------------------
1968 procedure Analyze_External_Property_In_Decl_Part
1970 Expr_Val
: out Boolean)
1972 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
1973 Obj_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
1974 Obj_Id
: constant Entity_Id
:= Defining_Entity
(Obj_Decl
);
1980 -- Do not analyze the pragma multiple times
1982 if Is_Analyzed_Pragma
(N
) then
1986 Error_Msg_Name_1
:= Pragma_Name
(N
);
1988 -- An external property pragma must apply to an effectively volatile
1989 -- object other than a formal subprogram parameter (SPARK RM 7.1.3(2)).
1990 -- The check is performed at the end of the declarative region due to a
1991 -- possible out-of-order arrangement of pragmas:
1994 -- pragma Async_Readers (Obj);
1995 -- pragma Volatile (Obj);
1997 if not Is_Effectively_Volatile
(Obj_Id
) then
1999 ("external property % must apply to a volatile object", N
);
2002 -- Ensure that the Boolean expression (if present) is static. A missing
2003 -- argument defaults the value to True (SPARK RM 7.1.2(5)).
2007 if Present
(Arg1
) then
2008 Expr
:= Get_Pragma_Arg
(Arg1
);
2010 if Is_OK_Static_Expression
(Expr
) then
2011 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
2015 Set_Is_Analyzed_Pragma
(N
);
2016 end Analyze_External_Property_In_Decl_Part
;
2018 ---------------------------------
2019 -- Analyze_Global_In_Decl_Part --
2020 ---------------------------------
2022 procedure Analyze_Global_In_Decl_Part
(N
: Node_Id
) is
2023 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
2024 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
2025 Subp_Id
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
2027 Constits_Seen
: Elist_Id
:= No_Elist
;
2028 -- A list containing the entities of all constituents processed so far.
2029 -- It aids in detecting illegal usage of a state and a corresponding
2030 -- constituent in pragma [Refinde_]Global.
2032 Seen
: Elist_Id
:= No_Elist
;
2033 -- A list containing the entities of all the items processed so far. It
2034 -- plays a role in detecting distinct entities.
2036 States_Seen
: Elist_Id
:= No_Elist
;
2037 -- A list containing the entities of all states processed so far. It
2038 -- helps in detecting illegal usage of a state and a corresponding
2039 -- constituent in pragma [Refined_]Global.
2041 In_Out_Seen
: Boolean := False;
2042 Input_Seen
: Boolean := False;
2043 Output_Seen
: Boolean := False;
2044 Proof_Seen
: Boolean := False;
2045 -- Flags used to verify the consistency of modes
2047 procedure Analyze_Global_List
2049 Global_Mode
: Name_Id
:= Name_Input
);
2050 -- Verify the legality of a single global list declaration. Global_Mode
2051 -- denotes the current mode in effect.
2053 -------------------------
2054 -- Analyze_Global_List --
2055 -------------------------
2057 procedure Analyze_Global_List
2059 Global_Mode
: Name_Id
:= Name_Input
)
2061 procedure Analyze_Global_Item
2063 Global_Mode
: Name_Id
);
2064 -- Verify the legality of a single global item declaration denoted by
2065 -- Item. Global_Mode denotes the current mode in effect.
2067 procedure Check_Duplicate_Mode
2069 Status
: in out Boolean);
2070 -- Flag Status denotes whether a particular mode has been seen while
2071 -- processing a global list. This routine verifies that Mode is not a
2072 -- duplicate mode and sets the flag Status (SPARK RM 6.1.4(9)).
2074 procedure Check_Mode_Restriction_In_Enclosing_Context
2076 Item_Id
: Entity_Id
);
2077 -- Verify that an item of mode In_Out or Output does not appear as an
2078 -- input in the Global aspect of an enclosing subprogram. If this is
2079 -- the case, emit an error. Item and Item_Id are respectively the
2080 -- item and its entity.
2082 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
);
2083 -- Mode denotes either In_Out or Output. Depending on the kind of the
2084 -- related subprogram, emit an error if those two modes apply to a
2085 -- function (SPARK RM 6.1.4(10)).
2087 -------------------------
2088 -- Analyze_Global_Item --
2089 -------------------------
2091 procedure Analyze_Global_Item
2093 Global_Mode
: Name_Id
)
2095 Item_Id
: Entity_Id
;
2098 -- Detect one of the following cases
2100 -- with Global => (null, Name)
2101 -- with Global => (Name_1, null, Name_2)
2102 -- with Global => (Name, null)
2104 if Nkind
(Item
) = N_Null
then
2105 SPARK_Msg_N
("cannot mix null and non-null global items", Item
);
2110 Resolve_State
(Item
);
2112 -- Find the entity of the item. If this is a renaming, climb the
2113 -- renaming chain to reach the root object. Renamings of non-
2114 -- entire objects do not yield an entity (Empty).
2116 Item_Id
:= Entity_Of
(Item
);
2118 if Present
(Item_Id
) then
2120 -- A global item may denote a formal parameter of an enclosing
2121 -- subprogram (SPARK RM 6.1.4(6)). Do this check first to
2122 -- provide a better error diagnostic.
2124 if Is_Formal
(Item_Id
) then
2125 if Scope
(Item_Id
) = Spec_Id
then
2127 (Fix_Msg
(Spec_Id
, "global item cannot reference "
2128 & "parameter of subprogram &"), Item
, Spec_Id
);
2132 -- A global item may denote a concurrent type as long as it is
2133 -- the current instance of an enclosing protected or task type
2134 -- (SPARK RM 6.1.4).
2136 elsif Ekind_In
(Item_Id
, E_Protected_Type
, E_Task_Type
) then
2137 if Is_CCT_Instance
(Item_Id
, Spec_Id
) then
2139 -- Pragma [Refined_]Global associated with a protected
2140 -- subprogram cannot mention the current instance of a
2141 -- protected type because the instance behaves as a
2142 -- formal parameter.
2144 if Ekind
(Item_Id
) = E_Protected_Type
then
2145 Error_Msg_Name_1
:= Chars
(Item_Id
);
2147 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2148 & "cannot reference current instance of protected "
2149 & "type %"), Item
, Spec_Id
);
2152 -- Pragma [Refined_]Global associated with a task type
2153 -- cannot mention the current instance of a task type
2154 -- because the instance behaves as a formal parameter.
2156 else pragma Assert
(Ekind
(Item_Id
) = E_Task_Type
);
2157 Error_Msg_Name_1
:= Chars
(Item_Id
);
2159 (Fix_Msg
(Spec_Id
, "global item of subprogram & "
2160 & "cannot reference current instance of task type "
2161 & "%"), Item
, Spec_Id
);
2165 -- Otherwise the global item denotes a subtype mark that is
2166 -- not a current instance.
2170 ("invalid use of subtype mark in global list", Item
);
2174 -- A global item may denote the anonymous object created for a
2175 -- single protected/task type as long as the current instance
2176 -- is the same single type (SPARK RM 6.1.4).
2178 elsif Is_Single_Concurrent_Object
(Item_Id
)
2179 and then Is_CCT_Instance
(Item_Id
, Spec_Id
)
2181 -- Pragma [Refined_]Global associated with a protected
2182 -- subprogram cannot mention the current instance of a
2183 -- protected type because the instance behaves as a formal
2186 if Is_Single_Protected_Object
(Item_Id
) then
2187 Error_Msg_Name_1
:= Chars
(Item_Id
);
2189 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2190 & "reference current instance of protected type %"),
2194 -- Pragma [Refined_]Global associated with a task type
2195 -- cannot mention the current instance of a task type
2196 -- because the instance behaves as a formal parameter.
2198 else pragma Assert
(Is_Single_Task_Object
(Item_Id
));
2199 Error_Msg_Name_1
:= Chars
(Item_Id
);
2201 (Fix_Msg
(Spec_Id
, "global item of subprogram & cannot "
2202 & "reference current instance of task type %"),
2207 -- A formal object may act as a global item inside a generic
2209 elsif Is_Formal_Object
(Item_Id
) then
2212 -- The only legal references are those to abstract states,
2213 -- objects and various kinds of constants (SPARK RM 6.1.4(4)).
2215 elsif not Ekind_In
(Item_Id
, E_Abstract_State
,
2221 ("global item must denote object, state or current "
2222 & "instance of concurrent type", Item
);
2226 -- State related checks
2228 if Ekind
(Item_Id
) = E_Abstract_State
then
2230 -- Package and subprogram bodies are instantiated
2231 -- individually in a separate compiler pass. Due to this
2232 -- mode of instantiation, the refinement of a state may
2233 -- no longer be visible when a subprogram body contract
2234 -- is instantiated. Since the generic template is legal,
2235 -- do not perform this check in the instance to circumvent
2238 if Is_Generic_Instance
(Spec_Id
) then
2241 -- An abstract state with visible refinement cannot appear
2242 -- in pragma [Refined_]Global as its place must be taken by
2243 -- some of its constituents (SPARK RM 6.1.4(7)).
2245 elsif Has_Visible_Refinement
(Item_Id
) then
2247 ("cannot mention state & in global refinement",
2249 SPARK_Msg_N
("\use its constituents instead", Item
);
2252 -- An external state cannot appear as a global item of a
2253 -- nonvolatile function (SPARK RM 7.1.3(8)).
2255 elsif Is_External_State
(Item_Id
)
2256 and then Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2257 and then not Is_Volatile_Function
(Spec_Id
)
2260 ("external state & cannot act as global item of "
2261 & "nonvolatile function", Item
, Item_Id
);
2264 -- If the reference to the abstract state appears in an
2265 -- enclosing package body that will eventually refine the
2266 -- state, record the reference for future checks.
2269 Record_Possible_Body_Reference
2270 (State_Id
=> Item_Id
,
2274 -- Constant related checks
2276 elsif Ekind
(Item_Id
) = E_Constant
then
2278 -- A constant is a read-only item, therefore it cannot act
2281 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2283 ("constant & cannot act as output", Item
, Item_Id
);
2287 -- Loop parameter related checks
2289 elsif Ekind
(Item_Id
) = E_Loop_Parameter
then
2291 -- A loop parameter is a read-only item, therefore it cannot
2292 -- act as an output.
2294 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2296 ("loop parameter & cannot act as output",
2301 -- Variable related checks. These are only relevant when
2302 -- SPARK_Mode is on as they are not standard Ada legality
2305 elsif SPARK_Mode
= On
2306 and then Ekind
(Item_Id
) = E_Variable
2307 and then Is_Effectively_Volatile
(Item_Id
)
2309 -- An effectively volatile object cannot appear as a global
2310 -- item of a nonvolatile function (SPARK RM 7.1.3(8)).
2312 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
)
2313 and then not Is_Volatile_Function
(Spec_Id
)
2316 ("volatile object & cannot act as global item of a "
2317 & "function", Item
, Item_Id
);
2320 -- An effectively volatile object with external property
2321 -- Effective_Reads set to True must have mode Output or
2322 -- In_Out (SPARK RM 7.1.3(10)).
2324 elsif Effective_Reads_Enabled
(Item_Id
)
2325 and then Global_Mode
= Name_Input
2328 ("volatile object & with property Effective_Reads must "
2329 & "have mode In_Out or Output", Item
, Item_Id
);
2334 -- When the item renames an entire object, replace the item
2335 -- with a reference to the object.
2337 if Entity
(Item
) /= Item_Id
then
2338 Rewrite
(Item
, New_Occurrence_Of
(Item_Id
, Sloc
(Item
)));
2342 -- Some form of illegal construct masquerading as a name
2343 -- (SPARK RM 6.1.4(4)).
2347 ("global item must denote object, state or current instance "
2348 & "of concurrent type", Item
);
2352 -- Verify that an output does not appear as an input in an
2353 -- enclosing subprogram.
2355 if Nam_In
(Global_Mode
, Name_In_Out
, Name_Output
) then
2356 Check_Mode_Restriction_In_Enclosing_Context
(Item
, Item_Id
);
2359 -- The same entity might be referenced through various way.
2360 -- Check the entity of the item rather than the item itself
2361 -- (SPARK RM 6.1.4(10)).
2363 if Contains
(Seen
, Item_Id
) then
2364 SPARK_Msg_N
("duplicate global item", Item
);
2366 -- Add the entity of the current item to the list of processed
2370 Append_New_Elmt
(Item_Id
, Seen
);
2372 if Ekind
(Item_Id
) = E_Abstract_State
then
2373 Append_New_Elmt
(Item_Id
, States_Seen
);
2375 -- The variable may eventually become a constituent of a single
2376 -- protected/task type. Record the reference now and verify its
2377 -- legality when analyzing the contract of the variable
2380 elsif Ekind
(Item_Id
) = E_Variable
then
2381 Record_Possible_Part_Of_Reference
2386 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Constant
, E_Variable
)
2387 and then Present
(Encapsulating_State
(Item_Id
))
2389 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2392 end Analyze_Global_Item
;
2394 --------------------------
2395 -- Check_Duplicate_Mode --
2396 --------------------------
2398 procedure Check_Duplicate_Mode
2400 Status
: in out Boolean)
2404 SPARK_Msg_N
("duplicate global mode", Mode
);
2408 end Check_Duplicate_Mode
;
2410 -------------------------------------------------
2411 -- Check_Mode_Restriction_In_Enclosing_Context --
2412 -------------------------------------------------
2414 procedure Check_Mode_Restriction_In_Enclosing_Context
2416 Item_Id
: Entity_Id
)
2418 Context
: Entity_Id
;
2420 Inputs
: Elist_Id
:= No_Elist
;
2421 Outputs
: Elist_Id
:= No_Elist
;
2424 -- Traverse the scope stack looking for enclosing subprograms
2425 -- subject to pragma [Refined_]Global.
2427 Context
:= Scope
(Subp_Id
);
2428 while Present
(Context
) and then Context
/= Standard_Standard
loop
2429 if Is_Subprogram
(Context
)
2431 (Present
(Get_Pragma
(Context
, Pragma_Global
))
2433 Present
(Get_Pragma
(Context
, Pragma_Refined_Global
)))
2435 Collect_Subprogram_Inputs_Outputs
2436 (Subp_Id
=> Context
,
2437 Subp_Inputs
=> Inputs
,
2438 Subp_Outputs
=> Outputs
,
2439 Global_Seen
=> Dummy
);
2441 -- The item is classified as In_Out or Output but appears as
2442 -- an Input in an enclosing subprogram (SPARK RM 6.1.4(11)).
2444 if Appears_In
(Inputs
, Item_Id
)
2445 and then not Appears_In
(Outputs
, Item_Id
)
2448 ("global item & cannot have mode In_Out or Output",
2452 (Fix_Msg
(Subp_Id
, "\item already appears as input of "
2453 & "subprogram &"), Item
, Context
);
2455 -- Stop the traversal once an error has been detected
2461 Context
:= Scope
(Context
);
2463 end Check_Mode_Restriction_In_Enclosing_Context
;
2465 ----------------------------------------
2466 -- Check_Mode_Restriction_In_Function --
2467 ----------------------------------------
2469 procedure Check_Mode_Restriction_In_Function
(Mode
: Node_Id
) is
2471 if Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
2473 ("global mode & is not applicable to functions", Mode
);
2475 end Check_Mode_Restriction_In_Function
;
2483 -- Start of processing for Analyze_Global_List
2486 if Nkind
(List
) = N_Null
then
2487 Set_Analyzed
(List
);
2489 -- Single global item declaration
2491 elsif Nkind_In
(List
, N_Expanded_Name
,
2493 N_Selected_Component
)
2495 Analyze_Global_Item
(List
, Global_Mode
);
2497 -- Simple global list or moded global list declaration
2499 elsif Nkind
(List
) = N_Aggregate
then
2500 Set_Analyzed
(List
);
2502 -- The declaration of a simple global list appear as a collection
2505 if Present
(Expressions
(List
)) then
2506 if Present
(Component_Associations
(List
)) then
2508 ("cannot mix moded and non-moded global lists", List
);
2511 Item
:= First
(Expressions
(List
));
2512 while Present
(Item
) loop
2513 Analyze_Global_Item
(Item
, Global_Mode
);
2517 -- The declaration of a moded global list appears as a collection
2518 -- of component associations where individual choices denote
2521 elsif Present
(Component_Associations
(List
)) then
2522 if Present
(Expressions
(List
)) then
2524 ("cannot mix moded and non-moded global lists", List
);
2527 Assoc
:= First
(Component_Associations
(List
));
2528 while Present
(Assoc
) loop
2529 Mode
:= First
(Choices
(Assoc
));
2531 if Nkind
(Mode
) = N_Identifier
then
2532 if Chars
(Mode
) = Name_In_Out
then
2533 Check_Duplicate_Mode
(Mode
, In_Out_Seen
);
2534 Check_Mode_Restriction_In_Function
(Mode
);
2536 elsif Chars
(Mode
) = Name_Input
then
2537 Check_Duplicate_Mode
(Mode
, Input_Seen
);
2539 elsif Chars
(Mode
) = Name_Output
then
2540 Check_Duplicate_Mode
(Mode
, Output_Seen
);
2541 Check_Mode_Restriction_In_Function
(Mode
);
2543 elsif Chars
(Mode
) = Name_Proof_In
then
2544 Check_Duplicate_Mode
(Mode
, Proof_Seen
);
2547 SPARK_Msg_N
("invalid mode selector", Mode
);
2551 SPARK_Msg_N
("invalid mode selector", Mode
);
2554 -- Items in a moded list appear as a collection of
2555 -- expressions. Reuse the existing machinery to analyze
2559 (List
=> Expression
(Assoc
),
2560 Global_Mode
=> Chars
(Mode
));
2568 raise Program_Error
;
2571 -- Any other attempt to declare a global item is illegal. This is a
2572 -- syntax error, always report.
2575 Error_Msg_N
("malformed global list", List
);
2577 end Analyze_Global_List
;
2581 Items
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
2583 Restore_Scope
: Boolean := False;
2585 -- Start of processing for Analyze_Global_In_Decl_Part
2588 -- Do not analyze the pragma multiple times
2590 if Is_Analyzed_Pragma
(N
) then
2594 -- There is nothing to be done for a null global list
2596 if Nkind
(Items
) = N_Null
then
2597 Set_Analyzed
(Items
);
2599 -- Analyze the various forms of global lists and items. Note that some
2600 -- of these may be malformed in which case the analysis emits error
2604 -- When pragma [Refined_]Global appears on a single concurrent type,
2605 -- it is relocated to the anonymous object.
2607 if Is_Single_Concurrent_Object
(Spec_Id
) then
2610 -- Ensure that the formal parameters are visible when processing an
2611 -- item. This falls out of the general rule of aspects pertaining to
2612 -- subprogram declarations.
2614 elsif not In_Open_Scopes
(Spec_Id
) then
2615 Restore_Scope
:= True;
2616 Push_Scope
(Spec_Id
);
2618 if Ekind
(Spec_Id
) = E_Task_Type
then
2619 if Has_Discriminants
(Spec_Id
) then
2620 Install_Discriminants
(Spec_Id
);
2623 elsif Is_Generic_Subprogram
(Spec_Id
) then
2624 Install_Generic_Formals
(Spec_Id
);
2627 Install_Formals
(Spec_Id
);
2631 Analyze_Global_List
(Items
);
2633 if Restore_Scope
then
2638 -- Ensure that a state and a corresponding constituent do not appear
2639 -- together in pragma [Refined_]Global.
2641 Check_State_And_Constituent_Use
2642 (States
=> States_Seen
,
2643 Constits
=> Constits_Seen
,
2646 Set_Is_Analyzed_Pragma
(N
);
2647 end Analyze_Global_In_Decl_Part
;
2649 --------------------------------------------
2650 -- Analyze_Initial_Condition_In_Decl_Part --
2651 --------------------------------------------
2653 -- WARNING: This routine manages Ghost regions. Return statements must be
2654 -- replaced by gotos which jump to the end of the routine and restore the
2657 procedure Analyze_Initial_Condition_In_Decl_Part
(N
: Node_Id
) is
2658 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2659 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2660 Expr
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
2662 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
2663 -- Save the Ghost mode to restore on exit
2666 -- Do not analyze the pragma multiple times
2668 if Is_Analyzed_Pragma
(N
) then
2672 -- Set the Ghost mode in effect from the pragma. Due to the delayed
2673 -- analysis of the pragma, the Ghost mode at point of declaration and
2674 -- point of analysis may not necessarily be the same. Use the mode in
2675 -- effect at the point of declaration.
2679 -- The expression is preanalyzed because it has not been moved to its
2680 -- final place yet. A direct analysis may generate side effects and this
2681 -- is not desired at this point.
2683 Preanalyze_Assert_Expression
(Expr
, Standard_Boolean
);
2684 Set_Is_Analyzed_Pragma
(N
);
2686 Restore_Ghost_Mode
(Saved_GM
);
2687 end Analyze_Initial_Condition_In_Decl_Part
;
2689 --------------------------------------
2690 -- Analyze_Initializes_In_Decl_Part --
2691 --------------------------------------
2693 procedure Analyze_Initializes_In_Decl_Part
(N
: Node_Id
) is
2694 Pack_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
2695 Pack_Id
: constant Entity_Id
:= Defining_Entity
(Pack_Decl
);
2697 Constits_Seen
: Elist_Id
:= No_Elist
;
2698 -- A list containing the entities of all constituents processed so far.
2699 -- It aids in detecting illegal usage of a state and a corresponding
2700 -- constituent in pragma Initializes.
2702 Items_Seen
: Elist_Id
:= No_Elist
;
2703 -- A list of all initialization items processed so far. This list is
2704 -- used to detect duplicate items.
2706 Non_Null_Seen
: Boolean := False;
2707 Null_Seen
: Boolean := False;
2708 -- Flags used to check the legality of a null initialization list
2710 States_And_Objs
: Elist_Id
:= No_Elist
;
2711 -- A list of all abstract states and objects declared in the visible
2712 -- declarations of the related package. This list is used to detect the
2713 -- legality of initialization items.
2715 States_Seen
: Elist_Id
:= No_Elist
;
2716 -- A list containing the entities of all states processed so far. It
2717 -- helps in detecting illegal usage of a state and a corresponding
2718 -- constituent in pragma Initializes.
2720 procedure Analyze_Initialization_Item
(Item
: Node_Id
);
2721 -- Verify the legality of a single initialization item
2723 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
);
2724 -- Verify the legality of a single initialization item followed by a
2725 -- list of input items.
2727 procedure Collect_States_And_Objects
;
2728 -- Inspect the visible declarations of the related package and gather
2729 -- the entities of all abstract states and objects in States_And_Objs.
2731 ---------------------------------
2732 -- Analyze_Initialization_Item --
2733 ---------------------------------
2735 procedure Analyze_Initialization_Item
(Item
: Node_Id
) is
2736 Item_Id
: Entity_Id
;
2739 -- Null initialization list
2741 if Nkind
(Item
) = N_Null
then
2743 SPARK_Msg_N
("multiple null initializations not allowed", Item
);
2745 elsif Non_Null_Seen
then
2747 ("cannot mix null and non-null initialization items", Item
);
2752 -- Initialization item
2755 Non_Null_Seen
:= True;
2759 ("cannot mix null and non-null initialization items", Item
);
2763 Resolve_State
(Item
);
2765 if Is_Entity_Name
(Item
) then
2766 Item_Id
:= Entity_Of
(Item
);
2768 if Ekind_In
(Item_Id
, E_Abstract_State
,
2772 -- The state or variable must be declared in the visible
2773 -- declarations of the package (SPARK RM 7.1.5(7)).
2775 if not Contains
(States_And_Objs
, Item_Id
) then
2776 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2778 ("initialization item & must appear in the visible "
2779 & "declarations of package %", Item
, Item_Id
);
2781 -- Detect a duplicate use of the same initialization item
2782 -- (SPARK RM 7.1.5(5)).
2784 elsif Contains
(Items_Seen
, Item_Id
) then
2785 SPARK_Msg_N
("duplicate initialization item", Item
);
2787 -- The item is legal, add it to the list of processed states
2791 Append_New_Elmt
(Item_Id
, Items_Seen
);
2793 if Ekind
(Item_Id
) = E_Abstract_State
then
2794 Append_New_Elmt
(Item_Id
, States_Seen
);
2797 if Present
(Encapsulating_State
(Item_Id
)) then
2798 Append_New_Elmt
(Item_Id
, Constits_Seen
);
2802 -- The item references something that is not a state or object
2803 -- (SPARK RM 7.1.5(3)).
2807 ("initialization item must denote object or state", Item
);
2810 -- Some form of illegal construct masquerading as a name
2811 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2815 ("initialization item must denote object or state", Item
);
2818 end Analyze_Initialization_Item
;
2820 ---------------------------------------------
2821 -- Analyze_Initialization_Item_With_Inputs --
2822 ---------------------------------------------
2824 procedure Analyze_Initialization_Item_With_Inputs
(Item
: Node_Id
) is
2825 Inputs_Seen
: Elist_Id
:= No_Elist
;
2826 -- A list of all inputs processed so far. This list is used to detect
2827 -- duplicate uses of an input.
2829 Non_Null_Seen
: Boolean := False;
2830 Null_Seen
: Boolean := False;
2831 -- Flags used to check the legality of an input list
2833 procedure Analyze_Input_Item
(Input
: Node_Id
);
2834 -- Verify the legality of a single input item
2836 ------------------------
2837 -- Analyze_Input_Item --
2838 ------------------------
2840 procedure Analyze_Input_Item
(Input
: Node_Id
) is
2841 Input_Id
: Entity_Id
;
2842 Input_OK
: Boolean := True;
2847 if Nkind
(Input
) = N_Null
then
2850 ("multiple null initializations not allowed", Item
);
2852 elsif Non_Null_Seen
then
2854 ("cannot mix null and non-null initialization item", Item
);
2862 Non_Null_Seen
:= True;
2866 ("cannot mix null and non-null initialization item", Item
);
2870 Resolve_State
(Input
);
2872 if Is_Entity_Name
(Input
) then
2873 Input_Id
:= Entity_Of
(Input
);
2875 if Ekind_In
(Input_Id
, E_Abstract_State
,
2877 E_Generic_In_Out_Parameter
,
2878 E_Generic_In_Parameter
,
2884 -- The input cannot denote states or objects declared
2885 -- within the related package (SPARK RM 7.1.5(4)).
2887 if Within_Scope
(Input_Id
, Current_Scope
) then
2889 -- Do not consider generic formal parameters or their
2890 -- respective mappings to generic formals. Even though
2891 -- the formals appear within the scope of the package,
2892 -- it is allowed for an initialization item to depend
2893 -- on an input item.
2895 if Ekind_In
(Input_Id
, E_Generic_In_Out_Parameter
,
2896 E_Generic_In_Parameter
)
2900 elsif Ekind_In
(Input_Id
, E_Constant
, E_Variable
)
2901 and then Present
(Corresponding_Generic_Association
2902 (Declaration_Node
(Input_Id
)))
2908 Error_Msg_Name_1
:= Chars
(Pack_Id
);
2910 ("input item & cannot denote a visible object or "
2911 & "state of package %", Input
, Input_Id
);
2915 -- Detect a duplicate use of the same input item
2916 -- (SPARK RM 7.1.5(5)).
2918 if Contains
(Inputs_Seen
, Input_Id
) then
2920 SPARK_Msg_N
("duplicate input item", Input
);
2923 -- Input is legal, add it to the list of processed inputs
2926 Append_New_Elmt
(Input_Id
, Inputs_Seen
);
2928 if Ekind
(Input_Id
) = E_Abstract_State
then
2929 Append_New_Elmt
(Input_Id
, States_Seen
);
2932 if Ekind_In
(Input_Id
, E_Abstract_State
,
2935 and then Present
(Encapsulating_State
(Input_Id
))
2937 Append_New_Elmt
(Input_Id
, Constits_Seen
);
2941 -- The input references something that is not a state or an
2942 -- object (SPARK RM 7.1.5(3)).
2946 ("input item must denote object or state", Input
);
2949 -- Some form of illegal construct masquerading as a name
2950 -- (SPARK RM 7.1.5(3)). This is a syntax error, always report.
2954 ("input item must denote object or state", Input
);
2957 end Analyze_Input_Item
;
2961 Inputs
: constant Node_Id
:= Expression
(Item
);
2965 Name_Seen
: Boolean := False;
2966 -- A flag used to detect multiple item names
2968 -- Start of processing for Analyze_Initialization_Item_With_Inputs
2971 -- Inspect the name of an item with inputs
2973 Elmt
:= First
(Choices
(Item
));
2974 while Present
(Elmt
) loop
2976 SPARK_Msg_N
("only one item allowed in initialization", Elmt
);
2979 Analyze_Initialization_Item
(Elmt
);
2985 -- Multiple input items appear as an aggregate
2987 if Nkind
(Inputs
) = N_Aggregate
then
2988 if Present
(Expressions
(Inputs
)) then
2989 Input
:= First
(Expressions
(Inputs
));
2990 while Present
(Input
) loop
2991 Analyze_Input_Item
(Input
);
2996 if Present
(Component_Associations
(Inputs
)) then
2998 ("inputs must appear in named association form", Inputs
);
3001 -- Single input item
3004 Analyze_Input_Item
(Inputs
);
3006 end Analyze_Initialization_Item_With_Inputs
;
3008 --------------------------------
3009 -- Collect_States_And_Objects --
3010 --------------------------------
3012 procedure Collect_States_And_Objects
is
3013 Pack_Spec
: constant Node_Id
:= Specification
(Pack_Decl
);
3017 -- Collect the abstract states defined in the package (if any)
3019 if Present
(Abstract_States
(Pack_Id
)) then
3020 States_And_Objs
:= New_Copy_Elist
(Abstract_States
(Pack_Id
));
3023 -- Collect all objects the appear in the visible declarations of the
3026 if Present
(Visible_Declarations
(Pack_Spec
)) then
3027 Decl
:= First
(Visible_Declarations
(Pack_Spec
));
3028 while Present
(Decl
) loop
3029 if Comes_From_Source
(Decl
)
3030 and then Nkind
(Decl
) = N_Object_Declaration
3032 Append_New_Elmt
(Defining_Entity
(Decl
), States_And_Objs
);
3038 end Collect_States_And_Objects
;
3042 Inits
: constant Node_Id
:= Expression
(Get_Argument
(N
, Pack_Id
));
3045 -- Start of processing for Analyze_Initializes_In_Decl_Part
3048 -- Do not analyze the pragma multiple times
3050 if Is_Analyzed_Pragma
(N
) then
3054 -- Nothing to do when the initialization list is empty
3056 if Nkind
(Inits
) = N_Null
then
3060 -- Single and multiple initialization clauses appear as an aggregate. If
3061 -- this is not the case, then either the parser or the analysis of the
3062 -- pragma failed to produce an aggregate.
3064 pragma Assert
(Nkind
(Inits
) = N_Aggregate
);
3066 -- Initialize the various lists used during analysis
3068 Collect_States_And_Objects
;
3070 if Present
(Expressions
(Inits
)) then
3071 Init
:= First
(Expressions
(Inits
));
3072 while Present
(Init
) loop
3073 Analyze_Initialization_Item
(Init
);
3078 if Present
(Component_Associations
(Inits
)) then
3079 Init
:= First
(Component_Associations
(Inits
));
3080 while Present
(Init
) loop
3081 Analyze_Initialization_Item_With_Inputs
(Init
);
3086 -- Ensure that a state and a corresponding constituent do not appear
3087 -- together in pragma Initializes.
3089 Check_State_And_Constituent_Use
3090 (States
=> States_Seen
,
3091 Constits
=> Constits_Seen
,
3094 Set_Is_Analyzed_Pragma
(N
);
3095 end Analyze_Initializes_In_Decl_Part
;
3097 ---------------------
3098 -- Analyze_Part_Of --
3099 ---------------------
3101 procedure Analyze_Part_Of
3103 Item_Id
: Entity_Id
;
3105 Encap_Id
: out Entity_Id
;
3106 Legal
: out Boolean)
3108 Encap_Typ
: Entity_Id
;
3109 Item_Decl
: Node_Id
;
3110 Pack_Id
: Entity_Id
;
3111 Placement
: State_Space_Kind
;
3112 Parent_Unit
: Entity_Id
;
3115 -- Assume that the indicator is illegal
3120 if Nkind_In
(Encap
, N_Expanded_Name
,
3122 N_Selected_Component
)
3125 Resolve_State
(Encap
);
3127 Encap_Id
:= Entity
(Encap
);
3129 -- The encapsulator is an abstract state
3131 if Ekind
(Encap_Id
) = E_Abstract_State
then
3134 -- The encapsulator is a single concurrent type (SPARK RM 9.3)
3136 elsif Is_Single_Concurrent_Object
(Encap_Id
) then
3139 -- Otherwise the encapsulator is not a legal choice
3143 ("indicator Part_Of must denote abstract state, single "
3144 & "protected type or single task type", Encap
);
3148 -- This is a syntax error, always report
3152 ("indicator Part_Of must denote abstract state, single protected "
3153 & "type or single task type", Encap
);
3157 -- Catch a case where indicator Part_Of denotes the abstract view of a
3158 -- variable which appears as an abstract state (SPARK RM 10.1.2 2).
3160 if From_Limited_With
(Encap_Id
)
3161 and then Present
(Non_Limited_View
(Encap_Id
))
3162 and then Ekind
(Non_Limited_View
(Encap_Id
)) = E_Variable
3164 SPARK_Msg_N
("indicator Part_Of must denote abstract state", Encap
);
3165 SPARK_Msg_N
("\& denotes abstract view of object", Encap
);
3169 -- The encapsulator is an abstract state
3171 if Ekind
(Encap_Id
) = E_Abstract_State
then
3173 -- Determine where the object, package instantiation or state lives
3174 -- with respect to the enclosing packages or package bodies.
3176 Find_Placement_In_State_Space
3177 (Item_Id
=> Item_Id
,
3178 Placement
=> Placement
,
3179 Pack_Id
=> Pack_Id
);
3181 -- The item appears in a non-package construct with a declarative
3182 -- part (subprogram, block, etc). As such, the item is not allowed
3183 -- to be a part of an encapsulating state because the item is not
3186 if Placement
= Not_In_Package
then
3188 ("indicator Part_Of cannot appear in this context "
3189 & "(SPARK RM 7.2.6(5))", Indic
);
3190 Error_Msg_Name_1
:= Chars
(Scope
(Encap_Id
));
3192 ("\& is not part of the hidden state of package %",
3195 -- The item appears in the visible state space of some package. In
3196 -- general this scenario does not warrant Part_Of except when the
3197 -- package is a private child unit and the encapsulating state is
3198 -- declared in a parent unit or a public descendant of that parent
3201 elsif Placement
= Visible_State_Space
then
3202 if Is_Child_Unit
(Pack_Id
)
3203 and then Is_Private_Descendant
(Pack_Id
)
3205 -- A variable or state abstraction which is part of the visible
3206 -- state of a private child unit (or one of its public
3207 -- descendants) must have its Part_Of indicator specified. The
3208 -- Part_Of indicator must denote a state abstraction declared
3209 -- by either the parent unit of the private unit or by a public
3210 -- descendant of that parent unit.
3212 -- Find nearest private ancestor (which can be the current unit
3215 Parent_Unit
:= Pack_Id
;
3216 while Present
(Parent_Unit
) loop
3219 (Parent
(Unit_Declaration_Node
(Parent_Unit
)));
3220 Parent_Unit
:= Scope
(Parent_Unit
);
3223 Parent_Unit
:= Scope
(Parent_Unit
);
3225 if not Is_Child_Or_Sibling
(Pack_Id
, Scope
(Encap_Id
)) then
3227 ("indicator Part_Of must denote abstract state or public "
3228 & "descendant of & (SPARK RM 7.2.6(3))",
3229 Indic
, Parent_Unit
);
3231 elsif Scope
(Encap_Id
) = Parent_Unit
3233 (Is_Ancestor_Package
(Parent_Unit
, Scope
(Encap_Id
))
3234 and then not Is_Private_Descendant
(Scope
(Encap_Id
)))
3240 ("indicator Part_Of must denote abstract state or public "
3241 & "descendant of & (SPARK RM 7.2.6(3))",
3242 Indic
, Parent_Unit
);
3245 -- Indicator Part_Of is not needed when the related package is not
3246 -- a private child unit or a public descendant thereof.
3250 ("indicator Part_Of cannot appear in this context "
3251 & "(SPARK RM 7.2.6(5))", Indic
);
3252 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3254 ("\& is declared in the visible part of package %",
3258 -- When the item appears in the private state space of a package, the
3259 -- encapsulating state must be declared in the same package.
3261 elsif Placement
= Private_State_Space
then
3262 if Scope
(Encap_Id
) /= Pack_Id
then
3264 ("indicator Part_Of must designate an abstract state of "
3265 & "package & (SPARK RM 7.2.6(2))", Indic
, Pack_Id
);
3266 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3268 ("\& is declared in the private part of package %",
3272 -- Items declared in the body state space of a package do not need
3273 -- Part_Of indicators as the refinement has already been seen.
3277 ("indicator Part_Of cannot appear in this context "
3278 & "(SPARK RM 7.2.6(5))", Indic
);
3280 if Scope
(Encap_Id
) = Pack_Id
then
3281 Error_Msg_Name_1
:= Chars
(Pack_Id
);
3283 ("\& is declared in the body of package %", Indic
, Item_Id
);
3287 -- The encapsulator is a single concurrent type
3290 Encap_Typ
:= Etype
(Encap_Id
);
3292 -- Only abstract states and variables can act as constituents of an
3293 -- encapsulating single concurrent type.
3295 if Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
3298 -- The constituent is a constant
3300 elsif Ekind
(Item_Id
) = E_Constant
then
3301 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3303 (Fix_Msg
(Encap_Typ
, "constant & cannot act as constituent of "
3304 & "single protected type %"), Indic
, Item_Id
);
3306 -- The constituent is a package instantiation
3309 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3311 (Fix_Msg
(Encap_Typ
, "package instantiation & cannot act as "
3312 & "constituent of single protected type %"), Indic
, Item_Id
);
3315 -- When the item denotes an abstract state of a nested package, use
3316 -- the declaration of the package to detect proper placement.
3321 -- with Abstract_State => (State with Part_Of => T)
3323 if Ekind
(Item_Id
) = E_Abstract_State
then
3324 Item_Decl
:= Unit_Declaration_Node
(Scope
(Item_Id
));
3326 Item_Decl
:= Declaration_Node
(Item_Id
);
3329 -- Both the item and its encapsulating single concurrent type must
3330 -- appear in the same declarative region (SPARK RM 9.3). Note that
3331 -- privacy is ignored.
3333 if Parent
(Item_Decl
) /= Parent
(Declaration_Node
(Encap_Id
)) then
3334 Error_Msg_Name_1
:= Chars
(Encap_Id
);
3336 (Fix_Msg
(Encap_Typ
, "constituent & must be declared "
3337 & "immediately within the same region as single protected "
3338 & "type %"), Indic
, Item_Id
);
3343 end Analyze_Part_Of
;
3345 ----------------------------------
3346 -- Analyze_Part_Of_In_Decl_Part --
3347 ----------------------------------
3349 procedure Analyze_Part_Of_In_Decl_Part
3351 Freeze_Id
: Entity_Id
:= Empty
)
3353 Encap
: constant Node_Id
:=
3354 Get_Pragma_Arg
(First
(Pragma_Argument_Associations
(N
)));
3355 Errors
: constant Nat
:= Serious_Errors_Detected
;
3356 Var_Decl
: constant Node_Id
:= Find_Related_Context
(N
);
3357 Var_Id
: constant Entity_Id
:= Defining_Entity
(Var_Decl
);
3358 Constits
: Elist_Id
;
3359 Encap_Id
: Entity_Id
;
3363 -- Detect any discrepancies between the placement of the variable with
3364 -- respect to general state space and the encapsulating state or single
3371 Encap_Id
=> Encap_Id
,
3374 -- The Part_Of indicator turns the variable into a constituent of the
3375 -- encapsulating state or single concurrent type.
3378 pragma Assert
(Present
(Encap_Id
));
3379 Constits
:= Part_Of_Constituents
(Encap_Id
);
3381 if No
(Constits
) then
3382 Constits
:= New_Elmt_List
;
3383 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
3386 Append_Elmt
(Var_Id
, Constits
);
3387 Set_Encapsulating_State
(Var_Id
, Encap_Id
);
3389 -- A Part_Of constituent partially refines an abstract state. This
3390 -- property does not apply to protected or task units.
3392 if Ekind
(Encap_Id
) = E_Abstract_State
then
3393 Set_Has_Partial_Visible_Refinement
(Encap_Id
);
3397 -- Emit a clarification message when the encapsulator is undefined,
3398 -- possibly due to contract "freezing".
3400 if Errors
/= Serious_Errors_Detected
3401 and then Present
(Freeze_Id
)
3402 and then Has_Undefined_Reference
(Encap
)
3404 Contract_Freeze_Error
(Var_Id
, Freeze_Id
);
3406 end Analyze_Part_Of_In_Decl_Part
;
3408 --------------------
3409 -- Analyze_Pragma --
3410 --------------------
3412 procedure Analyze_Pragma
(N
: Node_Id
) is
3413 Loc
: constant Source_Ptr
:= Sloc
(N
);
3415 Pname
: Name_Id
:= Pragma_Name
(N
);
3416 -- Name of the source pragma, or name of the corresponding aspect for
3417 -- pragmas which originate in a source aspect. In the latter case, the
3418 -- name may be different from the pragma name.
3420 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
3422 Pragma_Exit
: exception;
3423 -- This exception is used to exit pragma processing completely. It
3424 -- is used when an error is detected, and no further processing is
3425 -- required. It is also used if an earlier error has left the tree in
3426 -- a state where the pragma should not be processed.
3429 -- Number of pragma argument associations
3435 -- First four pragma arguments (pragma argument association nodes, or
3436 -- Empty if the corresponding argument does not exist).
3438 type Name_List
is array (Natural range <>) of Name_Id
;
3439 type Args_List
is array (Natural range <>) of Node_Id
;
3440 -- Types used for arguments to Check_Arg_Order and Gather_Associations
3442 -----------------------
3443 -- Local Subprograms --
3444 -----------------------
3446 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
);
3447 -- Used by pragma Warnings (Off, string), and Warn_As_Error (string) to
3448 -- get the given string argument, and place it in Name_Buffer, adding
3449 -- leading and trailing asterisks if they are not already present. The
3450 -- caller has already checked that Arg is a static string expression.
3452 procedure Ada_2005_Pragma
;
3453 -- Called for pragmas defined in Ada 2005, that are not in Ada 95. In
3454 -- Ada 95 mode, these are implementation defined pragmas, so should be
3455 -- caught by the No_Implementation_Pragmas restriction.
3457 procedure Ada_2012_Pragma
;
3458 -- Called for pragmas defined in Ada 2012, that are not in Ada 95 or 05.
3459 -- In Ada 95 or 05 mode, these are implementation defined pragmas, so
3460 -- should be caught by the No_Implementation_Pragmas restriction.
3462 procedure Analyze_Depends_Global
3463 (Spec_Id
: out Entity_Id
;
3464 Subp_Decl
: out Node_Id
;
3465 Legal
: out Boolean);
3466 -- Subsidiary to the analysis of pragmas Depends and Global. Verify the
3467 -- legality of the placement and related context of the pragma. Spec_Id
3468 -- is the entity of the related subprogram. Subp_Decl is the declaration
3469 -- of the related subprogram. Sets flag Legal when the pragma is legal.
3471 procedure Analyze_If_Present
(Id
: Pragma_Id
);
3472 -- Inspect the remainder of the list containing pragma N and look for
3473 -- a pragma that matches Id. If found, analyze the pragma.
3475 procedure Analyze_Pre_Post_Condition
;
3476 -- Subsidiary to the analysis of pragmas Precondition and Postcondition
3478 procedure Analyze_Refined_Depends_Global_Post
3479 (Spec_Id
: out Entity_Id
;
3480 Body_Id
: out Entity_Id
;
3481 Legal
: out Boolean);
3482 -- Subsidiary routine to the analysis of body pragmas Refined_Depends,
3483 -- Refined_Global and Refined_Post. Verify the legality of the placement
3484 -- and related context of the pragma. Spec_Id is the entity of the
3485 -- related subprogram. Body_Id is the entity of the subprogram body.
3486 -- Flag Legal is set when the pragma is legal.
3488 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False);
3489 -- Perform full analysis of pragma Unmodified and the write aspect of
3490 -- pragma Unused. Flag Is_Unused should be set when verifying the
3491 -- semantics of pragma Unused.
3493 procedure Analyze_Unreferenced_Or_Unused
(Is_Unused
: Boolean := False);
3494 -- Perform full analysis of pragma Unreferenced and the read aspect of
3495 -- pragma Unused. Flag Is_Unused should be set when verifying the
3496 -- semantics of pragma Unused.
3498 procedure Check_Ada_83_Warning
;
3499 -- Issues a warning message for the current pragma if operating in Ada
3500 -- 83 mode (used for language pragmas that are not a standard part of
3501 -- Ada 83). This procedure does not raise Pragma_Exit. Also notes use
3504 procedure Check_Arg_Count
(Required
: Nat
);
3505 -- Check argument count for pragma is equal to given parameter. If not,
3506 -- then issue an error message and raise Pragma_Exit.
3508 -- Note: all routines whose name is Check_Arg_Is_xxx take an argument
3509 -- Arg which can either be a pragma argument association, in which case
3510 -- the check is applied to the expression of the association or an
3511 -- expression directly.
3513 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
);
3514 -- Check that an argument has the right form for an EXTERNAL_NAME
3515 -- parameter of an extended import/export pragma. The rule is that the
3516 -- name must be an identifier or string literal (in Ada 83 mode) or a
3517 -- static string expression (in Ada 95 mode).
3519 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
);
3520 -- Check the specified argument Arg to make sure that it is an
3521 -- identifier. If not give error and raise Pragma_Exit.
3523 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
);
3524 -- Check the specified argument Arg to make sure that it is an integer
3525 -- literal. If not give error and raise Pragma_Exit.
3527 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
);
3528 -- Check the specified argument Arg to make sure that it has the proper
3529 -- syntactic form for a local name and meets the semantic requirements
3530 -- for a local name. The local name is analyzed as part of the
3531 -- processing for this call. In addition, the local name is required
3532 -- to represent an entity at the library level.
3534 procedure Check_Arg_Is_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.
3540 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
);
3541 -- Check the specified argument Arg to make sure that it is a valid
3542 -- locking policy name. If not give error and raise Pragma_Exit.
3544 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
);
3545 -- Check the specified argument Arg to make sure that it is a valid
3546 -- elaboration policy name. If not give error and raise Pragma_Exit.
3548 procedure Check_Arg_Is_One_Of
3551 procedure Check_Arg_Is_One_Of
3553 N1
, N2
, N3
: Name_Id
);
3554 procedure Check_Arg_Is_One_Of
3556 N1
, N2
, N3
, N4
: Name_Id
);
3557 procedure Check_Arg_Is_One_Of
3559 N1
, N2
, N3
, N4
, N5
: Name_Id
);
3560 -- Check the specified argument Arg to make sure that it is an
3561 -- identifier whose name matches either N1 or N2 (or N3, N4, N5 if
3562 -- present). If not then give error and raise Pragma_Exit.
3564 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
);
3565 -- Check the specified argument Arg to make sure that it is a valid
3566 -- queuing policy name. If not give error and raise Pragma_Exit.
3568 procedure Check_Arg_Is_OK_Static_Expression
3570 Typ
: Entity_Id
:= Empty
);
3571 -- Check the specified argument Arg to make sure that it is a static
3572 -- expression of the given type (i.e. it will be analyzed and resolved
3573 -- using this type, which can be any valid argument to Resolve, e.g.
3574 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3575 -- Typ is left Empty, then any static expression is allowed. Includes
3576 -- checking that the argument does not raise Constraint_Error.
3578 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
);
3579 -- Check the specified argument Arg to make sure that it is a valid task
3580 -- dispatching policy name. If not give error and raise Pragma_Exit.
3582 procedure Check_Arg_Order
(Names
: Name_List
);
3583 -- Checks for an instance of two arguments with identifiers for the
3584 -- current pragma which are not in the sequence indicated by Names,
3585 -- and if so, generates a fatal message about bad order of arguments.
3587 procedure Check_At_Least_N_Arguments
(N
: Nat
);
3588 -- Check there are at least N arguments present
3590 procedure Check_At_Most_N_Arguments
(N
: Nat
);
3591 -- Check there are no more than N arguments present
3593 procedure Check_Component
3596 In_Variant_Part
: Boolean := False);
3597 -- Examine an Unchecked_Union component for correct use of per-object
3598 -- constrained subtypes, and for restrictions on finalizable components.
3599 -- UU_Typ is the related Unchecked_Union type. Flag In_Variant_Part
3600 -- should be set when Comp comes from a record variant.
3602 procedure Check_Duplicate_Pragma
(E
: Entity_Id
);
3603 -- Check if a rep item of the same name as the current pragma is already
3604 -- chained as a rep pragma to the given entity. If so give a message
3605 -- about the duplicate, and then raise Pragma_Exit so does not return.
3606 -- Note that if E is a type, then this routine avoids flagging a pragma
3607 -- which applies to a parent type from which E is derived.
3609 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
);
3610 -- Nam is an N_String_Literal node containing the external name set by
3611 -- an Import or Export pragma (or extended Import or Export pragma).
3612 -- This procedure checks for possible duplications if this is the export
3613 -- case, and if found, issues an appropriate error message.
3615 procedure Check_Expr_Is_OK_Static_Expression
3617 Typ
: Entity_Id
:= Empty
);
3618 -- Check the specified expression Expr to make sure that it is a static
3619 -- expression of the given type (i.e. it will be analyzed and resolved
3620 -- using this type, which can be any valid argument to Resolve, e.g.
3621 -- Any_Integer is OK). If not, given error and raise Pragma_Exit. If
3622 -- Typ is left Empty, then any static expression is allowed. Includes
3623 -- checking that the expression does not raise Constraint_Error.
3625 procedure Check_First_Subtype
(Arg
: Node_Id
);
3626 -- Checks that Arg, whose expression is an entity name, references a
3629 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3630 -- Checks that the given argument has an identifier, and if so, requires
3631 -- it to match the given identifier name. If there is no identifier, or
3632 -- a non-matching identifier, then an error message is given and
3633 -- Pragma_Exit is raised.
3635 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
);
3636 -- Checks that the given argument has an identifier, and if so, requires
3637 -- it to match one of the given identifier names. If there is no
3638 -- identifier, or a non-matching identifier, then an error message is
3639 -- given and Pragma_Exit is raised.
3641 procedure Check_In_Main_Program
;
3642 -- Common checks for pragmas that appear within a main program
3643 -- (Priority, Main_Storage, Time_Slice, Relative_Deadline, CPU).
3645 procedure Check_Interrupt_Or_Attach_Handler
;
3646 -- Common processing for first argument of pragma Interrupt_Handler or
3647 -- pragma Attach_Handler.
3649 procedure Check_Loop_Pragma_Placement
;
3650 -- Verify whether pragmas Loop_Invariant, Loop_Optimize and Loop_Variant
3651 -- appear immediately within a construct restricted to loops, and that
3652 -- pragmas Loop_Invariant and Loop_Variant are grouped together.
3654 procedure Check_Is_In_Decl_Part_Or_Package_Spec
;
3655 -- Check that pragma appears in a declarative part, or in a package
3656 -- specification, i.e. that it does not occur in a statement sequence
3659 procedure Check_No_Identifier
(Arg
: Node_Id
);
3660 -- Checks that the given argument does not have an identifier. If
3661 -- an identifier is present, then an error message is issued, and
3662 -- Pragma_Exit is raised.
3664 procedure Check_No_Identifiers
;
3665 -- Checks that none of the arguments to the pragma has an identifier.
3666 -- If any argument has an identifier, then an error message is issued,
3667 -- and Pragma_Exit is raised.
3669 procedure Check_No_Link_Name
;
3670 -- Checks that no link name is specified
3672 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
);
3673 -- Checks if the given argument has an identifier, and if so, requires
3674 -- it to match the given identifier name. If there is a non-matching
3675 -- identifier, then an error message is given and Pragma_Exit is raised.
3677 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String);
3678 -- Checks if the given argument has an identifier, and if so, requires
3679 -- it to match the given identifier name. If there is a non-matching
3680 -- identifier, then an error message is given and Pragma_Exit is raised.
3681 -- In this version of the procedure, the identifier name is given as
3682 -- a string with lower case letters.
3684 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
);
3685 -- Subsidiary to the analysis of pragmas Async_Readers, Async_Writers,
3686 -- Constant_After_Elaboration, Effective_Reads, Effective_Writes,
3687 -- Extensions_Visible and Volatile_Function. Ensure that expression Expr
3688 -- is an OK static boolean expression. Emit an error if this is not the
3691 procedure Check_Static_Constraint
(Constr
: Node_Id
);
3692 -- Constr is a constraint from an N_Subtype_Indication node from a
3693 -- component constraint in an Unchecked_Union type. This routine checks
3694 -- that the constraint is static as required by the restrictions for
3697 procedure Check_Valid_Configuration_Pragma
;
3698 -- Legality checks for placement of a configuration pragma
3700 procedure Check_Valid_Library_Unit_Pragma
;
3701 -- Legality checks for library unit pragmas. A special case arises for
3702 -- pragmas in generic instances that come from copies of the original
3703 -- library unit pragmas in the generic templates. In the case of other
3704 -- than library level instantiations these can appear in contexts which
3705 -- would normally be invalid (they only apply to the original template
3706 -- and to library level instantiations), and they are simply ignored,
3707 -- which is implemented by rewriting them as null statements.
3709 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
);
3710 -- Check an Unchecked_Union variant for lack of nested variants and
3711 -- presence of at least one component. UU_Typ is the related Unchecked_
3714 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
);
3715 -- Subsidiary routine to the processing of pragmas Abstract_State,
3716 -- Contract_Cases, Depends, Global, Initializes, Refined_Depends,
3717 -- Refined_Global and Refined_State. Transform argument Arg into
3718 -- an aggregate if not one already. N_Null is never transformed.
3719 -- Arg may denote an aspect specification or a pragma argument
3722 procedure Error_Pragma
(Msg
: String);
3723 pragma No_Return
(Error_Pragma
);
3724 -- Outputs error message for current pragma. The message contains a %
3725 -- that will be replaced with the pragma name, and the flag is placed
3726 -- on the pragma itself. Pragma_Exit is then raised. Note: this routine
3727 -- calls Fix_Error (see spec of that procedure for details).
3729 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
);
3730 pragma No_Return
(Error_Pragma_Arg
);
3731 -- Outputs error message for current pragma. The message may contain
3732 -- a % that will be replaced with the pragma name. The parameter Arg
3733 -- may either be a pragma argument association, in which case the flag
3734 -- is placed on the expression of this association, or an expression,
3735 -- in which case the flag is placed directly on the expression. The
3736 -- message is placed using Error_Msg_N, so the message may also contain
3737 -- an & insertion character which will reference the given Arg value.
3738 -- After placing the message, Pragma_Exit is raised. Note: this routine
3739 -- calls Fix_Error (see spec of that procedure for details).
3741 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
);
3742 pragma No_Return
(Error_Pragma_Arg
);
3743 -- Similar to above form of Error_Pragma_Arg except that two messages
3744 -- are provided, the second is a continuation comment starting with \.
3746 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
);
3747 pragma No_Return
(Error_Pragma_Arg_Ident
);
3748 -- Outputs error message for current pragma. The message may contain a %
3749 -- that will be replaced with the pragma name. The parameter Arg must be
3750 -- a pragma argument association with a non-empty identifier (i.e. its
3751 -- Chars field must be set), and the error message is placed on the
3752 -- identifier. The message is placed using Error_Msg_N so the message
3753 -- may also contain an & insertion character which will reference
3754 -- the identifier. After placing the message, Pragma_Exit is raised.
3755 -- Note: this routine calls Fix_Error (see spec of that procedure for
3758 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
);
3759 pragma No_Return
(Error_Pragma_Ref
);
3760 -- Outputs error message for current pragma. The message may contain
3761 -- a % that will be replaced with the pragma name. The parameter Ref
3762 -- must be an entity whose name can be referenced by & and sloc by #.
3763 -- After placing the message, Pragma_Exit is raised. Note: this routine
3764 -- calls Fix_Error (see spec of that procedure for details).
3766 function Find_Lib_Unit_Name
return Entity_Id
;
3767 -- Used for a library unit pragma to find the entity to which the
3768 -- library unit pragma applies, returns the entity found.
3770 procedure Find_Program_Unit_Name
(Id
: Node_Id
);
3771 -- If the pragma is a compilation unit pragma, the id must denote the
3772 -- compilation unit in the same compilation, and the pragma must appear
3773 -- in the list of preceding or trailing pragmas. If it is a program
3774 -- unit pragma that is not a compilation unit pragma, then the
3775 -- identifier must be visible.
3777 function Find_Unique_Parameterless_Procedure
3779 Arg
: Node_Id
) return Entity_Id
;
3780 -- Used for a procedure pragma to find the unique parameterless
3781 -- procedure identified by Name, returns it if it exists, otherwise
3782 -- errors out and uses Arg as the pragma argument for the message.
3784 function Fix_Error
(Msg
: String) return String;
3785 -- This is called prior to issuing an error message. Msg is the normal
3786 -- error message issued in the pragma case. This routine checks for the
3787 -- case of a pragma coming from an aspect in the source, and returns a
3788 -- message suitable for the aspect case as follows:
3790 -- Each substring "pragma" is replaced by "aspect"
3792 -- If "argument of" is at the start of the error message text, it is
3793 -- replaced by "entity for".
3795 -- If "argument" is at the start of the error message text, it is
3796 -- replaced by "entity".
3798 -- So for example, "argument of pragma X must be discrete type"
3799 -- returns "entity for aspect X must be a discrete type".
3801 -- Finally Error_Msg_Name_1 is set to the name of the aspect (which may
3802 -- be different from the pragma name). If the current pragma results
3803 -- from rewriting another pragma, then Error_Msg_Name_1 is set to the
3804 -- original pragma name.
3806 procedure Gather_Associations
3808 Args
: out Args_List
);
3809 -- This procedure is used to gather the arguments for a pragma that
3810 -- permits arbitrary ordering of parameters using the normal rules
3811 -- for named and positional parameters. The Names argument is a list
3812 -- of Name_Id values that corresponds to the allowed pragma argument
3813 -- association identifiers in order. The result returned in Args is
3814 -- a list of corresponding expressions that are the pragma arguments.
3815 -- Note that this is a list of expressions, not of pragma argument
3816 -- associations (Gather_Associations has completely checked all the
3817 -- optional identifiers when it returns). An entry in Args is Empty
3818 -- on return if the corresponding argument is not present.
3820 procedure GNAT_Pragma
;
3821 -- Called for all GNAT defined pragmas to check the relevant restriction
3822 -- (No_Implementation_Pragmas).
3824 function Is_Before_First_Decl
3825 (Pragma_Node
: Node_Id
;
3826 Decls
: List_Id
) return Boolean;
3827 -- Return True if Pragma_Node is before the first declarative item in
3828 -- Decls where Decls is the list of declarative items.
3830 function Is_Configuration_Pragma
return Boolean;
3831 -- Determines if the placement of the current pragma is appropriate
3832 -- for a configuration pragma.
3834 function Is_In_Context_Clause
return Boolean;
3835 -- Returns True if pragma appears within the context clause of a unit,
3836 -- and False for any other placement (does not generate any messages).
3838 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean;
3839 -- Analyzes the argument, and determines if it is a static string
3840 -- expression, returns True if so, False if non-static or not String.
3841 -- A special case is that a string literal returns True in Ada 83 mode
3842 -- (which has no such thing as static string expressions). Note that
3843 -- the call analyzes its argument, so this cannot be used for the case
3844 -- where an identifier might not be declared.
3846 procedure Pragma_Misplaced
;
3847 pragma No_Return
(Pragma_Misplaced
);
3848 -- Issue fatal error message for misplaced pragma
3850 procedure Process_Atomic_Independent_Shared_Volatile
;
3851 -- Common processing for pragmas Atomic, Independent, Shared, Volatile,
3852 -- Volatile_Full_Access. Note that Shared is an obsolete Ada 83 pragma
3853 -- and treated as being identical in effect to pragma Atomic.
3855 procedure Process_Compile_Time_Warning_Or_Error
;
3856 -- Common processing for Compile_Time_Error and Compile_Time_Warning
3858 procedure Process_Convention
3859 (C
: out Convention_Id
;
3860 Ent
: out Entity_Id
);
3861 -- Common processing for Convention, Interface, Import and Export.
3862 -- Checks first two arguments of pragma, and sets the appropriate
3863 -- convention value in the specified entity or entities. On return
3864 -- C is the convention, Ent is the referenced entity.
3866 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
);
3867 -- Common processing for Disable/Enable_Atomic_Synchronization. Nam is
3868 -- Name_Suppress for Disable and Name_Unsuppress for Enable.
3870 procedure Process_Extended_Import_Export_Object_Pragma
3871 (Arg_Internal
: Node_Id
;
3872 Arg_External
: Node_Id
;
3873 Arg_Size
: Node_Id
);
3874 -- Common processing for the pragmas Import/Export_Object. The three
3875 -- arguments correspond to the three named parameters of the pragmas. An
3876 -- argument is empty if the corresponding parameter is not present in
3879 procedure Process_Extended_Import_Export_Internal_Arg
3880 (Arg_Internal
: Node_Id
:= Empty
);
3881 -- Common processing for all extended Import and Export pragmas. The
3882 -- argument is the pragma parameter for the Internal argument. If
3883 -- Arg_Internal is empty or inappropriate, an error message is posted.
3884 -- Otherwise, on normal return, the Entity_Field of Arg_Internal is
3885 -- set to identify the referenced entity.
3887 procedure Process_Extended_Import_Export_Subprogram_Pragma
3888 (Arg_Internal
: Node_Id
;
3889 Arg_External
: Node_Id
;
3890 Arg_Parameter_Types
: Node_Id
;
3891 Arg_Result_Type
: Node_Id
:= Empty
;
3892 Arg_Mechanism
: Node_Id
;
3893 Arg_Result_Mechanism
: Node_Id
:= Empty
);
3894 -- Common processing for all extended Import and Export pragmas applying
3895 -- to subprograms. The caller omits any arguments that do not apply to
3896 -- the pragma in question (for example, Arg_Result_Type can be non-Empty
3897 -- only in the Import_Function and Export_Function cases). The argument
3898 -- names correspond to the allowed pragma association identifiers.
3900 procedure Process_Generic_List
;
3901 -- Common processing for Share_Generic and Inline_Generic
3903 procedure Process_Import_Or_Interface
;
3904 -- Common processing for Import or Interface
3906 procedure Process_Import_Predefined_Type
;
3907 -- Processing for completing a type with pragma Import. This is used
3908 -- to declare types that match predefined C types, especially for cases
3909 -- without corresponding Ada predefined type.
3911 type Inline_Status
is (Suppressed
, Disabled
, Enabled
);
3912 -- Inline status of a subprogram, indicated as follows:
3913 -- Suppressed: inlining is suppressed for the subprogram
3914 -- Disabled: no inlining is requested for the subprogram
3915 -- Enabled: inlining is requested/required for the subprogram
3917 procedure Process_Inline
(Status
: Inline_Status
);
3918 -- Common processing for No_Inline, Inline and Inline_Always. Parameter
3919 -- indicates the inline status specified by the pragma.
3921 procedure Process_Interface_Name
3922 (Subprogram_Def
: Entity_Id
;
3926 -- Given the last two arguments of pragma Import, pragma Export, or
3927 -- pragma Interface_Name, performs validity checks and sets the
3928 -- Interface_Name field of the given subprogram entity to the
3929 -- appropriate external or link name, depending on the arguments given.
3930 -- Ext_Arg is always present, but Link_Arg may be missing. Note that
3931 -- Ext_Arg may represent the Link_Name if Link_Arg is missing, and
3932 -- appropriate named notation is used for Ext_Arg. If neither Ext_Arg
3933 -- nor Link_Arg is present, the interface name is set to the default
3934 -- from the subprogram name. In addition, the pragma itself is passed
3935 -- to analyze any expressions in the case the pragma came from an aspect
3938 procedure Process_Interrupt_Or_Attach_Handler
;
3939 -- Common processing for Interrupt and Attach_Handler pragmas
3941 procedure Process_Restrictions_Or_Restriction_Warnings
(Warn
: Boolean);
3942 -- Common processing for Restrictions and Restriction_Warnings pragmas.
3943 -- Warn is True for Restriction_Warnings, or for Restrictions if the
3944 -- flag Treat_Restrictions_As_Warnings is set, and False if this flag
3945 -- is not set in the Restrictions case.
3947 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean);
3948 -- Common processing for Suppress and Unsuppress. The boolean parameter
3949 -- Suppress_Case is True for the Suppress case, and False for the
3952 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
);
3953 -- Subsidiary to the analysis of pragmas Independent[_Components].
3954 -- Record such a pragma N applied to entity E for future checks.
3956 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
);
3957 -- This procedure sets the Is_Exported flag for the given entity,
3958 -- checking that the entity was not previously imported. Arg is
3959 -- the argument that specified the entity. A check is also made
3960 -- for exporting inappropriate entities.
3962 procedure Set_Extended_Import_Export_External_Name
3963 (Internal_Ent
: Entity_Id
;
3964 Arg_External
: Node_Id
);
3965 -- Common processing for all extended import export pragmas. The first
3966 -- argument, Internal_Ent, is the internal entity, which has already
3967 -- been checked for validity by the caller. Arg_External is from the
3968 -- Import or Export pragma, and may be null if no External parameter
3969 -- was present. If Arg_External is present and is a non-null string
3970 -- (a null string is treated as the default), then the Interface_Name
3971 -- field of Internal_Ent is set appropriately.
3973 procedure Set_Imported
(E
: Entity_Id
);
3974 -- This procedure sets the Is_Imported flag for the given entity,
3975 -- checking that it is not previously exported or imported.
3977 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
);
3978 -- Mech is a parameter passing mechanism (see Import_Function syntax
3979 -- for MECHANISM_NAME). This routine checks that the mechanism argument
3980 -- has the right form, and if not issues an error message. If the
3981 -- argument has the right form then the Mechanism field of Ent is
3982 -- set appropriately.
3984 procedure Set_Rational_Profile
;
3985 -- Activate the set of configuration pragmas and permissions that make
3986 -- up the Rational profile.
3988 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
);
3989 -- Activate the set of configuration pragmas and restrictions that make
3990 -- up the Profile. Profile must be either GNAT_Extended_Ravenscar,
3991 -- GNAT_Ravenscar_EDF, or Ravenscar. N is the corresponding pragma node,
3992 -- which is used for error messages on any constructs violating the
3995 ----------------------------------
3996 -- Acquire_Warning_Match_String --
3997 ----------------------------------
3999 procedure Acquire_Warning_Match_String
(Arg
: Node_Id
) is
4001 String_To_Name_Buffer
4002 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
4004 -- Add asterisk at start if not already there
4006 if Name_Len
> 0 and then Name_Buffer
(1) /= '*' then
4007 Name_Buffer
(2 .. Name_Len
+ 1) :=
4008 Name_Buffer
(1 .. Name_Len
);
4009 Name_Buffer
(1) := '*';
4010 Name_Len
:= Name_Len
+ 1;
4013 -- Add asterisk at end if not already there
4015 if Name_Buffer
(Name_Len
) /= '*' then
4016 Name_Len
:= Name_Len
+ 1;
4017 Name_Buffer
(Name_Len
) := '*';
4019 end Acquire_Warning_Match_String
;
4021 ---------------------
4022 -- Ada_2005_Pragma --
4023 ---------------------
4025 procedure Ada_2005_Pragma
is
4027 if Ada_Version
<= Ada_95
then
4028 Check_Restriction
(No_Implementation_Pragmas
, N
);
4030 end Ada_2005_Pragma
;
4032 ---------------------
4033 -- Ada_2012_Pragma --
4034 ---------------------
4036 procedure Ada_2012_Pragma
is
4038 if Ada_Version
<= Ada_2005
then
4039 Check_Restriction
(No_Implementation_Pragmas
, N
);
4041 end Ada_2012_Pragma
;
4043 ----------------------------
4044 -- Analyze_Depends_Global --
4045 ----------------------------
4047 procedure Analyze_Depends_Global
4048 (Spec_Id
: out Entity_Id
;
4049 Subp_Decl
: out Node_Id
;
4050 Legal
: out Boolean)
4053 -- Assume that the pragma is illegal
4060 Check_Arg_Count
(1);
4062 -- Ensure the proper placement of the pragma. Depends/Global must be
4063 -- associated with a subprogram declaration or a body that acts as a
4066 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4070 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4073 -- Generic subprogram
4075 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4078 -- Object declaration of a single concurrent type
4080 elsif Nkind
(Subp_Decl
) = N_Object_Declaration
then
4085 elsif Nkind
(Subp_Decl
) = N_Single_Task_Declaration
then
4088 -- Subprogram body acts as spec
4090 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4091 and then No
(Corresponding_Spec
(Subp_Decl
))
4095 -- Subprogram body stub acts as spec
4097 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4098 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
4102 -- Subprogram declaration
4104 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4109 elsif Nkind
(Subp_Decl
) = N_Task_Type_Declaration
then
4117 -- If we get here, then the pragma is legal
4120 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
4122 -- When the related context is an entry, the entry must belong to a
4123 -- protected unit (SPARK RM 6.1.4(6)).
4125 if Is_Entry_Declaration
(Spec_Id
)
4126 and then Ekind
(Scope
(Spec_Id
)) /= E_Protected_Type
4131 -- When the related context is an anonymous object created for a
4132 -- simple concurrent type, the type must be a task
4133 -- (SPARK RM 6.1.4(6)).
4135 elsif Is_Single_Concurrent_Object
(Spec_Id
)
4136 and then Ekind
(Etype
(Spec_Id
)) /= E_Task_Type
4142 -- A pragma that applies to a Ghost entity becomes Ghost for the
4143 -- purposes of legality checks and removal of ignored Ghost code.
4145 Mark_Ghost_Pragma
(N
, Spec_Id
);
4146 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4147 end Analyze_Depends_Global
;
4149 ------------------------
4150 -- Analyze_If_Present --
4151 ------------------------
4153 procedure Analyze_If_Present
(Id
: Pragma_Id
) is
4157 pragma Assert
(Is_List_Member
(N
));
4159 -- Inspect the declarations or statements following pragma N looking
4160 -- for another pragma whose Id matches the caller's request. If it is
4161 -- available, analyze it.
4164 while Present
(Stmt
) loop
4165 if Nkind
(Stmt
) = N_Pragma
and then Get_Pragma_Id
(Stmt
) = Id
then
4166 Analyze_Pragma
(Stmt
);
4169 -- The first source declaration or statement immediately following
4170 -- N ends the region where a pragma may appear.
4172 elsif Comes_From_Source
(Stmt
) then
4178 end Analyze_If_Present
;
4180 --------------------------------
4181 -- Analyze_Pre_Post_Condition --
4182 --------------------------------
4184 procedure Analyze_Pre_Post_Condition
is
4185 Prag_Iden
: constant Node_Id
:= Pragma_Identifier
(N
);
4186 Subp_Decl
: Node_Id
;
4187 Subp_Id
: Entity_Id
;
4189 Duplicates_OK
: Boolean := False;
4190 -- Flag set when a pre/postcondition allows multiple pragmas of the
4193 In_Body_OK
: Boolean := False;
4194 -- Flag set when a pre/postcondition is allowed to appear on a body
4195 -- even though the subprogram may have a spec.
4197 Is_Pre_Post
: Boolean := False;
4198 -- Flag set when the pragma is one of Pre, Pre_Class, Post or
4201 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean;
4202 -- Implement rules in AI12-0131: an overriding operation can have
4203 -- a class-wide precondition only if one of its ancestors has an
4204 -- explicit class-wide precondition.
4206 -----------------------------
4207 -- Inherits_Class_Wide_Pre --
4208 -----------------------------
4210 function Inherits_Class_Wide_Pre
(E
: Entity_Id
) return Boolean is
4211 Typ
: constant Entity_Id
:= Find_Dispatching_Type
(E
);
4214 Prev
: Entity_Id
:= Overridden_Operation
(E
);
4217 -- Check ancestors on the overriding operation to examine the
4218 -- preconditions that may apply to them.
4220 while Present
(Prev
) loop
4221 Cont
:= Contract
(Prev
);
4222 if Present
(Cont
) then
4223 Prag
:= Pre_Post_Conditions
(Cont
);
4224 while Present
(Prag
) loop
4225 if Class_Present
(Prag
) then
4229 Prag
:= Next_Pragma
(Prag
);
4233 -- For a type derived from a generic formal type, the operation
4234 -- inheriting the condition is a renaming, not an overriding of
4235 -- the operation of the formal. Ditto for an inherited
4236 -- operation which has no explicit contracts.
4238 if Is_Generic_Type
(Find_Dispatching_Type
(Prev
))
4239 or else not Comes_From_Source
(Prev
)
4241 Prev
:= Alias
(Prev
);
4243 Prev
:= Overridden_Operation
(Prev
);
4247 -- If the controlling type of the subprogram has progenitors, an
4248 -- interface operation implemented by the current operation may
4249 -- have a class-wide precondition.
4251 if Has_Interfaces
(Typ
) then
4256 Prim_Elmt
: Elmt_Id
;
4257 Prim_List
: Elist_Id
;
4260 Collect_Interfaces
(Typ
, Ints
);
4261 Elmt
:= First_Elmt
(Ints
);
4263 -- Iterate over the primitive operations of each interface
4265 while Present
(Elmt
) loop
4266 Prim_List
:= Direct_Primitive_Operations
(Node
(Elmt
));
4267 Prim_Elmt
:= First_Elmt
(Prim_List
);
4268 while Present
(Prim_Elmt
) loop
4269 Prim
:= Node
(Prim_Elmt
);
4270 if Chars
(Prim
) = Chars
(E
)
4271 and then Present
(Contract
(Prim
))
4272 and then Class_Present
4273 (Pre_Post_Conditions
(Contract
(Prim
)))
4278 Next_Elmt
(Prim_Elmt
);
4287 end Inherits_Class_Wide_Pre
;
4289 -- Start of processing for Analyze_Pre_Post_Condition
4292 -- Change the name of pragmas Pre, Pre_Class, Post and Post_Class to
4293 -- offer uniformity among the various kinds of pre/postconditions by
4294 -- rewriting the pragma identifier. This allows the retrieval of the
4295 -- original pragma name by routine Original_Aspect_Pragma_Name.
4297 if Comes_From_Source
(N
) then
4298 if Nam_In
(Pname
, Name_Pre
, Name_Pre_Class
) then
4299 Is_Pre_Post
:= True;
4300 Set_Class_Present
(N
, Pname
= Name_Pre_Class
);
4301 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Precondition
));
4303 elsif Nam_In
(Pname
, Name_Post
, Name_Post_Class
) then
4304 Is_Pre_Post
:= True;
4305 Set_Class_Present
(N
, Pname
= Name_Post_Class
);
4306 Rewrite
(Prag_Iden
, Make_Identifier
(Loc
, Name_Postcondition
));
4310 -- Determine the semantics with respect to duplicates and placement
4311 -- in a body. Pragmas Precondition and Postcondition were introduced
4312 -- before aspects and are not subject to the same aspect-like rules.
4314 if Nam_In
(Pname
, Name_Precondition
, Name_Postcondition
) then
4315 Duplicates_OK
:= True;
4321 -- Pragmas Pre, Pre_Class, Post and Post_Class allow for a single
4322 -- argument without an identifier.
4325 Check_Arg_Count
(1);
4326 Check_No_Identifiers
;
4328 -- Pragmas Precondition and Postcondition have complex argument
4332 Check_At_Least_N_Arguments
(1);
4333 Check_At_Most_N_Arguments
(2);
4334 Check_Optional_Identifier
(Arg1
, Name_Check
);
4336 if Present
(Arg2
) then
4337 Check_Optional_Identifier
(Arg2
, Name_Message
);
4338 Preanalyze_Spec_Expression
4339 (Get_Pragma_Arg
(Arg2
), Standard_String
);
4343 -- For a pragma PPC in the extended main source unit, record enabled
4345 -- ??? nothing checks that the pragma is in the main source unit
4347 if Is_Checked
(N
) and then not Split_PPC
(N
) then
4348 Set_SCO_Pragma_Enabled
(Loc
);
4351 -- Ensure the proper placement of the pragma
4354 Find_Related_Declaration_Or_Body
4355 (N
, Do_Checks
=> not Duplicates_OK
);
4357 -- When a pre/postcondition pragma applies to an abstract subprogram,
4358 -- its original form must be an aspect with 'Class.
4360 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
4361 if not From_Aspect_Specification
(N
) then
4363 ("pragma % cannot be applied to abstract subprogram");
4365 elsif not Class_Present
(N
) then
4367 ("aspect % requires ''Class for abstract subprogram");
4370 -- Entry declaration
4372 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
4375 -- Generic subprogram declaration
4377 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
4382 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
4383 and then (No
(Corresponding_Spec
(Subp_Decl
)) or In_Body_OK
)
4387 -- Subprogram body stub
4389 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
4390 and then (No
(Corresponding_Spec_Of_Stub
(Subp_Decl
)) or In_Body_OK
)
4394 -- Subprogram declaration
4396 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
4398 -- AI05-0230: When a pre/postcondition pragma applies to a null
4399 -- procedure, its original form must be an aspect with 'Class.
4401 if Nkind
(Specification
(Subp_Decl
)) = N_Procedure_Specification
4402 and then Null_Present
(Specification
(Subp_Decl
))
4403 and then From_Aspect_Specification
(N
)
4404 and then not Class_Present
(N
)
4406 Error_Pragma
("aspect % requires ''Class for null procedure");
4409 -- Implement the legality checks mandated by AI12-0131:
4410 -- Pre'Class shall not be specified for an overriding primitive
4411 -- subprogram of a tagged type T unless the Pre'Class aspect is
4412 -- specified for the corresponding primitive subprogram of some
4416 E
: constant Entity_Id
:= Defining_Entity
(Subp_Decl
);
4419 if Class_Present
(N
)
4420 and then Pragma_Name
(N
) = Name_Precondition
4421 and then Present
(Overridden_Operation
(E
))
4422 and then not Inherits_Class_Wide_Pre
(E
)
4425 ("illegal class-wide precondition on overriding operation",
4426 Corresponding_Aspect
(N
));
4430 -- A renaming declaration may inherit a generated pragma, its
4431 -- placement comes from expansion, not from source.
4433 elsif Nkind
(Subp_Decl
) = N_Subprogram_Renaming_Declaration
4434 and then not Comes_From_Source
(N
)
4438 -- Otherwise the placement is illegal
4445 Subp_Id
:= Defining_Entity
(Subp_Decl
);
4447 -- A pragma that applies to a Ghost entity becomes Ghost for the
4448 -- purposes of legality checks and removal of ignored Ghost code.
4450 Mark_Ghost_Pragma
(N
, Subp_Id
);
4452 -- Chain the pragma on the contract for further processing by
4453 -- Analyze_Pre_Post_Condition_In_Decl_Part.
4455 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
4457 -- Fully analyze the pragma when it appears inside an entry or
4458 -- subprogram body because it cannot benefit from forward references.
4460 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
4462 N_Subprogram_Body_Stub
)
4464 -- The legality checks of pragmas Precondition and Postcondition
4465 -- are affected by the SPARK mode in effect and the volatility of
4466 -- the context. Analyze all pragmas in a specific order.
4468 Analyze_If_Present
(Pragma_SPARK_Mode
);
4469 Analyze_If_Present
(Pragma_Volatile_Function
);
4470 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
4472 end Analyze_Pre_Post_Condition
;
4474 -----------------------------------------
4475 -- Analyze_Refined_Depends_Global_Post --
4476 -----------------------------------------
4478 procedure Analyze_Refined_Depends_Global_Post
4479 (Spec_Id
: out Entity_Id
;
4480 Body_Id
: out Entity_Id
;
4481 Legal
: out Boolean)
4483 Body_Decl
: Node_Id
;
4484 Spec_Decl
: Node_Id
;
4487 -- Assume that the pragma is illegal
4494 Check_Arg_Count
(1);
4495 Check_No_Identifiers
;
4497 -- Verify the placement of the pragma and check for duplicates. The
4498 -- pragma must apply to a subprogram body [stub].
4500 Body_Decl
:= Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
4504 if Nkind
(Body_Decl
) = N_Entry_Body
then
4509 elsif Nkind
(Body_Decl
) = N_Subprogram_Body
then
4512 -- Subprogram body stub
4514 elsif Nkind
(Body_Decl
) = N_Subprogram_Body_Stub
then
4519 elsif Nkind
(Body_Decl
) = N_Task_Body
then
4527 Body_Id
:= Defining_Entity
(Body_Decl
);
4528 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
4530 -- The pragma must apply to the second declaration of a subprogram.
4531 -- In other words, the body [stub] cannot acts as a spec.
4533 if No
(Spec_Id
) then
4534 Error_Pragma
("pragma % cannot apply to a stand alone body");
4537 -- Catch the case where the subprogram body is a subunit and acts as
4538 -- the third declaration of the subprogram.
4540 elsif Nkind
(Parent
(Body_Decl
)) = N_Subunit
then
4541 Error_Pragma
("pragma % cannot apply to a subunit");
4545 -- A refined pragma can only apply to the body [stub] of a subprogram
4546 -- declared in the visible part of a package. Retrieve the context of
4547 -- the subprogram declaration.
4549 Spec_Decl
:= Unit_Declaration_Node
(Spec_Id
);
4551 -- When dealing with protected entries or protected subprograms, use
4552 -- the enclosing protected type as the proper context.
4554 if Ekind_In
(Spec_Id
, E_Entry
,
4558 and then Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
4560 Spec_Decl
:= Declaration_Node
(Scope
(Spec_Id
));
4563 if Nkind
(Parent
(Spec_Decl
)) /= N_Package_Specification
then
4565 (Fix_Msg
(Spec_Id
, "pragma % must apply to the body of "
4566 & "subprogram declared in a package specification"));
4570 -- If we get here, then the pragma is legal
4574 -- A pragma that applies to a Ghost entity becomes Ghost for the
4575 -- purposes of legality checks and removal of ignored Ghost code.
4577 Mark_Ghost_Pragma
(N
, Spec_Id
);
4579 if Nam_In
(Pname
, Name_Refined_Depends
, Name_Refined_Global
) then
4580 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
4582 end Analyze_Refined_Depends_Global_Post
;
4584 ----------------------------------
4585 -- Analyze_Unmodified_Or_Unused --
4586 ----------------------------------
4588 procedure Analyze_Unmodified_Or_Unused
(Is_Unused
: Boolean := False) is
4593 Ghost_Error_Posted
: Boolean := False;
4594 -- Flag set when an error concerning the illegal mix of Ghost and
4595 -- non-Ghost variables is emitted.
4597 Ghost_Id
: Entity_Id
:= Empty
;
4598 -- The entity of the first Ghost variable encountered while
4599 -- processing the arguments of the pragma.
4603 Check_At_Least_N_Arguments
(1);
4605 -- Loop through arguments
4608 while Present
(Arg
) loop
4609 Check_No_Identifier
(Arg
);
4611 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4612 -- in fact generate reference, so that the entity will have a
4613 -- reference, which will inhibit any warnings about it not
4614 -- being referenced, and also properly show up in the ali file
4615 -- as a reference. But this reference is recorded before the
4616 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4617 -- generated for this reference.
4619 Check_Arg_Is_Local_Name
(Arg
);
4620 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4622 if Is_Entity_Name
(Arg_Expr
) then
4623 Arg_Id
:= Entity
(Arg_Expr
);
4625 -- Skip processing the argument if already flagged
4627 if Is_Assignable
(Arg_Id
)
4628 and then not Has_Pragma_Unmodified
(Arg_Id
)
4629 and then not Has_Pragma_Unused
(Arg_Id
)
4631 Set_Has_Pragma_Unmodified
(Arg_Id
);
4634 Set_Has_Pragma_Unused
(Arg_Id
);
4637 -- A pragma that applies to a Ghost entity becomes Ghost for
4638 -- the purposes of legality checks and removal of ignored
4641 Mark_Ghost_Pragma
(N
, Arg_Id
);
4643 -- Capture the entity of the first Ghost variable being
4644 -- processed for error detection purposes.
4646 if Is_Ghost_Entity
(Arg_Id
) then
4647 if No
(Ghost_Id
) then
4651 -- Otherwise the variable is non-Ghost. It is illegal to mix
4652 -- references to Ghost and non-Ghost entities
4655 elsif Present
(Ghost_Id
)
4656 and then not Ghost_Error_Posted
4658 Ghost_Error_Posted
:= True;
4660 Error_Msg_Name_1
:= Pname
;
4662 ("pragma % cannot mention ghost and non-ghost "
4665 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4666 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
4668 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4669 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
4672 -- Warn if already flagged as Unused or Unmodified
4674 elsif Has_Pragma_Unmodified
(Arg_Id
) then
4675 if Has_Pragma_Unused
(Arg_Id
) then
4677 ("??pragma Unused already given for &!", Arg_Expr
,
4681 ("??pragma Unmodified already given for &!", Arg_Expr
,
4685 -- Otherwise the pragma referenced an illegal entity
4689 ("pragma% can only be applied to a variable", Arg_Expr
);
4695 end Analyze_Unmodified_Or_Unused
;
4697 -----------------------------------
4698 -- Analyze_Unreference_Or_Unused --
4699 -----------------------------------
4701 procedure Analyze_Unreferenced_Or_Unused
4702 (Is_Unused
: Boolean := False)
4709 Ghost_Error_Posted
: Boolean := False;
4710 -- Flag set when an error concerning the illegal mix of Ghost and
4711 -- non-Ghost names is emitted.
4713 Ghost_Id
: Entity_Id
:= Empty
;
4714 -- The entity of the first Ghost name encountered while processing
4715 -- the arguments of the pragma.
4719 Check_At_Least_N_Arguments
(1);
4721 -- Check case of appearing within context clause
4723 if not Is_Unused
and then Is_In_Context_Clause
then
4725 -- The arguments must all be units mentioned in a with clause in
4726 -- the same context clause. Note that Par.Prag already checked
4727 -- that the arguments are either identifiers or selected
4731 while Present
(Arg
) loop
4732 Citem
:= First
(List_Containing
(N
));
4733 while Citem
/= N
loop
4734 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4736 if Nkind
(Citem
) = N_With_Clause
4737 and then Same_Name
(Name
(Citem
), Arg_Expr
)
4739 Set_Has_Pragma_Unreferenced
4742 (Library_Unit
(Citem
))));
4743 Set_Elab_Unit_Name
(Arg_Expr
, Name
(Citem
));
4752 ("argument of pragma% is not withed unit", Arg
);
4758 -- Case of not in list of context items
4762 while Present
(Arg
) loop
4763 Check_No_Identifier
(Arg
);
4765 -- Note: the analyze call done by Check_Arg_Is_Local_Name will
4766 -- in fact generate reference, so that the entity will have a
4767 -- reference, which will inhibit any warnings about it not
4768 -- being referenced, and also properly show up in the ali file
4769 -- as a reference. But this reference is recorded before the
4770 -- Has_Pragma_Unreferenced flag is set, so that no warning is
4771 -- generated for this reference.
4773 Check_Arg_Is_Local_Name
(Arg
);
4774 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
4776 if Is_Entity_Name
(Arg_Expr
) then
4777 Arg_Id
:= Entity
(Arg_Expr
);
4779 -- Warn if already flagged as Unused or Unreferenced and
4780 -- skip processing the argument.
4782 if Has_Pragma_Unreferenced
(Arg_Id
) then
4783 if Has_Pragma_Unused
(Arg_Id
) then
4785 ("??pragma Unused already given for &!", Arg_Expr
,
4789 ("??pragma Unreferenced already given for &!",
4793 -- Apply Unreferenced to the entity
4796 -- If the entity is overloaded, the pragma applies to the
4797 -- most recent overloading, as documented. In this case,
4798 -- name resolution does not generate a reference, so it
4799 -- must be done here explicitly.
4801 if Is_Overloaded
(Arg_Expr
) then
4802 Generate_Reference
(Arg_Id
, N
);
4805 Set_Has_Pragma_Unreferenced
(Arg_Id
);
4808 Set_Has_Pragma_Unused
(Arg_Id
);
4811 -- A pragma that applies to a Ghost entity becomes Ghost
4812 -- for the purposes of legality checks and removal of
4813 -- ignored Ghost code.
4815 Mark_Ghost_Pragma
(N
, Arg_Id
);
4817 -- Capture the entity of the first Ghost name being
4818 -- processed for error detection purposes.
4820 if Is_Ghost_Entity
(Arg_Id
) then
4821 if No
(Ghost_Id
) then
4825 -- Otherwise the name is non-Ghost. It is illegal to mix
4826 -- references to Ghost and non-Ghost entities
4829 elsif Present
(Ghost_Id
)
4830 and then not Ghost_Error_Posted
4832 Ghost_Error_Posted
:= True;
4834 Error_Msg_Name_1
:= Pname
;
4836 ("pragma % cannot mention ghost and non-ghost "
4839 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
4841 ("\& # declared as ghost", N
, Ghost_Id
);
4843 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
4845 ("\& # declared as non-ghost", N
, Arg_Id
);
4853 end Analyze_Unreferenced_Or_Unused
;
4855 --------------------------
4856 -- Check_Ada_83_Warning --
4857 --------------------------
4859 procedure Check_Ada_83_Warning
is
4861 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
4862 Error_Msg_N
("(Ada 83) pragma& is non-standard??", N
);
4864 end Check_Ada_83_Warning
;
4866 ---------------------
4867 -- Check_Arg_Count --
4868 ---------------------
4870 procedure Check_Arg_Count
(Required
: Nat
) is
4872 if Arg_Count
/= Required
then
4873 Error_Pragma
("wrong number of arguments for pragma%");
4875 end Check_Arg_Count
;
4877 --------------------------------
4878 -- Check_Arg_Is_External_Name --
4879 --------------------------------
4881 procedure Check_Arg_Is_External_Name
(Arg
: Node_Id
) is
4882 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4885 if Nkind
(Argx
) = N_Identifier
then
4889 Analyze_And_Resolve
(Argx
, Standard_String
);
4891 if Is_OK_Static_Expression
(Argx
) then
4894 elsif Etype
(Argx
) = Any_Type
then
4897 -- An interesting special case, if we have a string literal and
4898 -- we are in Ada 83 mode, then we allow it even though it will
4899 -- not be flagged as static. This allows expected Ada 83 mode
4900 -- use of external names which are string literals, even though
4901 -- technically these are not static in Ada 83.
4903 elsif Ada_Version
= Ada_83
4904 and then Nkind
(Argx
) = N_String_Literal
4908 -- Static expression that raises Constraint_Error. This has
4909 -- already been flagged, so just exit from pragma processing.
4911 elsif Is_OK_Static_Expression
(Argx
) then
4914 -- Here we have a real error (non-static expression)
4917 Error_Msg_Name_1
:= Pname
;
4920 Msg
: constant String :=
4921 "argument for pragma% must be a identifier or "
4922 & "static string expression!";
4924 Flag_Non_Static_Expr
(Fix_Error
(Msg
), Argx
);
4929 end Check_Arg_Is_External_Name
;
4931 -----------------------------
4932 -- Check_Arg_Is_Identifier --
4933 -----------------------------
4935 procedure Check_Arg_Is_Identifier
(Arg
: Node_Id
) is
4936 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4938 if Nkind
(Argx
) /= N_Identifier
then
4940 ("argument for pragma% must be identifier", Argx
);
4942 end Check_Arg_Is_Identifier
;
4944 ----------------------------------
4945 -- Check_Arg_Is_Integer_Literal --
4946 ----------------------------------
4948 procedure Check_Arg_Is_Integer_Literal
(Arg
: Node_Id
) is
4949 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4951 if Nkind
(Argx
) /= N_Integer_Literal
then
4953 ("argument for pragma% must be integer literal", Argx
);
4955 end Check_Arg_Is_Integer_Literal
;
4957 -------------------------------------------
4958 -- Check_Arg_Is_Library_Level_Local_Name --
4959 -------------------------------------------
4963 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4964 -- | library_unit_NAME
4966 procedure Check_Arg_Is_Library_Level_Local_Name
(Arg
: Node_Id
) is
4968 Check_Arg_Is_Local_Name
(Arg
);
4970 -- If it came from an aspect, we want to give the error just as if it
4971 -- came from source.
4973 if not Is_Library_Level_Entity
(Entity
(Get_Pragma_Arg
(Arg
)))
4974 and then (Comes_From_Source
(N
)
4975 or else Present
(Corresponding_Aspect
(Parent
(Arg
))))
4978 ("argument for pragma% must be library level entity", Arg
);
4980 end Check_Arg_Is_Library_Level_Local_Name
;
4982 -----------------------------
4983 -- Check_Arg_Is_Local_Name --
4984 -----------------------------
4988 -- | DIRECT_NAME'ATTRIBUTE_DESIGNATOR
4989 -- | library_unit_NAME
4991 procedure Check_Arg_Is_Local_Name
(Arg
: Node_Id
) is
4992 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
4995 -- If this pragma came from an aspect specification, we don't want to
4996 -- check for this error, because that would cause spurious errors, in
4997 -- case a type is frozen in a scope more nested than the type. The
4998 -- aspect itself of course can't be anywhere but on the declaration
5001 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
5002 if From_Aspect_Specification
(Parent
(Arg
)) then
5006 -- Arg is the Expression of an N_Pragma_Argument_Association
5009 if From_Aspect_Specification
(Parent
(Parent
(Arg
))) then
5016 if Nkind
(Argx
) not in N_Direct_Name
5017 and then (Nkind
(Argx
) /= N_Attribute_Reference
5018 or else Present
(Expressions
(Argx
))
5019 or else Nkind
(Prefix
(Argx
)) /= N_Identifier
)
5020 and then (not Is_Entity_Name
(Argx
)
5021 or else not Is_Compilation_Unit
(Entity
(Argx
)))
5023 Error_Pragma_Arg
("argument for pragma% must be local name", Argx
);
5026 -- No further check required if not an entity name
5028 if not Is_Entity_Name
(Argx
) then
5034 Ent
: constant Entity_Id
:= Entity
(Argx
);
5035 Scop
: constant Entity_Id
:= Scope
(Ent
);
5038 -- Case of a pragma applied to a compilation unit: pragma must
5039 -- occur immediately after the program unit in the compilation.
5041 if Is_Compilation_Unit
(Ent
) then
5043 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Ent
);
5046 -- Case of pragma placed immediately after spec
5048 if Parent
(N
) = Aux_Decls_Node
(Parent
(Decl
)) then
5051 -- Case of pragma placed immediately after body
5053 elsif Nkind
(Decl
) = N_Subprogram_Declaration
5054 and then Present
(Corresponding_Body
(Decl
))
5058 (Parent
(Unit_Declaration_Node
5059 (Corresponding_Body
(Decl
))));
5061 -- All other cases are illegal
5068 -- Special restricted placement rule from 10.2.1(11.8/2)
5070 elsif Is_Generic_Formal
(Ent
)
5071 and then Prag_Id
= Pragma_Preelaborable_Initialization
5073 OK
:= List_Containing
(N
) =
5074 Generic_Formal_Declarations
5075 (Unit_Declaration_Node
(Scop
));
5077 -- If this is an aspect applied to a subprogram body, the
5078 -- pragma is inserted in its declarative part.
5080 elsif From_Aspect_Specification
(N
)
5081 and then Ent
= Current_Scope
5083 Nkind
(Unit_Declaration_Node
(Ent
)) = N_Subprogram_Body
5087 -- If the aspect is a predicate (possibly others ???) and the
5088 -- context is a record type, this is a discriminant expression
5089 -- within a type declaration, that freezes the predicated
5092 elsif From_Aspect_Specification
(N
)
5093 and then Prag_Id
= Pragma_Predicate
5094 and then Ekind
(Current_Scope
) = E_Record_Type
5095 and then Scop
= Scope
(Current_Scope
)
5099 -- Default case, just check that the pragma occurs in the scope
5100 -- of the entity denoted by the name.
5103 OK
:= Current_Scope
= Scop
;
5108 ("pragma% argument must be in same declarative part", Arg
);
5112 end Check_Arg_Is_Local_Name
;
5114 ---------------------------------
5115 -- Check_Arg_Is_Locking_Policy --
5116 ---------------------------------
5118 procedure Check_Arg_Is_Locking_Policy
(Arg
: Node_Id
) is
5119 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5122 Check_Arg_Is_Identifier
(Argx
);
5124 if not Is_Locking_Policy_Name
(Chars
(Argx
)) then
5125 Error_Pragma_Arg
("& is not a valid locking policy name", Argx
);
5127 end Check_Arg_Is_Locking_Policy
;
5129 -----------------------------------------------
5130 -- Check_Arg_Is_Partition_Elaboration_Policy --
5131 -----------------------------------------------
5133 procedure Check_Arg_Is_Partition_Elaboration_Policy
(Arg
: Node_Id
) is
5134 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5137 Check_Arg_Is_Identifier
(Argx
);
5139 if not Is_Partition_Elaboration_Policy_Name
(Chars
(Argx
)) then
5141 ("& is not a valid partition elaboration policy name", Argx
);
5143 end Check_Arg_Is_Partition_Elaboration_Policy
;
5145 -------------------------
5146 -- Check_Arg_Is_One_Of --
5147 -------------------------
5149 procedure Check_Arg_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5150 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5153 Check_Arg_Is_Identifier
(Argx
);
5155 if not Nam_In
(Chars
(Argx
), N1
, N2
) then
5156 Error_Msg_Name_2
:= N1
;
5157 Error_Msg_Name_3
:= N2
;
5158 Error_Pragma_Arg
("argument for pragma% must be% or%", Argx
);
5160 end Check_Arg_Is_One_Of
;
5162 procedure Check_Arg_Is_One_Of
5164 N1
, N2
, N3
: Name_Id
)
5166 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5169 Check_Arg_Is_Identifier
(Argx
);
5171 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
) then
5172 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5174 end Check_Arg_Is_One_Of
;
5176 procedure Check_Arg_Is_One_Of
5178 N1
, N2
, N3
, N4
: Name_Id
)
5180 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5183 Check_Arg_Is_Identifier
(Argx
);
5185 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
) then
5186 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5188 end Check_Arg_Is_One_Of
;
5190 procedure Check_Arg_Is_One_Of
5192 N1
, N2
, N3
, N4
, N5
: Name_Id
)
5194 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5197 Check_Arg_Is_Identifier
(Argx
);
5199 if not Nam_In
(Chars
(Argx
), N1
, N2
, N3
, N4
, N5
) then
5200 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
5202 end Check_Arg_Is_One_Of
;
5204 ---------------------------------
5205 -- Check_Arg_Is_Queuing_Policy --
5206 ---------------------------------
5208 procedure Check_Arg_Is_Queuing_Policy
(Arg
: Node_Id
) is
5209 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5212 Check_Arg_Is_Identifier
(Argx
);
5214 if not Is_Queuing_Policy_Name
(Chars
(Argx
)) then
5215 Error_Pragma_Arg
("& is not a valid queuing policy name", Argx
);
5217 end Check_Arg_Is_Queuing_Policy
;
5219 ---------------------------------------
5220 -- Check_Arg_Is_OK_Static_Expression --
5221 ---------------------------------------
5223 procedure Check_Arg_Is_OK_Static_Expression
5225 Typ
: Entity_Id
:= Empty
)
5228 Check_Expr_Is_OK_Static_Expression
(Get_Pragma_Arg
(Arg
), Typ
);
5229 end Check_Arg_Is_OK_Static_Expression
;
5231 ------------------------------------------
5232 -- Check_Arg_Is_Task_Dispatching_Policy --
5233 ------------------------------------------
5235 procedure Check_Arg_Is_Task_Dispatching_Policy
(Arg
: Node_Id
) is
5236 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5239 Check_Arg_Is_Identifier
(Argx
);
5241 if not Is_Task_Dispatching_Policy_Name
(Chars
(Argx
)) then
5243 ("& is not an allowed task dispatching policy name", Argx
);
5245 end Check_Arg_Is_Task_Dispatching_Policy
;
5247 ---------------------
5248 -- Check_Arg_Order --
5249 ---------------------
5251 procedure Check_Arg_Order
(Names
: Name_List
) is
5254 Highest_So_Far
: Natural := 0;
5255 -- Highest index in Names seen do far
5259 for J
in 1 .. Arg_Count
loop
5260 if Chars
(Arg
) /= No_Name
then
5261 for K
in Names
'Range loop
5262 if Chars
(Arg
) = Names
(K
) then
5263 if K
< Highest_So_Far
then
5264 Error_Msg_Name_1
:= Pname
;
5266 ("parameters out of order for pragma%", Arg
);
5267 Error_Msg_Name_1
:= Names
(K
);
5268 Error_Msg_Name_2
:= Names
(Highest_So_Far
);
5269 Error_Msg_N
("\% must appear before %", Arg
);
5273 Highest_So_Far
:= K
;
5281 end Check_Arg_Order
;
5283 --------------------------------
5284 -- Check_At_Least_N_Arguments --
5285 --------------------------------
5287 procedure Check_At_Least_N_Arguments
(N
: Nat
) is
5289 if Arg_Count
< N
then
5290 Error_Pragma
("too few arguments for pragma%");
5292 end Check_At_Least_N_Arguments
;
5294 -------------------------------
5295 -- Check_At_Most_N_Arguments --
5296 -------------------------------
5298 procedure Check_At_Most_N_Arguments
(N
: Nat
) is
5301 if Arg_Count
> N
then
5303 for J
in 1 .. N
loop
5305 Error_Pragma_Arg
("too many arguments for pragma%", Arg
);
5308 end Check_At_Most_N_Arguments
;
5310 ---------------------
5311 -- Check_Component --
5312 ---------------------
5314 procedure Check_Component
5317 In_Variant_Part
: Boolean := False)
5319 Comp_Id
: constant Entity_Id
:= Defining_Identifier
(Comp
);
5320 Sindic
: constant Node_Id
:=
5321 Subtype_Indication
(Component_Definition
(Comp
));
5322 Typ
: constant Entity_Id
:= Etype
(Comp_Id
);
5325 -- Ada 2005 (AI-216): If a component subtype is subject to a per-
5326 -- object constraint, then the component type shall be an Unchecked_
5329 if Nkind
(Sindic
) = N_Subtype_Indication
5330 and then Has_Per_Object_Constraint
(Comp_Id
)
5331 and then not Is_Unchecked_Union
(Etype
(Subtype_Mark
(Sindic
)))
5334 ("component subtype subject to per-object constraint "
5335 & "must be an Unchecked_Union", Comp
);
5337 -- Ada 2012 (AI05-0026): For an unchecked union type declared within
5338 -- the body of a generic unit, or within the body of any of its
5339 -- descendant library units, no part of the type of a component
5340 -- declared in a variant_part of the unchecked union type shall be of
5341 -- a formal private type or formal private extension declared within
5342 -- the formal part of the generic unit.
5344 elsif Ada_Version
>= Ada_2012
5345 and then In_Generic_Body
(UU_Typ
)
5346 and then In_Variant_Part
5347 and then Is_Private_Type
(Typ
)
5348 and then Is_Generic_Type
(Typ
)
5351 ("component of unchecked union cannot be of generic type", Comp
);
5353 elsif Needs_Finalization
(Typ
) then
5355 ("component of unchecked union cannot be controlled", Comp
);
5357 elsif Has_Task
(Typ
) then
5359 ("component of unchecked union cannot have tasks", Comp
);
5361 end Check_Component
;
5363 ----------------------------
5364 -- Check_Duplicate_Pragma --
5365 ----------------------------
5367 procedure Check_Duplicate_Pragma
(E
: Entity_Id
) is
5368 Id
: Entity_Id
:= E
;
5372 -- Nothing to do if this pragma comes from an aspect specification,
5373 -- since we could not be duplicating a pragma, and we dealt with the
5374 -- case of duplicated aspects in Analyze_Aspect_Specifications.
5376 if From_Aspect_Specification
(N
) then
5380 -- Otherwise current pragma may duplicate previous pragma or a
5381 -- previously given aspect specification or attribute definition
5382 -- clause for the same pragma.
5384 P
:= Get_Rep_Item
(E
, Pragma_Name
(N
), Check_Parents
=> False);
5388 -- If the entity is a type, then we have to make sure that the
5389 -- ostensible duplicate is not for a parent type from which this
5393 if Nkind
(P
) = N_Pragma
then
5395 Args
: constant List_Id
:=
5396 Pragma_Argument_Associations
(P
);
5399 and then Is_Entity_Name
(Expression
(First
(Args
)))
5400 and then Is_Type
(Entity
(Expression
(First
(Args
))))
5401 and then Entity
(Expression
(First
(Args
))) /= E
5407 elsif Nkind
(P
) = N_Aspect_Specification
5408 and then Is_Type
(Entity
(P
))
5409 and then Entity
(P
) /= E
5415 -- Here we have a definite duplicate
5417 Error_Msg_Name_1
:= Pragma_Name
(N
);
5418 Error_Msg_Sloc
:= Sloc
(P
);
5420 -- For a single protected or a single task object, the error is
5421 -- issued on the original entity.
5423 if Ekind_In
(Id
, E_Task_Type
, E_Protected_Type
) then
5424 Id
:= Defining_Identifier
(Original_Node
(Parent
(Id
)));
5427 if Nkind
(P
) = N_Aspect_Specification
5428 or else From_Aspect_Specification
(P
)
5430 Error_Msg_NE
("aspect% for & previously given#", N
, Id
);
5432 Error_Msg_NE
("pragma% for & duplicates pragma#", N
, Id
);
5437 end Check_Duplicate_Pragma
;
5439 ----------------------------------
5440 -- Check_Duplicated_Export_Name --
5441 ----------------------------------
5443 procedure Check_Duplicated_Export_Name
(Nam
: Node_Id
) is
5444 String_Val
: constant String_Id
:= Strval
(Nam
);
5447 -- We are only interested in the export case, and in the case of
5448 -- generics, it is the instance, not the template, that is the
5449 -- problem (the template will generate a warning in any case).
5451 if not Inside_A_Generic
5452 and then (Prag_Id
= Pragma_Export
5454 Prag_Id
= Pragma_Export_Procedure
5456 Prag_Id
= Pragma_Export_Valued_Procedure
5458 Prag_Id
= Pragma_Export_Function
)
5460 for J
in Externals
.First
.. Externals
.Last
loop
5461 if String_Equal
(String_Val
, Strval
(Externals
.Table
(J
))) then
5462 Error_Msg_Sloc
:= Sloc
(Externals
.Table
(J
));
5463 Error_Msg_N
("external name duplicates name given#", Nam
);
5468 Externals
.Append
(Nam
);
5470 end Check_Duplicated_Export_Name
;
5472 ----------------------------------------
5473 -- Check_Expr_Is_OK_Static_Expression --
5474 ----------------------------------------
5476 procedure Check_Expr_Is_OK_Static_Expression
5478 Typ
: Entity_Id
:= Empty
)
5481 if Present
(Typ
) then
5482 Analyze_And_Resolve
(Expr
, Typ
);
5484 Analyze_And_Resolve
(Expr
);
5487 -- An expression cannot be considered static if its resolution failed
5488 -- or if it's erroneous. Stop the analysis of the related pragma.
5490 if Etype
(Expr
) = Any_Type
or else Error_Posted
(Expr
) then
5493 elsif Is_OK_Static_Expression
(Expr
) then
5496 -- An interesting special case, if we have a string literal and we
5497 -- are in Ada 83 mode, then we allow it even though it will not be
5498 -- flagged as static. This allows the use of Ada 95 pragmas like
5499 -- Import in Ada 83 mode. They will of course be flagged with
5500 -- warnings as usual, but will not cause errors.
5502 elsif Ada_Version
= Ada_83
5503 and then Nkind
(Expr
) = N_String_Literal
5507 -- Finally, we have a real error
5510 Error_Msg_Name_1
:= Pname
;
5511 Flag_Non_Static_Expr
5512 (Fix_Error
("argument for pragma% must be a static expression!"),
5516 end Check_Expr_Is_OK_Static_Expression
;
5518 -------------------------
5519 -- Check_First_Subtype --
5520 -------------------------
5522 procedure Check_First_Subtype
(Arg
: Node_Id
) is
5523 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
5524 Ent
: constant Entity_Id
:= Entity
(Argx
);
5527 if Is_First_Subtype
(Ent
) then
5530 elsif Is_Type
(Ent
) then
5532 ("pragma% cannot apply to subtype", Argx
);
5534 elsif Is_Object
(Ent
) then
5536 ("pragma% cannot apply to object, requires a type", Argx
);
5540 ("pragma% cannot apply to&, requires a type", Argx
);
5542 end Check_First_Subtype
;
5544 ----------------------
5545 -- Check_Identifier --
5546 ----------------------
5548 procedure Check_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
5551 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5553 if Chars
(Arg
) = No_Name
or else Chars
(Arg
) /= Id
then
5554 Error_Msg_Name_1
:= Pname
;
5555 Error_Msg_Name_2
:= Id
;
5556 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
5560 end Check_Identifier
;
5562 --------------------------------
5563 -- Check_Identifier_Is_One_Of --
5564 --------------------------------
5566 procedure Check_Identifier_Is_One_Of
(Arg
: Node_Id
; N1
, N2
: Name_Id
) is
5569 and then Nkind
(Arg
) = N_Pragma_Argument_Association
5571 if Chars
(Arg
) = No_Name
then
5572 Error_Msg_Name_1
:= Pname
;
5573 Error_Msg_N
("pragma% argument expects an identifier", Arg
);
5576 elsif Chars
(Arg
) /= N1
5577 and then Chars
(Arg
) /= N2
5579 Error_Msg_Name_1
:= Pname
;
5580 Error_Msg_N
("invalid identifier for pragma% argument", Arg
);
5584 end Check_Identifier_Is_One_Of
;
5586 ---------------------------
5587 -- Check_In_Main_Program --
5588 ---------------------------
5590 procedure Check_In_Main_Program
is
5591 P
: constant Node_Id
:= Parent
(N
);
5594 -- Must be in subprogram body
5596 if Nkind
(P
) /= N_Subprogram_Body
then
5597 Error_Pragma
("% pragma allowed only in subprogram");
5599 -- Otherwise warn if obviously not main program
5601 elsif Present
(Parameter_Specifications
(Specification
(P
)))
5602 or else not Is_Compilation_Unit
(Defining_Entity
(P
))
5604 Error_Msg_Name_1
:= Pname
;
5606 ("??pragma% is only effective in main program", N
);
5608 end Check_In_Main_Program
;
5610 ---------------------------------------
5611 -- Check_Interrupt_Or_Attach_Handler --
5612 ---------------------------------------
5614 procedure Check_Interrupt_Or_Attach_Handler
is
5615 Arg1_X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
5616 Handler_Proc
, Proc_Scope
: Entity_Id
;
5621 if Prag_Id
= Pragma_Interrupt_Handler
then
5622 Check_Restriction
(No_Dynamic_Attachment
, N
);
5625 Handler_Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
5626 Proc_Scope
:= Scope
(Handler_Proc
);
5628 if Ekind
(Proc_Scope
) /= E_Protected_Type
then
5630 ("argument of pragma% must be protected procedure", Arg1
);
5633 -- For pragma case (as opposed to access case), check placement.
5634 -- We don't need to do that for aspects, because we have the
5635 -- check that they aspect applies an appropriate procedure.
5637 if not From_Aspect_Specification
(N
)
5638 and then Parent
(N
) /= Protected_Definition
(Parent
(Proc_Scope
))
5640 Error_Pragma
("pragma% must be in protected definition");
5643 if not Is_Library_Level_Entity
(Proc_Scope
) then
5645 ("argument for pragma% must be library level entity", Arg1
);
5648 -- AI05-0033: A pragma cannot appear within a generic body, because
5649 -- instance can be in a nested scope. The check that protected type
5650 -- is itself a library-level declaration is done elsewhere.
5652 -- Note: we omit this check in Relaxed_RM_Semantics mode to properly
5653 -- handle code prior to AI-0033. Analysis tools typically are not
5654 -- interested in this pragma in any case, so no need to worry too
5655 -- much about its placement.
5657 if Inside_A_Generic
then
5658 if Ekind
(Scope
(Current_Scope
)) = E_Generic_Package
5659 and then In_Package_Body
(Scope
(Current_Scope
))
5660 and then not Relaxed_RM_Semantics
5662 Error_Pragma
("pragma% cannot be used inside a generic");
5665 end Check_Interrupt_Or_Attach_Handler
;
5667 ---------------------------------
5668 -- Check_Loop_Pragma_Placement --
5669 ---------------------------------
5671 procedure Check_Loop_Pragma_Placement
is
5672 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
);
5673 -- Verify whether the current pragma is properly grouped with other
5674 -- pragma Loop_Invariant and/or Loop_Variant. Node Loop_Stmt is the
5675 -- related loop where the pragma appears.
5677 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean;
5678 -- Determine whether an arbitrary statement Stmt denotes pragma
5679 -- Loop_Invariant or Loop_Variant.
5681 procedure Placement_Error
(Constr
: Node_Id
);
5682 pragma No_Return
(Placement_Error
);
5683 -- Node Constr denotes the last loop restricted construct before we
5684 -- encountered an illegal relation between enclosing constructs. Emit
5685 -- an error depending on what Constr was.
5687 --------------------------------
5688 -- Check_Loop_Pragma_Grouping --
5689 --------------------------------
5691 procedure Check_Loop_Pragma_Grouping
(Loop_Stmt
: Node_Id
) is
5692 Stop_Search
: exception;
5693 -- This exception is used to terminate the recursive descent of
5694 -- routine Check_Grouping.
5696 procedure Check_Grouping
(L
: List_Id
);
5697 -- Find the first group of pragmas in list L and if successful,
5698 -- ensure that the current pragma is part of that group. The
5699 -- routine raises Stop_Search once such a check is performed to
5700 -- halt the recursive descent.
5702 procedure Grouping_Error
(Prag
: Node_Id
);
5703 pragma No_Return
(Grouping_Error
);
5704 -- Emit an error concerning the current pragma indicating that it
5705 -- should be placed after pragma Prag.
5707 --------------------
5708 -- Check_Grouping --
5709 --------------------
5711 procedure Check_Grouping
(L
: List_Id
) is
5717 -- Inspect the list of declarations or statements looking for
5718 -- the first grouping of pragmas:
5721 -- pragma Loop_Invariant ...;
5722 -- pragma Loop_Variant ...;
5724 -- pragma Loop_Variant ...; -- current pragma
5726 -- If the current pragma is not in the grouping, then it must
5727 -- either appear in a different declarative or statement list
5728 -- or the construct at (1) is separating the pragma from the
5732 while Present
(Stmt
) loop
5734 -- Pragmas Loop_Invariant and Loop_Variant may only appear
5735 -- inside a loop or a block housed inside a loop. Inspect
5736 -- the declarations and statements of the block as they may
5737 -- contain the first grouping.
5739 if Nkind
(Stmt
) = N_Block_Statement
then
5740 HSS
:= Handled_Statement_Sequence
(Stmt
);
5742 Check_Grouping
(Declarations
(Stmt
));
5744 if Present
(HSS
) then
5745 Check_Grouping
(Statements
(HSS
));
5748 -- First pragma of the first topmost grouping has been found
5750 elsif Is_Loop_Pragma
(Stmt
) then
5752 -- The group and the current pragma are not in the same
5753 -- declarative or statement list.
5755 if List_Containing
(Stmt
) /= List_Containing
(N
) then
5756 Grouping_Error
(Stmt
);
5758 -- Try to reach the current pragma from the first pragma
5759 -- of the grouping while skipping other members:
5761 -- pragma Loop_Invariant ...; -- first pragma
5762 -- pragma Loop_Variant ...; -- member
5764 -- pragma Loop_Variant ...; -- current pragma
5767 while Present
(Stmt
) loop
5769 -- The current pragma is either the first pragma
5770 -- of the group or is a member of the group. Stop
5771 -- the search as the placement is legal.
5776 -- Skip group members, but keep track of the last
5777 -- pragma in the group.
5779 elsif Is_Loop_Pragma
(Stmt
) then
5782 -- Skip declarations and statements generated by
5783 -- the compiler during expansion.
5785 elsif not Comes_From_Source
(Stmt
) then
5788 -- A non-pragma is separating the group from the
5789 -- current pragma, the placement is illegal.
5792 Grouping_Error
(Prag
);
5798 -- If the traversal did not reach the current pragma,
5799 -- then the list must be malformed.
5801 raise Program_Error
;
5809 --------------------
5810 -- Grouping_Error --
5811 --------------------
5813 procedure Grouping_Error
(Prag
: Node_Id
) is
5815 Error_Msg_Sloc
:= Sloc
(Prag
);
5816 Error_Pragma
("pragma% must appear next to pragma#");
5819 -- Start of processing for Check_Loop_Pragma_Grouping
5822 -- Inspect the statements of the loop or nested blocks housed
5823 -- within to determine whether the current pragma is part of the
5824 -- first topmost grouping of Loop_Invariant and Loop_Variant.
5826 Check_Grouping
(Statements
(Loop_Stmt
));
5829 when Stop_Search
=> null;
5830 end Check_Loop_Pragma_Grouping
;
5832 --------------------
5833 -- Is_Loop_Pragma --
5834 --------------------
5836 function Is_Loop_Pragma
(Stmt
: Node_Id
) return Boolean is
5838 -- Inspect the original node as Loop_Invariant and Loop_Variant
5839 -- pragmas are rewritten to null when assertions are disabled.
5841 if Nkind
(Original_Node
(Stmt
)) = N_Pragma
then
5843 Nam_In
(Pragma_Name_Unmapped
(Original_Node
(Stmt
)),
5844 Name_Loop_Invariant
,
5851 ---------------------
5852 -- Placement_Error --
5853 ---------------------
5855 procedure Placement_Error
(Constr
: Node_Id
) is
5856 LA
: constant String := " with Loop_Entry";
5859 if Prag_Id
= Pragma_Assert
then
5860 Error_Msg_String
(1 .. LA
'Length) := LA
;
5861 Error_Msg_Strlen
:= LA
'Length;
5863 Error_Msg_Strlen
:= 0;
5866 if Nkind
(Constr
) = N_Pragma
then
5868 ("pragma %~ must appear immediately within the statements "
5872 ("block containing pragma %~ must appear immediately within "
5873 & "the statements of a loop", Constr
);
5875 end Placement_Error
;
5877 -- Local declarations
5882 -- Start of processing for Check_Loop_Pragma_Placement
5885 -- Check that pragma appears immediately within a loop statement,
5886 -- ignoring intervening block statements.
5890 while Present
(Stmt
) loop
5892 -- The pragma or previous block must appear immediately within the
5893 -- current block's declarative or statement part.
5895 if Nkind
(Stmt
) = N_Block_Statement
then
5896 if (No
(Declarations
(Stmt
))
5897 or else List_Containing
(Prev
) /= Declarations
(Stmt
))
5899 List_Containing
(Prev
) /=
5900 Statements
(Handled_Statement_Sequence
(Stmt
))
5902 Placement_Error
(Prev
);
5905 -- Keep inspecting the parents because we are now within a
5906 -- chain of nested blocks.
5910 Stmt
:= Parent
(Stmt
);
5913 -- The pragma or previous block must appear immediately within the
5914 -- statements of the loop.
5916 elsif Nkind
(Stmt
) = N_Loop_Statement
then
5917 if List_Containing
(Prev
) /= Statements
(Stmt
) then
5918 Placement_Error
(Prev
);
5921 -- Stop the traversal because we reached the innermost loop
5922 -- regardless of whether we encountered an error or not.
5926 -- Ignore a handled statement sequence. Note that this node may
5927 -- be related to a subprogram body in which case we will emit an
5928 -- error on the next iteration of the search.
5930 elsif Nkind
(Stmt
) = N_Handled_Sequence_Of_Statements
then
5931 Stmt
:= Parent
(Stmt
);
5933 -- Any other statement breaks the chain from the pragma to the
5937 Placement_Error
(Prev
);
5942 -- Check that the current pragma Loop_Invariant or Loop_Variant is
5943 -- grouped together with other such pragmas.
5945 if Is_Loop_Pragma
(N
) then
5947 -- The previous check should have located the related loop
5949 pragma Assert
(Nkind
(Stmt
) = N_Loop_Statement
);
5950 Check_Loop_Pragma_Grouping
(Stmt
);
5952 end Check_Loop_Pragma_Placement
;
5954 -------------------------------------------
5955 -- Check_Is_In_Decl_Part_Or_Package_Spec --
5956 -------------------------------------------
5958 procedure Check_Is_In_Decl_Part_Or_Package_Spec
is
5967 elsif Nkind
(P
) = N_Handled_Sequence_Of_Statements
then
5970 elsif Nkind_In
(P
, N_Package_Specification
,
5975 -- Note: the following tests seem a little peculiar, because
5976 -- they test for bodies, but if we were in the statement part
5977 -- of the body, we would already have hit the handled statement
5978 -- sequence, so the only way we get here is by being in the
5979 -- declarative part of the body.
5981 elsif Nkind_In
(P
, N_Subprogram_Body
,
5992 Error_Pragma
("pragma% is not in declarative part or package spec");
5993 end Check_Is_In_Decl_Part_Or_Package_Spec
;
5995 -------------------------
5996 -- Check_No_Identifier --
5997 -------------------------
5999 procedure Check_No_Identifier
(Arg
: Node_Id
) is
6001 if Nkind
(Arg
) = N_Pragma_Argument_Association
6002 and then Chars
(Arg
) /= No_Name
6004 Error_Pragma_Arg_Ident
6005 ("pragma% does not permit identifier& here", Arg
);
6007 end Check_No_Identifier
;
6009 --------------------------
6010 -- Check_No_Identifiers --
6011 --------------------------
6013 procedure Check_No_Identifiers
is
6017 for J
in 1 .. Arg_Count
loop
6018 Check_No_Identifier
(Arg_Node
);
6021 end Check_No_Identifiers
;
6023 ------------------------
6024 -- Check_No_Link_Name --
6025 ------------------------
6027 procedure Check_No_Link_Name
is
6029 if Present
(Arg3
) and then Chars
(Arg3
) = Name_Link_Name
then
6033 if Present
(Arg4
) then
6035 ("Link_Name argument not allowed for Import Intrinsic", Arg4
);
6037 end Check_No_Link_Name
;
6039 -------------------------------
6040 -- Check_Optional_Identifier --
6041 -------------------------------
6043 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: Name_Id
) is
6046 and then Nkind
(Arg
) = N_Pragma_Argument_Association
6047 and then Chars
(Arg
) /= No_Name
6049 if Chars
(Arg
) /= Id
then
6050 Error_Msg_Name_1
:= Pname
;
6051 Error_Msg_Name_2
:= Id
;
6052 Error_Msg_N
("pragma% argument expects identifier%", Arg
);
6056 end Check_Optional_Identifier
;
6058 procedure Check_Optional_Identifier
(Arg
: Node_Id
; Id
: String) is
6060 Check_Optional_Identifier
(Arg
, Name_Find
(Id
));
6061 end Check_Optional_Identifier
;
6063 -------------------------------------
6064 -- Check_Static_Boolean_Expression --
6065 -------------------------------------
6067 procedure Check_Static_Boolean_Expression
(Expr
: Node_Id
) is
6069 if Present
(Expr
) then
6070 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
6072 if not Is_OK_Static_Expression
(Expr
) then
6074 ("expression of pragma % must be static", Expr
);
6077 end Check_Static_Boolean_Expression
;
6079 -----------------------------
6080 -- Check_Static_Constraint --
6081 -----------------------------
6083 -- Note: for convenience in writing this procedure, in addition to
6084 -- the officially (i.e. by spec) allowed argument which is always a
6085 -- constraint, it also allows ranges and discriminant associations.
6086 -- Above is not clear ???
6088 procedure Check_Static_Constraint
(Constr
: Node_Id
) is
6090 procedure Require_Static
(E
: Node_Id
);
6091 -- Require given expression to be static expression
6093 --------------------
6094 -- Require_Static --
6095 --------------------
6097 procedure Require_Static
(E
: Node_Id
) is
6099 if not Is_OK_Static_Expression
(E
) then
6100 Flag_Non_Static_Expr
6101 ("non-static constraint not allowed in Unchecked_Union!", E
);
6106 -- Start of processing for Check_Static_Constraint
6109 case Nkind
(Constr
) is
6110 when N_Discriminant_Association
=>
6111 Require_Static
(Expression
(Constr
));
6114 Require_Static
(Low_Bound
(Constr
));
6115 Require_Static
(High_Bound
(Constr
));
6117 when N_Attribute_Reference
=>
6118 Require_Static
(Type_Low_Bound
(Etype
(Prefix
(Constr
))));
6119 Require_Static
(Type_High_Bound
(Etype
(Prefix
(Constr
))));
6121 when N_Range_Constraint
=>
6122 Check_Static_Constraint
(Range_Expression
(Constr
));
6124 when N_Index_Or_Discriminant_Constraint
=>
6128 IDC
:= First
(Constraints
(Constr
));
6129 while Present
(IDC
) loop
6130 Check_Static_Constraint
(IDC
);
6138 end Check_Static_Constraint
;
6140 --------------------------------------
6141 -- Check_Valid_Configuration_Pragma --
6142 --------------------------------------
6144 -- A configuration pragma must appear in the context clause of a
6145 -- compilation unit, and only other pragmas may precede it. Note that
6146 -- the test also allows use in a configuration pragma file.
6148 procedure Check_Valid_Configuration_Pragma
is
6150 if not Is_Configuration_Pragma
then
6151 Error_Pragma
("incorrect placement for configuration pragma%");
6153 end Check_Valid_Configuration_Pragma
;
6155 -------------------------------------
6156 -- Check_Valid_Library_Unit_Pragma --
6157 -------------------------------------
6159 procedure Check_Valid_Library_Unit_Pragma
is
6161 Parent_Node
: Node_Id
;
6162 Unit_Name
: Entity_Id
;
6163 Unit_Kind
: Node_Kind
;
6164 Unit_Node
: Node_Id
;
6165 Sindex
: Source_File_Index
;
6168 if not Is_List_Member
(N
) then
6172 Plist
:= List_Containing
(N
);
6173 Parent_Node
:= Parent
(Plist
);
6175 if Parent_Node
= Empty
then
6178 -- Case of pragma appearing after a compilation unit. In this case
6179 -- it must have an argument with the corresponding name and must
6180 -- be part of the following pragmas of its parent.
6182 elsif Nkind
(Parent_Node
) = N_Compilation_Unit_Aux
then
6183 if Plist
/= Pragmas_After
(Parent_Node
) then
6186 elsif Arg_Count
= 0 then
6188 ("argument required if outside compilation unit");
6191 Check_No_Identifiers
;
6192 Check_Arg_Count
(1);
6193 Unit_Node
:= Unit
(Parent
(Parent_Node
));
6194 Unit_Kind
:= Nkind
(Unit_Node
);
6196 Analyze
(Get_Pragma_Arg
(Arg1
));
6198 if Unit_Kind
= N_Generic_Subprogram_Declaration
6199 or else Unit_Kind
= N_Subprogram_Declaration
6201 Unit_Name
:= Defining_Entity
(Unit_Node
);
6203 elsif Unit_Kind
in N_Generic_Instantiation
then
6204 Unit_Name
:= Defining_Entity
(Unit_Node
);
6207 Unit_Name
:= Cunit_Entity
(Current_Sem_Unit
);
6210 if Chars
(Unit_Name
) /=
6211 Chars
(Entity
(Get_Pragma_Arg
(Arg1
)))
6214 ("pragma% argument is not current unit name", Arg1
);
6217 if Ekind
(Unit_Name
) = E_Package
6218 and then Present
(Renamed_Entity
(Unit_Name
))
6220 Error_Pragma
("pragma% not allowed for renamed package");
6224 -- Pragma appears other than after a compilation unit
6227 -- Here we check for the generic instantiation case and also
6228 -- for the case of processing a generic formal package. We
6229 -- detect these cases by noting that the Sloc on the node
6230 -- does not belong to the current compilation unit.
6232 Sindex
:= Source_Index
(Current_Sem_Unit
);
6234 if Loc
not in Source_First
(Sindex
) .. Source_Last
(Sindex
) then
6235 Rewrite
(N
, Make_Null_Statement
(Loc
));
6238 -- If before first declaration, the pragma applies to the
6239 -- enclosing unit, and the name if present must be this name.
6241 elsif Is_Before_First_Decl
(N
, Plist
) then
6242 Unit_Node
:= Unit_Declaration_Node
(Current_Scope
);
6243 Unit_Kind
:= Nkind
(Unit_Node
);
6245 if Nkind
(Parent
(Unit_Node
)) /= N_Compilation_Unit
then
6248 elsif Unit_Kind
= N_Subprogram_Body
6249 and then not Acts_As_Spec
(Unit_Node
)
6253 elsif Nkind
(Parent_Node
) = N_Package_Body
then
6256 elsif Nkind
(Parent_Node
) = N_Package_Specification
6257 and then Plist
= Private_Declarations
(Parent_Node
)
6261 elsif (Nkind
(Parent_Node
) = N_Generic_Package_Declaration
6262 or else Nkind
(Parent_Node
) =
6263 N_Generic_Subprogram_Declaration
)
6264 and then Plist
= Generic_Formal_Declarations
(Parent_Node
)
6268 elsif Arg_Count
> 0 then
6269 Analyze
(Get_Pragma_Arg
(Arg1
));
6271 if Entity
(Get_Pragma_Arg
(Arg1
)) /= Current_Scope
then
6273 ("name in pragma% must be enclosing unit", Arg1
);
6276 -- It is legal to have no argument in this context
6282 -- Error if not before first declaration. This is because a
6283 -- library unit pragma argument must be the name of a library
6284 -- unit (RM 10.1.5(7)), but the only names permitted in this
6285 -- context are (RM 10.1.5(6)) names of subprogram declarations,
6286 -- generic subprogram declarations or generic instantiations.
6290 ("pragma% misplaced, must be before first declaration");
6294 end Check_Valid_Library_Unit_Pragma
;
6300 procedure Check_Variant
(Variant
: Node_Id
; UU_Typ
: Entity_Id
) is
6301 Clist
: constant Node_Id
:= Component_List
(Variant
);
6305 Comp
:= First
(Component_Items
(Clist
));
6306 while Present
(Comp
) loop
6307 Check_Component
(Comp
, UU_Typ
, In_Variant_Part
=> True);
6312 ---------------------------
6313 -- Ensure_Aggregate_Form --
6314 ---------------------------
6316 procedure Ensure_Aggregate_Form
(Arg
: Node_Id
) is
6317 CFSD
: constant Boolean := Get_Comes_From_Source_Default
;
6318 Expr
: constant Node_Id
:= Expression
(Arg
);
6319 Loc
: constant Source_Ptr
:= Sloc
(Expr
);
6320 Comps
: List_Id
:= No_List
;
6321 Exprs
: List_Id
:= No_List
;
6322 Nam
: Name_Id
:= No_Name
;
6323 Nam_Loc
: Source_Ptr
;
6326 -- The pragma argument is in positional form:
6328 -- pragma Depends (Nam => ...)
6332 -- Note that the Sloc of the Chars field is the Sloc of the pragma
6333 -- argument association.
6335 if Nkind
(Arg
) = N_Pragma_Argument_Association
then
6337 Nam_Loc
:= Sloc
(Arg
);
6339 -- Remove the pragma argument name as this will be captured in the
6342 Set_Chars
(Arg
, No_Name
);
6345 -- The argument is already in aggregate form, but the presence of a
6346 -- name causes this to be interpreted as named association which in
6347 -- turn must be converted into an aggregate.
6349 -- pragma Global (In_Out => (A, B, C))
6353 -- pragma Global ((In_Out => (A, B, C)))
6355 -- aggregate aggregate
6357 if Nkind
(Expr
) = N_Aggregate
then
6358 if Nam
= No_Name
then
6362 -- Do not transform a null argument into an aggregate as N_Null has
6363 -- special meaning in formal verification pragmas.
6365 elsif Nkind
(Expr
) = N_Null
then
6369 -- Everything comes from source if the original comes from source
6371 Set_Comes_From_Source_Default
(Comes_From_Source
(Arg
));
6373 -- Positional argument is transformed into an aggregate with an
6374 -- Expressions list.
6376 if Nam
= No_Name
then
6377 Exprs
:= New_List
(Relocate_Node
(Expr
));
6379 -- An associative argument is transformed into an aggregate with
6380 -- Component_Associations.
6384 Make_Component_Association
(Loc
,
6385 Choices
=> New_List
(Make_Identifier
(Nam_Loc
, Nam
)),
6386 Expression
=> Relocate_Node
(Expr
)));
6389 Set_Expression
(Arg
,
6390 Make_Aggregate
(Loc
,
6391 Component_Associations
=> Comps
,
6392 Expressions
=> Exprs
));
6394 -- Restore Comes_From_Source default
6396 Set_Comes_From_Source_Default
(CFSD
);
6397 end Ensure_Aggregate_Form
;
6403 procedure Error_Pragma
(Msg
: String) is
6405 Error_Msg_Name_1
:= Pname
;
6406 Error_Msg_N
(Fix_Error
(Msg
), N
);
6410 ----------------------
6411 -- Error_Pragma_Arg --
6412 ----------------------
6414 procedure Error_Pragma_Arg
(Msg
: String; Arg
: Node_Id
) is
6416 Error_Msg_Name_1
:= Pname
;
6417 Error_Msg_N
(Fix_Error
(Msg
), Get_Pragma_Arg
(Arg
));
6419 end Error_Pragma_Arg
;
6421 procedure Error_Pragma_Arg
(Msg1
, Msg2
: String; Arg
: Node_Id
) is
6423 Error_Msg_Name_1
:= Pname
;
6424 Error_Msg_N
(Fix_Error
(Msg1
), Get_Pragma_Arg
(Arg
));
6425 Error_Pragma_Arg
(Msg2
, Arg
);
6426 end Error_Pragma_Arg
;
6428 ----------------------------
6429 -- Error_Pragma_Arg_Ident --
6430 ----------------------------
6432 procedure Error_Pragma_Arg_Ident
(Msg
: String; Arg
: Node_Id
) is
6434 Error_Msg_Name_1
:= Pname
;
6435 Error_Msg_N
(Fix_Error
(Msg
), Arg
);
6437 end Error_Pragma_Arg_Ident
;
6439 ----------------------
6440 -- Error_Pragma_Ref --
6441 ----------------------
6443 procedure Error_Pragma_Ref
(Msg
: String; Ref
: Entity_Id
) is
6445 Error_Msg_Name_1
:= Pname
;
6446 Error_Msg_Sloc
:= Sloc
(Ref
);
6447 Error_Msg_NE
(Fix_Error
(Msg
), N
, Ref
);
6449 end Error_Pragma_Ref
;
6451 ------------------------
6452 -- Find_Lib_Unit_Name --
6453 ------------------------
6455 function Find_Lib_Unit_Name
return Entity_Id
is
6457 -- Return inner compilation unit entity, for case of nested
6458 -- categorization pragmas. This happens in generic unit.
6460 if Nkind
(Parent
(N
)) = N_Package_Specification
6461 and then Defining_Entity
(Parent
(N
)) /= Current_Scope
6463 return Defining_Entity
(Parent
(N
));
6465 return Current_Scope
;
6467 end Find_Lib_Unit_Name
;
6469 ----------------------------
6470 -- Find_Program_Unit_Name --
6471 ----------------------------
6473 procedure Find_Program_Unit_Name
(Id
: Node_Id
) is
6474 Unit_Name
: Entity_Id
;
6475 Unit_Kind
: Node_Kind
;
6476 P
: constant Node_Id
:= Parent
(N
);
6479 if Nkind
(P
) = N_Compilation_Unit
then
6480 Unit_Kind
:= Nkind
(Unit
(P
));
6482 if Nkind_In
(Unit_Kind
, N_Subprogram_Declaration
,
6483 N_Package_Declaration
)
6484 or else Unit_Kind
in N_Generic_Declaration
6486 Unit_Name
:= Defining_Entity
(Unit
(P
));
6488 if Chars
(Id
) = Chars
(Unit_Name
) then
6489 Set_Entity
(Id
, Unit_Name
);
6490 Set_Etype
(Id
, Etype
(Unit_Name
));
6492 Set_Etype
(Id
, Any_Type
);
6494 ("cannot find program unit referenced by pragma%");
6498 Set_Etype
(Id
, Any_Type
);
6499 Error_Pragma
("pragma% inapplicable to this unit");
6505 end Find_Program_Unit_Name
;
6507 -----------------------------------------
6508 -- Find_Unique_Parameterless_Procedure --
6509 -----------------------------------------
6511 function Find_Unique_Parameterless_Procedure
6513 Arg
: Node_Id
) return Entity_Id
6515 Proc
: Entity_Id
:= Empty
;
6518 -- The body of this procedure needs some comments ???
6520 if not Is_Entity_Name
(Name
) then
6522 ("argument of pragma% must be entity name", Arg
);
6524 elsif not Is_Overloaded
(Name
) then
6525 Proc
:= Entity
(Name
);
6527 if Ekind
(Proc
) /= E_Procedure
6528 or else Present
(First_Formal
(Proc
))
6531 ("argument of pragma% must be parameterless procedure", Arg
);
6536 Found
: Boolean := False;
6538 Index
: Interp_Index
;
6541 Get_First_Interp
(Name
, Index
, It
);
6542 while Present
(It
.Nam
) loop
6545 if Ekind
(Proc
) = E_Procedure
6546 and then No
(First_Formal
(Proc
))
6550 Set_Entity
(Name
, Proc
);
6551 Set_Is_Overloaded
(Name
, False);
6554 ("ambiguous handler name for pragma% ", Arg
);
6558 Get_Next_Interp
(Index
, It
);
6563 ("argument of pragma% must be parameterless procedure",
6566 Proc
:= Entity
(Name
);
6572 end Find_Unique_Parameterless_Procedure
;
6578 function Fix_Error
(Msg
: String) return String is
6579 Res
: String (Msg
'Range) := Msg
;
6580 Res_Last
: Natural := Msg
'Last;
6584 -- If we have a rewriting of another pragma, go to that pragma
6586 if Is_Rewrite_Substitution
(N
)
6587 and then Nkind
(Original_Node
(N
)) = N_Pragma
6589 Error_Msg_Name_1
:= Pragma_Name
(Original_Node
(N
));
6592 -- Case where pragma comes from an aspect specification
6594 if From_Aspect_Specification
(N
) then
6596 -- Change appearence of "pragma" in message to "aspect"
6599 while J
<= Res_Last
- 5 loop
6600 if Res
(J
.. J
+ 5) = "pragma" then
6601 Res
(J
.. J
+ 5) := "aspect";
6609 -- Change "argument of" at start of message to "entity for"
6612 and then Res
(Res
'First .. Res
'First + 10) = "argument of"
6614 Res
(Res
'First .. Res
'First + 9) := "entity for";
6615 Res
(Res
'First + 10 .. Res_Last
- 1) :=
6616 Res
(Res
'First + 11 .. Res_Last
);
6617 Res_Last
:= Res_Last
- 1;
6620 -- Change "argument" at start of message to "entity"
6623 and then Res
(Res
'First .. Res
'First + 7) = "argument"
6625 Res
(Res
'First .. Res
'First + 5) := "entity";
6626 Res
(Res
'First + 6 .. Res_Last
- 2) :=
6627 Res
(Res
'First + 8 .. Res_Last
);
6628 Res_Last
:= Res_Last
- 2;
6631 -- Get name from corresponding aspect
6633 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(N
);
6636 -- Return possibly modified message
6638 return Res
(Res
'First .. Res_Last
);
6641 -------------------------
6642 -- Gather_Associations --
6643 -------------------------
6645 procedure Gather_Associations
6647 Args
: out Args_List
)
6652 -- Initialize all parameters to Empty
6654 for J
in Args
'Range loop
6658 -- That's all we have to do if there are no argument associations
6660 if No
(Pragma_Argument_Associations
(N
)) then
6664 -- Otherwise first deal with any positional parameters present
6666 Arg
:= First
(Pragma_Argument_Associations
(N
));
6667 for Index
in Args
'Range loop
6668 exit when No
(Arg
) or else Chars
(Arg
) /= No_Name
;
6669 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6673 -- Positional parameters all processed, if any left, then we
6674 -- have too many positional parameters.
6676 if Present
(Arg
) and then Chars
(Arg
) = No_Name
then
6678 ("too many positional associations for pragma%", Arg
);
6681 -- Process named parameters if any are present
6683 while Present
(Arg
) loop
6684 if Chars
(Arg
) = No_Name
then
6686 ("positional association cannot follow named association",
6690 for Index
in Names
'Range loop
6691 if Names
(Index
) = Chars
(Arg
) then
6692 if Present
(Args
(Index
)) then
6694 ("duplicate argument association for pragma%", Arg
);
6696 Args
(Index
) := Get_Pragma_Arg
(Arg
);
6701 if Index
= Names
'Last then
6702 Error_Msg_Name_1
:= Pname
;
6703 Error_Msg_N
("pragma% does not allow & argument", Arg
);
6705 -- Check for possible misspelling
6707 for Index1
in Names
'Range loop
6708 if Is_Bad_Spelling_Of
6709 (Chars
(Arg
), Names
(Index1
))
6711 Error_Msg_Name_1
:= Names
(Index1
);
6712 Error_Msg_N
-- CODEFIX
6713 ("\possible misspelling of%", Arg
);
6725 end Gather_Associations
;
6731 procedure GNAT_Pragma
is
6733 -- We need to check the No_Implementation_Pragmas restriction for
6734 -- the case of a pragma from source. Note that the case of aspects
6735 -- generating corresponding pragmas marks these pragmas as not being
6736 -- from source, so this test also catches that case.
6738 if Comes_From_Source
(N
) then
6739 Check_Restriction
(No_Implementation_Pragmas
, N
);
6743 --------------------------
6744 -- Is_Before_First_Decl --
6745 --------------------------
6747 function Is_Before_First_Decl
6748 (Pragma_Node
: Node_Id
;
6749 Decls
: List_Id
) return Boolean
6751 Item
: Node_Id
:= First
(Decls
);
6754 -- Only other pragmas can come before this pragma
6757 if No
(Item
) or else Nkind
(Item
) /= N_Pragma
then
6760 elsif Item
= Pragma_Node
then
6766 end Is_Before_First_Decl
;
6768 -----------------------------
6769 -- Is_Configuration_Pragma --
6770 -----------------------------
6772 -- A configuration pragma must appear in the context clause of a
6773 -- compilation unit, and only other pragmas may precede it. Note that
6774 -- the test below also permits use in a configuration pragma file.
6776 function Is_Configuration_Pragma
return Boolean is
6777 Lis
: constant List_Id
:= List_Containing
(N
);
6778 Par
: constant Node_Id
:= Parent
(N
);
6782 -- If no parent, then we are in the configuration pragma file,
6783 -- so the placement is definitely appropriate.
6788 -- Otherwise we must be in the context clause of a compilation unit
6789 -- and the only thing allowed before us in the context list is more
6790 -- configuration pragmas.
6792 elsif Nkind
(Par
) = N_Compilation_Unit
6793 and then Context_Items
(Par
) = Lis
6800 elsif Nkind
(Prg
) /= N_Pragma
then
6810 end Is_Configuration_Pragma
;
6812 --------------------------
6813 -- Is_In_Context_Clause --
6814 --------------------------
6816 function Is_In_Context_Clause
return Boolean is
6818 Parent_Node
: Node_Id
;
6821 if not Is_List_Member
(N
) then
6825 Plist
:= List_Containing
(N
);
6826 Parent_Node
:= Parent
(Plist
);
6828 if Parent_Node
= Empty
6829 or else Nkind
(Parent_Node
) /= N_Compilation_Unit
6830 or else Context_Items
(Parent_Node
) /= Plist
6837 end Is_In_Context_Clause
;
6839 ---------------------------------
6840 -- Is_Static_String_Expression --
6841 ---------------------------------
6843 function Is_Static_String_Expression
(Arg
: Node_Id
) return Boolean is
6844 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
6845 Lit
: constant Boolean := Nkind
(Argx
) = N_String_Literal
;
6848 Analyze_And_Resolve
(Argx
);
6850 -- Special case Ada 83, where the expression will never be static,
6851 -- but we will return true if we had a string literal to start with.
6853 if Ada_Version
= Ada_83
then
6856 -- Normal case, true only if we end up with a string literal that
6857 -- is marked as being the result of evaluating a static expression.
6860 return Is_OK_Static_Expression
(Argx
)
6861 and then Nkind
(Argx
) = N_String_Literal
;
6864 end Is_Static_String_Expression
;
6866 ----------------------
6867 -- Pragma_Misplaced --
6868 ----------------------
6870 procedure Pragma_Misplaced
is
6872 Error_Pragma
("incorrect placement of pragma%");
6873 end Pragma_Misplaced
;
6875 ------------------------------------------------
6876 -- Process_Atomic_Independent_Shared_Volatile --
6877 ------------------------------------------------
6879 procedure Process_Atomic_Independent_Shared_Volatile
is
6880 procedure Set_Atomic_VFA
(E
: Entity_Id
);
6881 -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if
6882 -- no explicit alignment was given, set alignment to unknown, since
6883 -- back end knows what the alignment requirements are for atomic and
6884 -- full access arrays. Note: this is necessary for derived types.
6886 --------------------
6887 -- Set_Atomic_VFA --
6888 --------------------
6890 procedure Set_Atomic_VFA
(E
: Entity_Id
) is
6892 if Prag_Id
= Pragma_Volatile_Full_Access
then
6893 Set_Is_Volatile_Full_Access
(E
);
6898 if not Has_Alignment_Clause
(E
) then
6899 Set_Alignment
(E
, Uint_0
);
6909 -- Start of processing for Process_Atomic_Independent_Shared_Volatile
6912 Check_Ada_83_Warning
;
6913 Check_No_Identifiers
;
6914 Check_Arg_Count
(1);
6915 Check_Arg_Is_Local_Name
(Arg1
);
6916 E_Arg
:= Get_Pragma_Arg
(Arg1
);
6918 if Etype
(E_Arg
) = Any_Type
then
6922 E
:= Entity
(E_Arg
);
6924 -- A pragma that applies to a Ghost entity becomes Ghost for the
6925 -- purposes of legality checks and removal of ignored Ghost code.
6927 Mark_Ghost_Pragma
(N
, E
);
6929 -- Check duplicate before we chain ourselves
6931 Check_Duplicate_Pragma
(E
);
6933 -- Check Atomic and VFA used together
6935 if (Is_Atomic
(E
) and then Prag_Id
= Pragma_Volatile_Full_Access
)
6936 or else (Is_Volatile_Full_Access
(E
)
6937 and then (Prag_Id
= Pragma_Atomic
6939 Prag_Id
= Pragma_Shared
))
6942 ("cannot have Volatile_Full_Access and Atomic for same entity");
6945 -- Check for applying VFA to an entity which has aliased component
6947 if Prag_Id
= Pragma_Volatile_Full_Access
then
6950 Aliased_Comp
: Boolean := False;
6951 -- Set True if aliased component present
6954 if Is_Array_Type
(Etype
(E
)) then
6955 Aliased_Comp
:= Has_Aliased_Components
(Etype
(E
));
6957 -- Record case, too bad Has_Aliased_Components is not also
6958 -- set for records, should it be ???
6960 elsif Is_Record_Type
(Etype
(E
)) then
6961 Comp
:= First_Component_Or_Discriminant
(Etype
(E
));
6962 while Present
(Comp
) loop
6963 if Is_Aliased
(Comp
)
6964 or else Is_Aliased
(Etype
(Comp
))
6966 Aliased_Comp
:= True;
6970 Next_Component_Or_Discriminant
(Comp
);
6974 if Aliased_Comp
then
6976 ("cannot apply Volatile_Full_Access (aliased component "
6982 -- Now check appropriateness of the entity
6984 Decl
:= Declaration_Node
(E
);
6987 if Rep_Item_Too_Early
(E
, N
)
6989 Rep_Item_Too_Late
(E
, N
)
6993 Check_First_Subtype
(Arg1
);
6996 -- Attribute belongs on the base type. If the view of the type is
6997 -- currently private, it also belongs on the underlying type.
6999 if Prag_Id
= Pragma_Atomic
7001 Prag_Id
= Pragma_Shared
7003 Prag_Id
= Pragma_Volatile_Full_Access
7006 Set_Atomic_VFA
(Base_Type
(E
));
7007 Set_Atomic_VFA
(Underlying_Type
(E
));
7010 -- Atomic/Shared/Volatile_Full_Access imply Independent
7012 if Prag_Id
/= Pragma_Volatile
then
7013 Set_Is_Independent
(E
);
7014 Set_Is_Independent
(Base_Type
(E
));
7015 Set_Is_Independent
(Underlying_Type
(E
));
7017 if Prag_Id
= Pragma_Independent
then
7018 Record_Independence_Check
(N
, Base_Type
(E
));
7022 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7024 if Prag_Id
/= Pragma_Independent
then
7025 Set_Is_Volatile
(E
);
7026 Set_Is_Volatile
(Base_Type
(E
));
7027 Set_Is_Volatile
(Underlying_Type
(E
));
7029 Set_Treat_As_Volatile
(E
);
7030 Set_Treat_As_Volatile
(Underlying_Type
(E
));
7033 elsif Nkind
(Decl
) = N_Object_Declaration
7034 or else (Nkind
(Decl
) = N_Component_Declaration
7035 and then Original_Record_Component
(E
) = E
)
7037 if Rep_Item_Too_Late
(E
, N
) then
7041 if Prag_Id
= Pragma_Atomic
7043 Prag_Id
= Pragma_Shared
7045 Prag_Id
= Pragma_Volatile_Full_Access
7047 if Prag_Id
= Pragma_Volatile_Full_Access
then
7048 Set_Is_Volatile_Full_Access
(E
);
7053 -- If the object declaration has an explicit initialization, a
7054 -- temporary may have to be created to hold the expression, to
7055 -- ensure that access to the object remain atomic.
7057 if Nkind
(Parent
(E
)) = N_Object_Declaration
7058 and then Present
(Expression
(Parent
(E
)))
7060 Set_Has_Delayed_Freeze
(E
);
7064 -- Atomic/Shared/Volatile_Full_Access imply Independent
7066 if Prag_Id
/= Pragma_Volatile
then
7067 Set_Is_Independent
(E
);
7069 if Prag_Id
= Pragma_Independent
then
7070 Record_Independence_Check
(N
, E
);
7074 -- Atomic/Shared/Volatile_Full_Access imply Volatile
7076 if Prag_Id
/= Pragma_Independent
then
7077 Set_Is_Volatile
(E
);
7078 Set_Treat_As_Volatile
(E
);
7082 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
7085 -- The following check is only relevant when SPARK_Mode is on as
7086 -- this is not a standard Ada legality rule. Pragma Volatile can
7087 -- only apply to a full type declaration or an object declaration
7088 -- (SPARK RM 7.1.3(2)). Original_Node is necessary to account for
7089 -- untagged derived types that are rewritten as subtypes of their
7090 -- respective root types.
7093 and then Prag_Id
= Pragma_Volatile
7095 not Nkind_In
(Original_Node
(Decl
), N_Full_Type_Declaration
,
7096 N_Object_Declaration
)
7099 ("argument of pragma % must denote a full type or object "
7100 & "declaration", Arg1
);
7102 end Process_Atomic_Independent_Shared_Volatile
;
7104 -------------------------------------------
7105 -- Process_Compile_Time_Warning_Or_Error --
7106 -------------------------------------------
7108 procedure Process_Compile_Time_Warning_Or_Error
is
7109 Validation_Needed
: Boolean := False;
7111 function Check_Node
(N
: Node_Id
) return Traverse_Result
;
7112 -- Tree visitor that checks if N is an attribute reference that can
7113 -- be statically computed by the back end. Validation_Needed is set
7114 -- to True if found.
7120 function Check_Node
(N
: Node_Id
) return Traverse_Result
is
7122 if Nkind
(N
) = N_Attribute_Reference
7123 and then Is_Entity_Name
(Prefix
(N
))
7126 Attr_Id
: constant Attribute_Id
:=
7127 Get_Attribute_Id
(Attribute_Name
(N
));
7129 if Attr_Id
= Attribute_Alignment
7130 or else Attr_Id
= Attribute_Size
7132 Validation_Needed
:= True;
7140 procedure Check_Expression
is new Traverse_Proc
(Check_Node
);
7144 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7146 -- Start of processing for Process_Compile_Time_Warning_Or_Error
7149 Check_Arg_Count
(2);
7150 Check_No_Identifiers
;
7151 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
7152 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
7154 if Compile_Time_Known_Value
(Arg1x
) then
7155 Process_Compile_Time_Warning_Or_Error
(N
, Sloc
(Arg1
));
7157 -- Register the expression for its validation after the back end has
7158 -- been called if it has occurrences of attributes Size or Alignment
7159 -- (because they may be statically computed by the back end and hence
7160 -- the whole expression needs to be reevaluated).
7163 Check_Expression
(Arg1x
);
7165 if Validation_Needed
then
7166 Sem_Ch13
.Validate_Compile_Time_Warning_Error
(N
);
7169 end Process_Compile_Time_Warning_Or_Error
;
7171 ------------------------
7172 -- Process_Convention --
7173 ------------------------
7175 procedure Process_Convention
7176 (C
: out Convention_Id
;
7177 Ent
: out Entity_Id
)
7181 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
);
7182 -- Called if we have more than one Export/Import/Convention pragma.
7183 -- This is generally illegal, but we have a special case of allowing
7184 -- Import and Interface to coexist if they specify the convention in
7185 -- a consistent manner. We are allowed to do this, since Interface is
7186 -- an implementation defined pragma, and we choose to do it since we
7187 -- know Rational allows this combination. S is the entity id of the
7188 -- subprogram in question. This procedure also sets the special flag
7189 -- Import_Interface_Present in both pragmas in the case where we do
7190 -- have matching Import and Interface pragmas.
7192 procedure Set_Convention_From_Pragma
(E
: Entity_Id
);
7193 -- Set convention in entity E, and also flag that the entity has a
7194 -- convention pragma. If entity is for a private or incomplete type,
7195 -- also set convention and flag on underlying type. This procedure
7196 -- also deals with the special case of C_Pass_By_Copy convention,
7197 -- and error checks for inappropriate convention specification.
7199 -------------------------------
7200 -- Diagnose_Multiple_Pragmas --
7201 -------------------------------
7203 procedure Diagnose_Multiple_Pragmas
(S
: Entity_Id
) is
7204 Pdec
: constant Node_Id
:= Declaration_Node
(S
);
7208 function Same_Convention
(Decl
: Node_Id
) return Boolean;
7209 -- Decl is a pragma node. This function returns True if this
7210 -- pragma has a first argument that is an identifier with a
7211 -- Chars field corresponding to the Convention_Id C.
7213 function Same_Name
(Decl
: Node_Id
) return Boolean;
7214 -- Decl is a pragma node. This function returns True if this
7215 -- pragma has a second argument that is an identifier with a
7216 -- Chars field that matches the Chars of the current subprogram.
7218 ---------------------
7219 -- Same_Convention --
7220 ---------------------
7222 function Same_Convention
(Decl
: Node_Id
) return Boolean is
7223 Arg1
: constant Node_Id
:=
7224 First
(Pragma_Argument_Associations
(Decl
));
7227 if Present
(Arg1
) then
7229 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
7231 if Nkind
(Arg
) = N_Identifier
7232 and then Is_Convention_Name
(Chars
(Arg
))
7233 and then Get_Convention_Id
(Chars
(Arg
)) = C
7241 end Same_Convention
;
7247 function Same_Name
(Decl
: Node_Id
) return Boolean is
7248 Arg1
: constant Node_Id
:=
7249 First
(Pragma_Argument_Associations
(Decl
));
7257 Arg2
:= Next
(Arg1
);
7264 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
7266 if Nkind
(Arg
) = N_Identifier
7267 and then Chars
(Arg
) = Chars
(S
)
7276 -- Start of processing for Diagnose_Multiple_Pragmas
7281 -- Definitely give message if we have Convention/Export here
7283 if Prag_Id
= Pragma_Convention
or else Prag_Id
= Pragma_Export
then
7286 -- If we have an Import or Export, scan back from pragma to
7287 -- find any previous pragma applying to the same procedure.
7288 -- The scan will be terminated by the start of the list, or
7289 -- hitting the subprogram declaration. This won't allow one
7290 -- pragma to appear in the public part and one in the private
7291 -- part, but that seems very unlikely in practice.
7295 while Present
(Decl
) and then Decl
/= Pdec
loop
7297 -- Look for pragma with same name as us
7299 if Nkind
(Decl
) = N_Pragma
7300 and then Same_Name
(Decl
)
7302 -- Give error if same as our pragma or Export/Convention
7304 if Nam_In
(Pragma_Name_Unmapped
(Decl
),
7307 Pragma_Name_Unmapped
(N
))
7311 -- Case of Import/Interface or the other way round
7313 elsif Nam_In
(Pragma_Name_Unmapped
(Decl
),
7314 Name_Interface
, Name_Import
)
7316 -- Here we know that we have Import and Interface. It
7317 -- doesn't matter which way round they are. See if
7318 -- they specify the same convention. If so, all OK,
7319 -- and set special flags to stop other messages
7321 if Same_Convention
(Decl
) then
7322 Set_Import_Interface_Present
(N
);
7323 Set_Import_Interface_Present
(Decl
);
7326 -- If different conventions, special message
7329 Error_Msg_Sloc
:= Sloc
(Decl
);
7331 ("convention differs from that given#", Arg1
);
7341 -- Give message if needed if we fall through those tests
7342 -- except on Relaxed_RM_Semantics where we let go: either this
7343 -- is a case accepted/ignored by other Ada compilers (e.g.
7344 -- a mix of Convention and Import), or another error will be
7345 -- generated later (e.g. using both Import and Export).
7347 if Err
and not Relaxed_RM_Semantics
then
7349 ("at most one Convention/Export/Import pragma is allowed",
7352 end Diagnose_Multiple_Pragmas
;
7354 --------------------------------
7355 -- Set_Convention_From_Pragma --
7356 --------------------------------
7358 procedure Set_Convention_From_Pragma
(E
: Entity_Id
) is
7360 -- Ada 2005 (AI-430): Check invalid attempt to change convention
7361 -- for an overridden dispatching operation. Technically this is
7362 -- an amendment and should only be done in Ada 2005 mode. However,
7363 -- this is clearly a mistake, since the problem that is addressed
7364 -- by this AI is that there is a clear gap in the RM.
7366 if Is_Dispatching_Operation
(E
)
7367 and then Present
(Overridden_Operation
(E
))
7368 and then C
/= Convention
(Overridden_Operation
(E
))
7371 ("cannot change convention for overridden dispatching "
7372 & "operation", Arg1
);
7375 -- Special checks for Convention_Stdcall
7377 if C
= Convention_Stdcall
then
7379 -- A dispatching call is not allowed. A dispatching subprogram
7380 -- cannot be used to interface to the Win32 API, so in fact
7381 -- this check does not impose any effective restriction.
7383 if Is_Dispatching_Operation
(E
) then
7384 Error_Msg_Sloc
:= Sloc
(E
);
7386 -- Note: make this unconditional so that if there is more
7387 -- than one call to which the pragma applies, we get a
7388 -- message for each call. Also don't use Error_Pragma,
7389 -- so that we get multiple messages.
7392 ("dispatching subprogram# cannot use Stdcall convention!",
7395 -- Several allowed cases
7397 elsif Is_Subprogram_Or_Generic_Subprogram
(E
)
7401 or else Ekind
(E
) = E_Variable
7403 -- A component as well. The entity does not have its Ekind
7404 -- set until the enclosing record declaration is fully
7407 or else Nkind
(Parent
(E
)) = N_Component_Declaration
7409 -- An access to subprogram is also allowed
7413 and then Ekind
(Designated_Type
(E
)) = E_Subprogram_Type
)
7415 -- Allow internal call to set convention of subprogram type
7417 or else Ekind
(E
) = E_Subprogram_Type
7423 ("second argument of pragma% must be subprogram (type)",
7428 -- Set the convention
7430 Set_Convention
(E
, C
);
7431 Set_Has_Convention_Pragma
(E
);
7433 -- For the case of a record base type, also set the convention of
7434 -- any anonymous access types declared in the record which do not
7435 -- currently have a specified convention.
7437 if Is_Record_Type
(E
) and then Is_Base_Type
(E
) then
7442 Comp
:= First_Component
(E
);
7443 while Present
(Comp
) loop
7444 if Present
(Etype
(Comp
))
7445 and then Ekind_In
(Etype
(Comp
),
7446 E_Anonymous_Access_Type
,
7447 E_Anonymous_Access_Subprogram_Type
)
7448 and then not Has_Convention_Pragma
(Comp
)
7450 Set_Convention
(Comp
, C
);
7453 Next_Component
(Comp
);
7458 -- Deal with incomplete/private type case, where underlying type
7459 -- is available, so set convention of that underlying type.
7461 if Is_Incomplete_Or_Private_Type
(E
)
7462 and then Present
(Underlying_Type
(E
))
7464 Set_Convention
(Underlying_Type
(E
), C
);
7465 Set_Has_Convention_Pragma
(Underlying_Type
(E
), True);
7468 -- A class-wide type should inherit the convention of the specific
7469 -- root type (although this isn't specified clearly by the RM).
7471 if Is_Type
(E
) and then Present
(Class_Wide_Type
(E
)) then
7472 Set_Convention
(Class_Wide_Type
(E
), C
);
7475 -- If the entity is a record type, then check for special case of
7476 -- C_Pass_By_Copy, which is treated the same as C except that the
7477 -- special record flag is set. This convention is only permitted
7478 -- on record types (see AI95-00131).
7480 if Cname
= Name_C_Pass_By_Copy
then
7481 if Is_Record_Type
(E
) then
7482 Set_C_Pass_By_Copy
(Base_Type
(E
));
7483 elsif Is_Incomplete_Or_Private_Type
(E
)
7484 and then Is_Record_Type
(Underlying_Type
(E
))
7486 Set_C_Pass_By_Copy
(Base_Type
(Underlying_Type
(E
)));
7489 ("C_Pass_By_Copy convention allowed only for record type",
7494 -- If the entity is a derived boolean type, check for the special
7495 -- case of convention C, C++, or Fortran, where we consider any
7496 -- nonzero value to represent true.
7498 if Is_Discrete_Type
(E
)
7499 and then Root_Type
(Etype
(E
)) = Standard_Boolean
7505 C
= Convention_Fortran
)
7507 Set_Nonzero_Is_True
(Base_Type
(E
));
7509 end Set_Convention_From_Pragma
;
7513 Comp_Unit
: Unit_Number_Type
;
7518 -- Start of processing for Process_Convention
7521 Check_At_Least_N_Arguments
(2);
7522 Check_Optional_Identifier
(Arg1
, Name_Convention
);
7523 Check_Arg_Is_Identifier
(Arg1
);
7524 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
7526 -- C_Pass_By_Copy is treated as a synonym for convention C (this is
7527 -- tested again below to set the critical flag).
7529 if Cname
= Name_C_Pass_By_Copy
then
7532 -- Otherwise we must have something in the standard convention list
7534 elsif Is_Convention_Name
(Cname
) then
7535 C
:= Get_Convention_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
7537 -- Otherwise warn on unrecognized convention
7540 if Warn_On_Export_Import
then
7542 ("??unrecognized convention name, C assumed",
7543 Get_Pragma_Arg
(Arg1
));
7549 Check_Optional_Identifier
(Arg2
, Name_Entity
);
7550 Check_Arg_Is_Local_Name
(Arg2
);
7552 Id
:= Get_Pragma_Arg
(Arg2
);
7555 if not Is_Entity_Name
(Id
) then
7556 Error_Pragma_Arg
("entity name required", Arg2
);
7561 -- Set entity to return
7565 -- Ada_Pass_By_Copy special checking
7567 if C
= Convention_Ada_Pass_By_Copy
then
7568 if not Is_First_Subtype
(E
) then
7570 ("convention `Ada_Pass_By_Copy` only allowed for types",
7574 if Is_By_Reference_Type
(E
) then
7576 ("convention `Ada_Pass_By_Copy` not allowed for by-reference "
7580 -- Ada_Pass_By_Reference special checking
7582 elsif C
= Convention_Ada_Pass_By_Reference
then
7583 if not Is_First_Subtype
(E
) then
7585 ("convention `Ada_Pass_By_Reference` only allowed for types",
7589 if Is_By_Copy_Type
(E
) then
7591 ("convention `Ada_Pass_By_Reference` not allowed for by-copy "
7596 -- Go to renamed subprogram if present, since convention applies to
7597 -- the actual renamed entity, not to the renaming entity. If the
7598 -- subprogram is inherited, go to parent subprogram.
7600 if Is_Subprogram
(E
)
7601 and then Present
(Alias
(E
))
7603 if Nkind
(Parent
(Declaration_Node
(E
))) =
7604 N_Subprogram_Renaming_Declaration
7606 if Scope
(E
) /= Scope
(Alias
(E
)) then
7608 ("cannot apply pragma% to non-local entity&#", E
);
7613 elsif Nkind_In
(Parent
(E
), N_Full_Type_Declaration
,
7614 N_Private_Extension_Declaration
)
7615 and then Scope
(E
) = Scope
(Alias
(E
))
7619 -- Return the parent subprogram the entity was inherited from
7625 -- Check that we are not applying this to a specless body. Relax this
7626 -- check if Relaxed_RM_Semantics to accommodate other Ada compilers.
7628 if Is_Subprogram
(E
)
7629 and then Nkind
(Parent
(Declaration_Node
(E
))) = N_Subprogram_Body
7630 and then not Relaxed_RM_Semantics
7633 ("pragma% requires separate spec and must come before body");
7636 -- Check that we are not applying this to a named constant
7638 if Ekind_In
(E
, E_Named_Integer
, E_Named_Real
) then
7639 Error_Msg_Name_1
:= Pname
;
7641 ("cannot apply pragma% to named constant!",
7642 Get_Pragma_Arg
(Arg2
));
7644 ("\supply appropriate type for&!", Arg2
);
7647 if Ekind
(E
) = E_Enumeration_Literal
then
7648 Error_Pragma
("enumeration literal not allowed for pragma%");
7651 -- Check for rep item appearing too early or too late
7653 if Etype
(E
) = Any_Type
7654 or else Rep_Item_Too_Early
(E
, N
)
7658 elsif Present
(Underlying_Type
(E
)) then
7659 E
:= Underlying_Type
(E
);
7662 if Rep_Item_Too_Late
(E
, N
) then
7666 if Has_Convention_Pragma
(E
) then
7667 Diagnose_Multiple_Pragmas
(E
);
7669 elsif Convention
(E
) = Convention_Protected
7670 or else Ekind
(Scope
(E
)) = E_Protected_Type
7673 ("a protected operation cannot be given a different convention",
7677 -- For Intrinsic, a subprogram is required
7679 if C
= Convention_Intrinsic
7680 and then not Is_Subprogram_Or_Generic_Subprogram
(E
)
7682 -- Accept Intrinsic Export on types if Relaxed_RM_Semantics
7684 if not (Is_Type
(E
) and then Relaxed_RM_Semantics
) then
7686 ("second argument of pragma% must be a subprogram", Arg2
);
7690 -- Deal with non-subprogram cases
7692 if not Is_Subprogram_Or_Generic_Subprogram
(E
) then
7693 Set_Convention_From_Pragma
(E
);
7697 -- The pragma must apply to a first subtype, but it can also
7698 -- apply to a generic type in a generic formal part, in which
7699 -- case it will also appear in the corresponding instance.
7701 if Is_Generic_Type
(E
) or else In_Instance
then
7704 Check_First_Subtype
(Arg2
);
7707 Set_Convention_From_Pragma
(Base_Type
(E
));
7709 -- For access subprograms, we must set the convention on the
7710 -- internally generated directly designated type as well.
7712 if Ekind
(E
) = E_Access_Subprogram_Type
then
7713 Set_Convention_From_Pragma
(Directly_Designated_Type
(E
));
7717 -- For the subprogram case, set proper convention for all homonyms
7718 -- in same scope and the same declarative part, i.e. the same
7719 -- compilation unit.
7722 Comp_Unit
:= Get_Source_Unit
(E
);
7723 Set_Convention_From_Pragma
(E
);
7725 -- Treat a pragma Import as an implicit body, and pragma import
7726 -- as implicit reference (for navigation in GPS).
7728 if Prag_Id
= Pragma_Import
then
7729 Generate_Reference
(E
, Id
, 'b');
7731 -- For exported entities we restrict the generation of references
7732 -- to entities exported to foreign languages since entities
7733 -- exported to Ada do not provide further information to GPS and
7734 -- add undesired references to the output of the gnatxref tool.
7736 elsif Prag_Id
= Pragma_Export
7737 and then Convention
(E
) /= Convention_Ada
7739 Generate_Reference
(E
, Id
, 'i');
7742 -- If the pragma comes from an aspect, it only applies to the
7743 -- given entity, not its homonyms.
7745 if From_Aspect_Specification
(N
) then
7749 -- Otherwise Loop through the homonyms of the pragma argument's
7750 -- entity, an apply convention to those in the current scope.
7756 exit when No
(E1
) or else Scope
(E1
) /= Current_Scope
;
7758 -- Ignore entry for which convention is already set
7760 if Has_Convention_Pragma
(E1
) then
7764 if Is_Subprogram
(E1
)
7765 and then Nkind
(Parent
(Declaration_Node
(E1
))) =
7767 and then not Relaxed_RM_Semantics
7769 Set_Has_Completion
(E
); -- to prevent cascaded error
7771 ("pragma% requires separate spec and must come before "
7775 -- Do not set the pragma on inherited operations or on formal
7778 if Comes_From_Source
(E1
)
7779 and then Comp_Unit
= Get_Source_Unit
(E1
)
7780 and then not Is_Formal_Subprogram
(E1
)
7781 and then Nkind
(Original_Node
(Parent
(E1
))) /=
7782 N_Full_Type_Declaration
7784 if Present
(Alias
(E1
))
7785 and then Scope
(E1
) /= Scope
(Alias
(E1
))
7788 ("cannot apply pragma% to non-local entity& declared#",
7792 Set_Convention_From_Pragma
(E1
);
7794 if Prag_Id
= Pragma_Import
then
7795 Generate_Reference
(E1
, Id
, 'b');
7803 end Process_Convention
;
7805 ----------------------------------------
7806 -- Process_Disable_Enable_Atomic_Sync --
7807 ----------------------------------------
7809 procedure Process_Disable_Enable_Atomic_Sync
(Nam
: Name_Id
) is
7811 Check_No_Identifiers
;
7812 Check_At_Most_N_Arguments
(1);
7814 -- Modeled internally as
7815 -- pragma Suppress/Unsuppress (Atomic_Synchronization [,Entity])
7820 Pragma_Argument_Associations
=> New_List
(
7821 Make_Pragma_Argument_Association
(Loc
,
7823 Make_Identifier
(Loc
, Name_Atomic_Synchronization
)))));
7825 if Present
(Arg1
) then
7826 Append_To
(Pragma_Argument_Associations
(N
), New_Copy
(Arg1
));
7830 end Process_Disable_Enable_Atomic_Sync
;
7832 -------------------------------------------------
7833 -- Process_Extended_Import_Export_Internal_Arg --
7834 -------------------------------------------------
7836 procedure Process_Extended_Import_Export_Internal_Arg
7837 (Arg_Internal
: Node_Id
:= Empty
)
7840 if No
(Arg_Internal
) then
7841 Error_Pragma
("Internal parameter required for pragma%");
7844 if Nkind
(Arg_Internal
) = N_Identifier
then
7847 elsif Nkind
(Arg_Internal
) = N_Operator_Symbol
7848 and then (Prag_Id
= Pragma_Import_Function
7850 Prag_Id
= Pragma_Export_Function
)
7856 ("wrong form for Internal parameter for pragma%", Arg_Internal
);
7859 Check_Arg_Is_Local_Name
(Arg_Internal
);
7860 end Process_Extended_Import_Export_Internal_Arg
;
7862 --------------------------------------------------
7863 -- Process_Extended_Import_Export_Object_Pragma --
7864 --------------------------------------------------
7866 procedure Process_Extended_Import_Export_Object_Pragma
7867 (Arg_Internal
: Node_Id
;
7868 Arg_External
: Node_Id
;
7874 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
7875 Def_Id
:= Entity
(Arg_Internal
);
7877 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
7879 ("pragma% must designate an object", Arg_Internal
);
7882 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
7884 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
7887 ("previous Common/Psect_Object applies, pragma % not permitted",
7891 if Rep_Item_Too_Late
(Def_Id
, N
) then
7895 Set_Extended_Import_Export_External_Name
(Def_Id
, Arg_External
);
7897 if Present
(Arg_Size
) then
7898 Check_Arg_Is_External_Name
(Arg_Size
);
7901 -- Export_Object case
7903 if Prag_Id
= Pragma_Export_Object
then
7904 if not Is_Library_Level_Entity
(Def_Id
) then
7906 ("argument for pragma% must be library level entity",
7910 if Ekind
(Current_Scope
) = E_Generic_Package
then
7911 Error_Pragma
("pragma& cannot appear in a generic unit");
7914 if not Size_Known_At_Compile_Time
(Etype
(Def_Id
)) then
7916 ("exported object must have compile time known size",
7920 if Warn_On_Export_Import
and then Is_Exported
(Def_Id
) then
7921 Error_Msg_N
("??duplicate Export_Object pragma", N
);
7923 Set_Exported
(Def_Id
, Arg_Internal
);
7926 -- Import_Object case
7929 if Is_Concurrent_Type
(Etype
(Def_Id
)) then
7931 ("cannot use pragma% for task/protected object",
7935 if Ekind
(Def_Id
) = E_Constant
then
7937 ("cannot import a constant", Arg_Internal
);
7940 if Warn_On_Export_Import
7941 and then Has_Discriminants
(Etype
(Def_Id
))
7944 ("imported value must be initialized??", Arg_Internal
);
7947 if Warn_On_Export_Import
7948 and then Is_Access_Type
(Etype
(Def_Id
))
7951 ("cannot import object of an access type??", Arg_Internal
);
7954 if Warn_On_Export_Import
7955 and then Is_Imported
(Def_Id
)
7957 Error_Msg_N
("??duplicate Import_Object pragma", N
);
7959 -- Check for explicit initialization present. Note that an
7960 -- initialization generated by the code generator, e.g. for an
7961 -- access type, does not count here.
7963 elsif Present
(Expression
(Parent
(Def_Id
)))
7966 (Original_Node
(Expression
(Parent
(Def_Id
))))
7968 Error_Msg_Sloc
:= Sloc
(Def_Id
);
7970 ("imported entities cannot be initialized (RM B.1(24))",
7971 "\no initialization allowed for & declared#", Arg1
);
7973 Set_Imported
(Def_Id
);
7974 Note_Possible_Modification
(Arg_Internal
, Sure
=> False);
7977 end Process_Extended_Import_Export_Object_Pragma
;
7979 ------------------------------------------------------
7980 -- Process_Extended_Import_Export_Subprogram_Pragma --
7981 ------------------------------------------------------
7983 procedure Process_Extended_Import_Export_Subprogram_Pragma
7984 (Arg_Internal
: Node_Id
;
7985 Arg_External
: Node_Id
;
7986 Arg_Parameter_Types
: Node_Id
;
7987 Arg_Result_Type
: Node_Id
:= Empty
;
7988 Arg_Mechanism
: Node_Id
;
7989 Arg_Result_Mechanism
: Node_Id
:= Empty
)
7995 Ambiguous
: Boolean;
7998 function Same_Base_Type
8000 Formal
: Entity_Id
) return Boolean;
8001 -- Determines if Ptype references the type of Formal. Note that only
8002 -- the base types need to match according to the spec. Ptype here is
8003 -- the argument from the pragma, which is either a type name, or an
8004 -- access attribute.
8006 --------------------
8007 -- Same_Base_Type --
8008 --------------------
8010 function Same_Base_Type
8012 Formal
: Entity_Id
) return Boolean
8014 Ftyp
: constant Entity_Id
:= Base_Type
(Etype
(Formal
));
8018 -- Case where pragma argument is typ'Access
8020 if Nkind
(Ptype
) = N_Attribute_Reference
8021 and then Attribute_Name
(Ptype
) = Name_Access
8023 Pref
:= Prefix
(Ptype
);
8026 if not Is_Entity_Name
(Pref
)
8027 or else Entity
(Pref
) = Any_Type
8032 -- We have a match if the corresponding argument is of an
8033 -- anonymous access type, and its designated type matches the
8034 -- type of the prefix of the access attribute
8036 return Ekind
(Ftyp
) = E_Anonymous_Access_Type
8037 and then Base_Type
(Entity
(Pref
)) =
8038 Base_Type
(Etype
(Designated_Type
(Ftyp
)));
8040 -- Case where pragma argument is a type name
8045 if not Is_Entity_Name
(Ptype
)
8046 or else Entity
(Ptype
) = Any_Type
8051 -- We have a match if the corresponding argument is of the type
8052 -- given in the pragma (comparing base types)
8054 return Base_Type
(Entity
(Ptype
)) = Ftyp
;
8058 -- Start of processing for
8059 -- Process_Extended_Import_Export_Subprogram_Pragma
8062 Process_Extended_Import_Export_Internal_Arg
(Arg_Internal
);
8066 -- Loop through homonyms (overloadings) of the entity
8068 Hom_Id
:= Entity
(Arg_Internal
);
8069 while Present
(Hom_Id
) loop
8070 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8072 -- We need a subprogram in the current scope
8074 if not Is_Subprogram
(Def_Id
)
8075 or else Scope
(Def_Id
) /= Current_Scope
8082 -- Pragma cannot apply to subprogram body
8084 if Is_Subprogram
(Def_Id
)
8085 and then Nkind
(Parent
(Declaration_Node
(Def_Id
))) =
8089 ("pragma% requires separate spec and must come before "
8093 -- Test result type if given, note that the result type
8094 -- parameter can only be present for the function cases.
8096 if Present
(Arg_Result_Type
)
8097 and then not Same_Base_Type
(Arg_Result_Type
, Def_Id
)
8101 elsif Etype
(Def_Id
) /= Standard_Void_Type
8102 and then Nam_In
(Pname
, Name_Export_Procedure
,
8103 Name_Import_Procedure
)
8107 -- Test parameter types if given. Note that this parameter has
8108 -- not been analyzed (and must not be, since it is semantic
8109 -- nonsense), so we get it as the parser left it.
8111 elsif Present
(Arg_Parameter_Types
) then
8112 Check_Matching_Types
: declare
8117 Formal
:= First_Formal
(Def_Id
);
8119 if Nkind
(Arg_Parameter_Types
) = N_Null
then
8120 if Present
(Formal
) then
8124 -- A list of one type, e.g. (List) is parsed as a
8125 -- parenthesized expression.
8127 elsif Nkind
(Arg_Parameter_Types
) /= N_Aggregate
8128 and then Paren_Count
(Arg_Parameter_Types
) = 1
8131 or else Present
(Next_Formal
(Formal
))
8136 Same_Base_Type
(Arg_Parameter_Types
, Formal
);
8139 -- A list of more than one type is parsed as a aggregate
8141 elsif Nkind
(Arg_Parameter_Types
) = N_Aggregate
8142 and then Paren_Count
(Arg_Parameter_Types
) = 0
8144 Ptype
:= First
(Expressions
(Arg_Parameter_Types
));
8145 while Present
(Ptype
) or else Present
(Formal
) loop
8148 or else not Same_Base_Type
(Ptype
, Formal
)
8153 Next_Formal
(Formal
);
8158 -- Anything else is of the wrong form
8162 ("wrong form for Parameter_Types parameter",
8163 Arg_Parameter_Types
);
8165 end Check_Matching_Types
;
8168 -- Match is now False if the entry we found did not match
8169 -- either a supplied Parameter_Types or Result_Types argument
8175 -- Ambiguous case, the flag Ambiguous shows if we already
8176 -- detected this and output the initial messages.
8179 if not Ambiguous
then
8181 Error_Msg_Name_1
:= Pname
;
8183 ("pragma% does not uniquely identify subprogram!",
8185 Error_Msg_Sloc
:= Sloc
(Ent
);
8186 Error_Msg_N
("matching subprogram #!", N
);
8190 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8191 Error_Msg_N
("matching subprogram #!", N
);
8196 Hom_Id
:= Homonym
(Hom_Id
);
8199 -- See if we found an entry
8202 if not Ambiguous
then
8203 if Is_Generic_Subprogram
(Entity
(Arg_Internal
)) then
8205 ("pragma% cannot be given for generic subprogram");
8208 ("pragma% does not identify local subprogram");
8215 -- Import pragmas must be for imported entities
8217 if Prag_Id
= Pragma_Import_Function
8219 Prag_Id
= Pragma_Import_Procedure
8221 Prag_Id
= Pragma_Import_Valued_Procedure
8223 if not Is_Imported
(Ent
) then
8225 ("pragma Import or Interface must precede pragma%");
8228 -- Here we have the Export case which can set the entity as exported
8230 -- But does not do so if the specified external name is null, since
8231 -- that is taken as a signal in DEC Ada 83 (with which we want to be
8232 -- compatible) to request no external name.
8234 elsif Nkind
(Arg_External
) = N_String_Literal
8235 and then String_Length
(Strval
(Arg_External
)) = 0
8239 -- In all other cases, set entity as exported
8242 Set_Exported
(Ent
, Arg_Internal
);
8245 -- Special processing for Valued_Procedure cases
8247 if Prag_Id
= Pragma_Import_Valued_Procedure
8249 Prag_Id
= Pragma_Export_Valued_Procedure
8251 Formal
:= First_Formal
(Ent
);
8254 Error_Pragma
("at least one parameter required for pragma%");
8256 elsif Ekind
(Formal
) /= E_Out_Parameter
then
8257 Error_Pragma
("first parameter must have mode out for pragma%");
8260 Set_Is_Valued_Procedure
(Ent
);
8264 Set_Extended_Import_Export_External_Name
(Ent
, Arg_External
);
8266 -- Process Result_Mechanism argument if present. We have already
8267 -- checked that this is only allowed for the function case.
8269 if Present
(Arg_Result_Mechanism
) then
8270 Set_Mechanism_Value
(Ent
, Arg_Result_Mechanism
);
8273 -- Process Mechanism parameter if present. Note that this parameter
8274 -- is not analyzed, and must not be analyzed since it is semantic
8275 -- nonsense, so we get it in exactly as the parser left it.
8277 if Present
(Arg_Mechanism
) then
8285 -- A single mechanism association without a formal parameter
8286 -- name is parsed as a parenthesized expression. All other
8287 -- cases are parsed as aggregates, so we rewrite the single
8288 -- parameter case as an aggregate for consistency.
8290 if Nkind
(Arg_Mechanism
) /= N_Aggregate
8291 and then Paren_Count
(Arg_Mechanism
) = 1
8293 Rewrite
(Arg_Mechanism
,
8294 Make_Aggregate
(Sloc
(Arg_Mechanism
),
8295 Expressions
=> New_List
(
8296 Relocate_Node
(Arg_Mechanism
))));
8299 -- Case of only mechanism name given, applies to all formals
8301 if Nkind
(Arg_Mechanism
) /= N_Aggregate
then
8302 Formal
:= First_Formal
(Ent
);
8303 while Present
(Formal
) loop
8304 Set_Mechanism_Value
(Formal
, Arg_Mechanism
);
8305 Next_Formal
(Formal
);
8308 -- Case of list of mechanism associations given
8311 if Null_Record_Present
(Arg_Mechanism
) then
8313 ("inappropriate form for Mechanism parameter",
8317 -- Deal with positional ones first
8319 Formal
:= First_Formal
(Ent
);
8321 if Present
(Expressions
(Arg_Mechanism
)) then
8322 Mname
:= First
(Expressions
(Arg_Mechanism
));
8323 while Present
(Mname
) loop
8326 ("too many mechanism associations", Mname
);
8329 Set_Mechanism_Value
(Formal
, Mname
);
8330 Next_Formal
(Formal
);
8335 -- Deal with named entries
8337 if Present
(Component_Associations
(Arg_Mechanism
)) then
8338 Massoc
:= First
(Component_Associations
(Arg_Mechanism
));
8339 while Present
(Massoc
) loop
8340 Choice
:= First
(Choices
(Massoc
));
8342 if Nkind
(Choice
) /= N_Identifier
8343 or else Present
(Next
(Choice
))
8346 ("incorrect form for mechanism association",
8350 Formal
:= First_Formal
(Ent
);
8354 ("parameter name & not present", Choice
);
8357 if Chars
(Choice
) = Chars
(Formal
) then
8359 (Formal
, Expression
(Massoc
));
8361 -- Set entity on identifier (needed by ASIS)
8363 Set_Entity
(Choice
, Formal
);
8368 Next_Formal
(Formal
);
8377 end Process_Extended_Import_Export_Subprogram_Pragma
;
8379 --------------------------
8380 -- Process_Generic_List --
8381 --------------------------
8383 procedure Process_Generic_List
is
8388 Check_No_Identifiers
;
8389 Check_At_Least_N_Arguments
(1);
8391 -- Check all arguments are names of generic units or instances
8394 while Present
(Arg
) loop
8395 Exp
:= Get_Pragma_Arg
(Arg
);
8398 if not Is_Entity_Name
(Exp
)
8400 (not Is_Generic_Instance
(Entity
(Exp
))
8402 not Is_Generic_Unit
(Entity
(Exp
)))
8405 ("pragma% argument must be name of generic unit/instance",
8411 end Process_Generic_List
;
8413 ------------------------------------
8414 -- Process_Import_Predefined_Type --
8415 ------------------------------------
8417 procedure Process_Import_Predefined_Type
is
8418 Loc
: constant Source_Ptr
:= Sloc
(N
);
8420 Ftyp
: Node_Id
:= Empty
;
8426 Nam
:= String_To_Name
(Strval
(Expression
(Arg3
)));
8428 Elmt
:= First_Elmt
(Predefined_Float_Types
);
8429 while Present
(Elmt
) and then Chars
(Node
(Elmt
)) /= Nam
loop
8433 Ftyp
:= Node
(Elmt
);
8435 if Present
(Ftyp
) then
8437 -- Don't build a derived type declaration, because predefined C
8438 -- types have no declaration anywhere, so cannot really be named.
8439 -- Instead build a full type declaration, starting with an
8440 -- appropriate type definition is built
8442 if Is_Floating_Point_Type
(Ftyp
) then
8443 Def
:= Make_Floating_Point_Definition
(Loc
,
8444 Make_Integer_Literal
(Loc
, Digits_Value
(Ftyp
)),
8445 Make_Real_Range_Specification
(Loc
,
8446 Make_Real_Literal
(Loc
, Realval
(Type_Low_Bound
(Ftyp
))),
8447 Make_Real_Literal
(Loc
, Realval
(Type_High_Bound
(Ftyp
)))));
8449 -- Should never have a predefined type we cannot handle
8452 raise Program_Error
;
8455 -- Build and insert a Full_Type_Declaration, which will be
8456 -- analyzed as soon as this list entry has been analyzed.
8458 Decl
:= Make_Full_Type_Declaration
(Loc
,
8459 Make_Defining_Identifier
(Loc
, Chars
(Expression
(Arg2
))),
8460 Type_Definition
=> Def
);
8462 Insert_After
(N
, Decl
);
8463 Mark_Rewrite_Insertion
(Decl
);
8466 Error_Pragma_Arg
("no matching type found for pragma%",
8469 end Process_Import_Predefined_Type
;
8471 ---------------------------------
8472 -- Process_Import_Or_Interface --
8473 ---------------------------------
8475 procedure Process_Import_Or_Interface
is
8481 -- In Relaxed_RM_Semantics, support old Ada 83 style:
8482 -- pragma Import (Entity, "external name");
8484 if Relaxed_RM_Semantics
8485 and then Arg_Count
= 2
8486 and then Prag_Id
= Pragma_Import
8487 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
8490 Def_Id
:= Get_Pragma_Arg
(Arg1
);
8493 if not Is_Entity_Name
(Def_Id
) then
8494 Error_Pragma_Arg
("entity name required", Arg1
);
8497 Def_Id
:= Entity
(Def_Id
);
8498 Kill_Size_Check_Code
(Def_Id
);
8499 Note_Possible_Modification
(Get_Pragma_Arg
(Arg1
), Sure
=> False);
8502 Process_Convention
(C
, Def_Id
);
8504 -- A pragma that applies to a Ghost entity becomes Ghost for the
8505 -- purposes of legality checks and removal of ignored Ghost code.
8507 Mark_Ghost_Pragma
(N
, Def_Id
);
8508 Kill_Size_Check_Code
(Def_Id
);
8509 Note_Possible_Modification
(Get_Pragma_Arg
(Arg2
), Sure
=> False);
8512 -- Various error checks
8514 if Ekind_In
(Def_Id
, E_Variable
, E_Constant
) then
8516 -- We do not permit Import to apply to a renaming declaration
8518 if Present
(Renamed_Object
(Def_Id
)) then
8520 ("pragma% not allowed for object renaming", Arg2
);
8522 -- User initialization is not allowed for imported object, but
8523 -- the object declaration may contain a default initialization,
8524 -- that will be discarded. Note that an explicit initialization
8525 -- only counts if it comes from source, otherwise it is simply
8526 -- the code generator making an implicit initialization explicit.
8528 elsif Present
(Expression
(Parent
(Def_Id
)))
8529 and then Comes_From_Source
8530 (Original_Node
(Expression
(Parent
(Def_Id
))))
8532 -- Set imported flag to prevent cascaded errors
8534 Set_Is_Imported
(Def_Id
);
8536 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8538 ("no initialization allowed for declaration of& #",
8539 "\imported entities cannot be initialized (RM B.1(24))",
8543 -- If the pragma comes from an aspect specification the
8544 -- Is_Imported flag has already been set.
8546 if not From_Aspect_Specification
(N
) then
8547 Set_Imported
(Def_Id
);
8550 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8552 -- Note that we do not set Is_Public here. That's because we
8553 -- only want to set it if there is no address clause, and we
8554 -- don't know that yet, so we delay that processing till
8557 -- pragma Import completes deferred constants
8559 if Ekind
(Def_Id
) = E_Constant
then
8560 Set_Has_Completion
(Def_Id
);
8563 -- It is not possible to import a constant of an unconstrained
8564 -- array type (e.g. string) because there is no simple way to
8565 -- write a meaningful subtype for it.
8567 if Is_Array_Type
(Etype
(Def_Id
))
8568 and then not Is_Constrained
(Etype
(Def_Id
))
8571 ("imported constant& must have a constrained subtype",
8576 elsif Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8578 -- If the name is overloaded, pragma applies to all of the denoted
8579 -- entities in the same declarative part, unless the pragma comes
8580 -- from an aspect specification or was generated by the compiler
8581 -- (such as for pragma Provide_Shift_Operators).
8584 while Present
(Hom_Id
) loop
8586 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
8588 -- Ignore inherited subprograms because the pragma will apply
8589 -- to the parent operation, which is the one called.
8591 if Is_Overloadable
(Def_Id
)
8592 and then Present
(Alias
(Def_Id
))
8596 -- If it is not a subprogram, it must be in an outer scope and
8597 -- pragma does not apply.
8599 elsif not Is_Subprogram_Or_Generic_Subprogram
(Def_Id
) then
8602 -- The pragma does not apply to primitives of interfaces
8604 elsif Is_Dispatching_Operation
(Def_Id
)
8605 and then Present
(Find_Dispatching_Type
(Def_Id
))
8606 and then Is_Interface
(Find_Dispatching_Type
(Def_Id
))
8610 -- Verify that the homonym is in the same declarative part (not
8611 -- just the same scope). If the pragma comes from an aspect
8612 -- specification we know that it is part of the declaration.
8614 elsif Parent
(Unit_Declaration_Node
(Def_Id
)) /= Parent
(N
)
8615 and then Nkind
(Parent
(N
)) /= N_Compilation_Unit_Aux
8616 and then not From_Aspect_Specification
(N
)
8621 -- If the pragma comes from an aspect specification the
8622 -- Is_Imported flag has already been set.
8624 if not From_Aspect_Specification
(N
) then
8625 Set_Imported
(Def_Id
);
8628 -- Reject an Import applied to an abstract subprogram
8630 if Is_Subprogram
(Def_Id
)
8631 and then Is_Abstract_Subprogram
(Def_Id
)
8633 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8635 ("cannot import abstract subprogram& declared#",
8639 -- Special processing for Convention_Intrinsic
8641 if C
= Convention_Intrinsic
then
8643 -- Link_Name argument not allowed for intrinsic
8647 Set_Is_Intrinsic_Subprogram
(Def_Id
);
8649 -- If no external name is present, then check that this
8650 -- is a valid intrinsic subprogram. If an external name
8651 -- is present, then this is handled by the back end.
8654 Check_Intrinsic_Subprogram
8655 (Def_Id
, Get_Pragma_Arg
(Arg2
));
8659 -- Verify that the subprogram does not have a completion
8660 -- through a renaming declaration. For other completions the
8661 -- pragma appears as a too late representation.
8664 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Def_Id
);
8668 and then Nkind
(Decl
) = N_Subprogram_Declaration
8669 and then Present
(Corresponding_Body
(Decl
))
8670 and then Nkind
(Unit_Declaration_Node
8671 (Corresponding_Body
(Decl
))) =
8672 N_Subprogram_Renaming_Declaration
8674 Error_Msg_Sloc
:= Sloc
(Def_Id
);
8676 ("cannot import&, renaming already provided for "
8677 & "declaration #", N
, Def_Id
);
8681 -- If the pragma comes from an aspect specification, there
8682 -- must be an Import aspect specified as well. In the rare
8683 -- case where Import is set to False, the suprogram needs to
8684 -- have a local completion.
8687 Imp_Aspect
: constant Node_Id
:=
8688 Find_Aspect
(Def_Id
, Aspect_Import
);
8692 if Present
(Imp_Aspect
)
8693 and then Present
(Expression
(Imp_Aspect
))
8695 Expr
:= Expression
(Imp_Aspect
);
8696 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
8698 if Is_Entity_Name
(Expr
)
8699 and then Entity
(Expr
) = Standard_True
8701 Set_Has_Completion
(Def_Id
);
8704 -- If there is no expression, the default is True, as for
8705 -- all boolean aspects. Same for the older pragma.
8708 Set_Has_Completion
(Def_Id
);
8712 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
8715 if Is_Compilation_Unit
(Hom_Id
) then
8717 -- Its possible homonyms are not affected by the pragma.
8718 -- Such homonyms might be present in the context of other
8719 -- units being compiled.
8723 elsif From_Aspect_Specification
(N
) then
8726 -- If the pragma was created by the compiler, then we don't
8727 -- want it to apply to other homonyms. This kind of case can
8728 -- occur when using pragma Provide_Shift_Operators, which
8729 -- generates implicit shift and rotate operators with Import
8730 -- pragmas that might apply to earlier explicit or implicit
8731 -- declarations marked with Import (for example, coming from
8732 -- an earlier pragma Provide_Shift_Operators for another type),
8733 -- and we don't generally want other homonyms being treated
8734 -- as imported or the pragma flagged as an illegal duplicate.
8736 elsif not Comes_From_Source
(N
) then
8740 Hom_Id
:= Homonym
(Hom_Id
);
8744 -- Import a CPP class
8746 elsif C
= Convention_CPP
8747 and then (Is_Record_Type
(Def_Id
)
8748 or else Ekind
(Def_Id
) = E_Incomplete_Type
)
8750 if Ekind
(Def_Id
) = E_Incomplete_Type
then
8751 if Present
(Full_View
(Def_Id
)) then
8752 Def_Id
:= Full_View
(Def_Id
);
8756 ("cannot import 'C'P'P type before full declaration seen",
8757 Get_Pragma_Arg
(Arg2
));
8759 -- Although we have reported the error we decorate it as
8760 -- CPP_Class to avoid reporting spurious errors
8762 Set_Is_CPP_Class
(Def_Id
);
8767 -- Types treated as CPP classes must be declared limited (note:
8768 -- this used to be a warning but there is no real benefit to it
8769 -- since we did effectively intend to treat the type as limited
8772 if not Is_Limited_Type
(Def_Id
) then
8774 ("imported 'C'P'P type must be limited",
8775 Get_Pragma_Arg
(Arg2
));
8778 if Etype
(Def_Id
) /= Def_Id
8779 and then not Is_CPP_Class
(Root_Type
(Def_Id
))
8781 Error_Msg_N
("root type must be a 'C'P'P type", Arg1
);
8784 Set_Is_CPP_Class
(Def_Id
);
8786 -- Imported CPP types must not have discriminants (because C++
8787 -- classes do not have discriminants).
8789 if Has_Discriminants
(Def_Id
) then
8791 ("imported 'C'P'P type cannot have discriminants",
8792 First
(Discriminant_Specifications
8793 (Declaration_Node
(Def_Id
))));
8796 -- Check that components of imported CPP types do not have default
8797 -- expressions. For private types this check is performed when the
8798 -- full view is analyzed (see Process_Full_View).
8800 if not Is_Private_Type
(Def_Id
) then
8801 Check_CPP_Type_Has_No_Defaults
(Def_Id
);
8804 -- Import a CPP exception
8806 elsif C
= Convention_CPP
8807 and then Ekind
(Def_Id
) = E_Exception
8811 ("'External_'Name arguments is required for 'Cpp exception",
8814 -- As only a string is allowed, Check_Arg_Is_External_Name
8817 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8820 if Present
(Arg4
) then
8822 ("Link_Name argument not allowed for imported Cpp exception",
8826 -- Do not call Set_Interface_Name as the name of the exception
8827 -- shouldn't be modified (and in particular it shouldn't be
8828 -- the External_Name). For exceptions, the External_Name is the
8829 -- name of the RTTI structure.
8831 -- ??? Emit an error if pragma Import/Export_Exception is present
8833 elsif Nkind
(Parent
(Def_Id
)) = N_Incomplete_Type_Declaration
then
8835 Check_Arg_Count
(3);
8836 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
8838 Process_Import_Predefined_Type
;
8842 ("second argument of pragma% must be object, subprogram "
8843 & "or incomplete type",
8847 -- If this pragma applies to a compilation unit, then the unit, which
8848 -- is a subprogram, does not require (or allow) a body. We also do
8849 -- not need to elaborate imported procedures.
8851 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
8853 Cunit
: constant Node_Id
:= Parent
(Parent
(N
));
8855 Set_Body_Required
(Cunit
, False);
8858 end Process_Import_Or_Interface
;
8860 --------------------
8861 -- Process_Inline --
8862 --------------------
8864 procedure Process_Inline
(Status
: Inline_Status
) is
8871 Ghost_Error_Posted
: Boolean := False;
8872 -- Flag set when an error concerning the illegal mix of Ghost and
8873 -- non-Ghost subprograms is emitted.
8875 Ghost_Id
: Entity_Id
:= Empty
;
8876 -- The entity of the first Ghost subprogram encountered while
8877 -- processing the arguments of the pragma.
8879 procedure Make_Inline
(Subp
: Entity_Id
);
8880 -- Subp is the defining unit name of the subprogram declaration. If
8881 -- the pragma is valid, call Set_Inline_Flags on Subp, as well as on
8882 -- the corresponding body, if there is one present.
8884 procedure Set_Inline_Flags
(Subp
: Entity_Id
);
8885 -- Set Has_Pragma_{No_Inline,Inline,Inline_Always} flag on Subp.
8886 -- Also set or clear Is_Inlined flag on Subp depending on Status.
8888 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean;
8889 -- Returns True if it can be determined at this stage that inlining
8890 -- is not possible, for example if the body is available and contains
8891 -- exception handlers, we prevent inlining, since otherwise we can
8892 -- get undefined symbols at link time. This function also emits a
8893 -- warning if the pragma appears too late.
8895 -- ??? is business with link symbols still valid, or does it relate
8896 -- to front end ZCX which is being phased out ???
8898 ---------------------------
8899 -- Inlining_Not_Possible --
8900 ---------------------------
8902 function Inlining_Not_Possible
(Subp
: Entity_Id
) return Boolean is
8903 Decl
: constant Node_Id
:= Unit_Declaration_Node
(Subp
);
8907 if Nkind
(Decl
) = N_Subprogram_Body
then
8908 Stats
:= Handled_Statement_Sequence
(Decl
);
8909 return Present
(Exception_Handlers
(Stats
))
8910 or else Present
(At_End_Proc
(Stats
));
8912 elsif Nkind
(Decl
) = N_Subprogram_Declaration
8913 and then Present
(Corresponding_Body
(Decl
))
8915 if Analyzed
(Corresponding_Body
(Decl
)) then
8916 Error_Msg_N
("pragma appears too late, ignored??", N
);
8919 -- If the subprogram is a renaming as body, the body is just a
8920 -- call to the renamed subprogram, and inlining is trivially
8924 Nkind
(Unit_Declaration_Node
(Corresponding_Body
(Decl
))) =
8925 N_Subprogram_Renaming_Declaration
8931 Handled_Statement_Sequence
8932 (Unit_Declaration_Node
(Corresponding_Body
(Decl
)));
8935 Present
(Exception_Handlers
(Stats
))
8936 or else Present
(At_End_Proc
(Stats
));
8940 -- If body is not available, assume the best, the check is
8941 -- performed again when compiling enclosing package bodies.
8945 end Inlining_Not_Possible
;
8951 procedure Make_Inline
(Subp
: Entity_Id
) is
8952 Kind
: constant Entity_Kind
:= Ekind
(Subp
);
8953 Inner_Subp
: Entity_Id
:= Subp
;
8956 -- Ignore if bad type, avoid cascaded error
8958 if Etype
(Subp
) = Any_Type
then
8962 -- If inlining is not possible, for now do not treat as an error
8964 elsif Status
/= Suppressed
8965 and then Front_End_Inlining
8966 and then Inlining_Not_Possible
(Subp
)
8971 -- Here we have a candidate for inlining, but we must exclude
8972 -- derived operations. Otherwise we would end up trying to inline
8973 -- a phantom declaration, and the result would be to drag in a
8974 -- body which has no direct inlining associated with it. That
8975 -- would not only be inefficient but would also result in the
8976 -- backend doing cross-unit inlining in cases where it was
8977 -- definitely inappropriate to do so.
8979 -- However, a simple Comes_From_Source test is insufficient, since
8980 -- we do want to allow inlining of generic instances which also do
8981 -- not come from source. We also need to recognize specs generated
8982 -- by the front-end for bodies that carry the pragma. Finally,
8983 -- predefined operators do not come from source but are not
8984 -- inlineable either.
8986 elsif Is_Generic_Instance
(Subp
)
8987 or else Nkind
(Parent
(Parent
(Subp
))) = N_Subprogram_Declaration
8991 elsif not Comes_From_Source
(Subp
)
8992 and then Scope
(Subp
) /= Standard_Standard
8998 -- The referenced entity must either be the enclosing entity, or
8999 -- an entity declared within the current open scope.
9001 if Present
(Scope
(Subp
))
9002 and then Scope
(Subp
) /= Current_Scope
9003 and then Subp
/= Current_Scope
9006 ("argument of% must be entity in current scope", Assoc
);
9010 -- Processing for procedure, operator or function. If subprogram
9011 -- is aliased (as for an instance) indicate that the renamed
9012 -- entity (if declared in the same unit) is inlined.
9013 -- If this is the anonymous subprogram created for a subprogram
9014 -- instance, the inlining applies to it directly. Otherwise we
9015 -- retrieve it as the alias of the visible subprogram instance.
9017 if Is_Subprogram
(Subp
) then
9018 if Is_Wrapper_Package
(Scope
(Subp
)) then
9021 Inner_Subp
:= Ultimate_Alias
(Inner_Subp
);
9024 if In_Same_Source_Unit
(Subp
, Inner_Subp
) then
9025 Set_Inline_Flags
(Inner_Subp
);
9027 Decl
:= Parent
(Parent
(Inner_Subp
));
9029 if Nkind
(Decl
) = N_Subprogram_Declaration
9030 and then Present
(Corresponding_Body
(Decl
))
9032 Set_Inline_Flags
(Corresponding_Body
(Decl
));
9034 elsif Is_Generic_Instance
(Subp
)
9035 and then Comes_From_Source
(Subp
)
9037 -- Indicate that the body needs to be created for
9038 -- inlining subsequent calls. The instantiation node
9039 -- follows the declaration of the wrapper package
9040 -- created for it. The subprogram that requires the
9041 -- body is the anonymous one in the wrapper package.
9043 if Scope
(Subp
) /= Standard_Standard
9045 Need_Subprogram_Instance_Body
9046 (Next
(Unit_Declaration_Node
9047 (Scope
(Alias
(Subp
)))), Subp
)
9052 -- Inline is a program unit pragma (RM 10.1.5) and cannot
9053 -- appear in a formal part to apply to a formal subprogram.
9054 -- Do not apply check within an instance or a formal package
9055 -- the test will have been applied to the original generic.
9057 elsif Nkind
(Decl
) in N_Formal_Subprogram_Declaration
9058 and then List_Containing
(Decl
) = List_Containing
(N
)
9059 and then not In_Instance
9062 ("Inline cannot apply to a formal subprogram", N
);
9064 -- If Subp is a renaming, it is the renamed entity that
9065 -- will appear in any call, and be inlined. However, for
9066 -- ASIS uses it is convenient to indicate that the renaming
9067 -- itself is an inlined subprogram, so that some gnatcheck
9068 -- rules can be applied in the absence of expansion.
9070 elsif Nkind
(Decl
) = N_Subprogram_Renaming_Declaration
then
9071 Set_Inline_Flags
(Subp
);
9077 -- For a generic subprogram set flag as well, for use at the point
9078 -- of instantiation, to determine whether the body should be
9081 elsif Is_Generic_Subprogram
(Subp
) then
9082 Set_Inline_Flags
(Subp
);
9085 -- Literals are by definition inlined
9087 elsif Kind
= E_Enumeration_Literal
then
9090 -- Anything else is an error
9094 ("expect subprogram name for pragma%", Assoc
);
9098 ----------------------
9099 -- Set_Inline_Flags --
9100 ----------------------
9102 procedure Set_Inline_Flags
(Subp
: Entity_Id
) is
9104 -- First set the Has_Pragma_XXX flags and issue the appropriate
9105 -- errors and warnings for suspicious combinations.
9107 if Prag_Id
= Pragma_No_Inline
then
9108 if Has_Pragma_Inline_Always
(Subp
) then
9110 ("Inline_Always and No_Inline are mutually exclusive", N
);
9111 elsif Has_Pragma_Inline
(Subp
) then
9113 ("Inline and No_Inline both specified for& ??",
9114 N
, Entity
(Subp_Id
));
9117 Set_Has_Pragma_No_Inline
(Subp
);
9119 if Prag_Id
= Pragma_Inline_Always
then
9120 if Has_Pragma_No_Inline
(Subp
) then
9122 ("Inline_Always and No_Inline are mutually exclusive",
9126 Set_Has_Pragma_Inline_Always
(Subp
);
9128 if Has_Pragma_No_Inline
(Subp
) then
9130 ("Inline and No_Inline both specified for& ??",
9131 N
, Entity
(Subp_Id
));
9135 Set_Has_Pragma_Inline
(Subp
);
9138 -- Then adjust the Is_Inlined flag. It can never be set if the
9139 -- subprogram is subject to pragma No_Inline.
9143 Set_Is_Inlined
(Subp
, False);
9149 if not Has_Pragma_No_Inline
(Subp
) then
9150 Set_Is_Inlined
(Subp
, True);
9154 -- A pragma that applies to a Ghost entity becomes Ghost for the
9155 -- purposes of legality checks and removal of ignored Ghost code.
9157 Mark_Ghost_Pragma
(N
, Subp
);
9159 -- Capture the entity of the first Ghost subprogram being
9160 -- processed for error detection purposes.
9162 if Is_Ghost_Entity
(Subp
) then
9163 if No
(Ghost_Id
) then
9167 -- Otherwise the subprogram is non-Ghost. It is illegal to mix
9168 -- references to Ghost and non-Ghost entities (SPARK RM 6.9).
9170 elsif Present
(Ghost_Id
) and then not Ghost_Error_Posted
then
9171 Ghost_Error_Posted
:= True;
9173 Error_Msg_Name_1
:= Pname
;
9175 ("pragma % cannot mention ghost and non-ghost subprograms",
9178 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
9179 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
9181 Error_Msg_Sloc
:= Sloc
(Subp
);
9182 Error_Msg_NE
("\& # declared as non-ghost", N
, Subp
);
9184 end Set_Inline_Flags
;
9186 -- Start of processing for Process_Inline
9189 Check_No_Identifiers
;
9190 Check_At_Least_N_Arguments
(1);
9192 if Status
= Enabled
then
9193 Inline_Processing_Required
:= True;
9197 while Present
(Assoc
) loop
9198 Subp_Id
:= Get_Pragma_Arg
(Assoc
);
9202 if Is_Entity_Name
(Subp_Id
) then
9203 Subp
:= Entity
(Subp_Id
);
9205 if Subp
= Any_Id
then
9207 -- If previous error, avoid cascaded errors
9209 Check_Error_Detected
;
9215 -- For the pragma case, climb homonym chain. This is
9216 -- what implements allowing the pragma in the renaming
9217 -- case, with the result applying to the ancestors, and
9218 -- also allows Inline to apply to all previous homonyms.
9220 if not From_Aspect_Specification
(N
) then
9221 while Present
(Homonym
(Subp
))
9222 and then Scope
(Homonym
(Subp
)) = Current_Scope
9224 Make_Inline
(Homonym
(Subp
));
9225 Subp
:= Homonym
(Subp
);
9232 Error_Pragma_Arg
("inappropriate argument for pragma%", Assoc
);
9238 -- If the context is a package declaration, the pragma indicates
9239 -- that inlining will require the presence of the corresponding
9240 -- body. (this may be further refined).
9243 and then Nkind
(Unit
(Cunit
(Current_Sem_Unit
))) =
9244 N_Package_Declaration
9246 Set_Body_Needed_For_Inlining
(Cunit_Entity
(Current_Sem_Unit
));
9250 ----------------------------
9251 -- Process_Interface_Name --
9252 ----------------------------
9254 procedure Process_Interface_Name
9255 (Subprogram_Def
: Entity_Id
;
9262 String_Val
: String_Id
;
9264 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
);
9265 -- SN is a string literal node for an interface name. This routine
9266 -- performs some minimal checks that the name is reasonable. In
9267 -- particular that no spaces or other obviously incorrect characters
9268 -- appear. This is only a warning, since any characters are allowed.
9270 ----------------------------------
9271 -- Check_Form_Of_Interface_Name --
9272 ----------------------------------
9274 procedure Check_Form_Of_Interface_Name
(SN
: Node_Id
) is
9275 S
: constant String_Id
:= Strval
(Expr_Value_S
(SN
));
9276 SL
: constant Nat
:= String_Length
(S
);
9281 Error_Msg_N
("interface name cannot be null string", SN
);
9284 for J
in 1 .. SL
loop
9285 C
:= Get_String_Char
(S
, J
);
9287 -- Look for dubious character and issue unconditional warning.
9288 -- Definitely dubious if not in character range.
9290 if not In_Character_Range
(C
)
9292 -- Commas, spaces and (back)slashes are dubious
9294 or else Get_Character
(C
) = ','
9295 or else Get_Character
(C
) = '\'
9296 or else Get_Character
(C
) = ' '
9297 or else Get_Character
(C
) = '/'
9300 ("??interface name contains illegal character",
9301 Sloc
(SN
) + Source_Ptr
(J
));
9304 end Check_Form_Of_Interface_Name
;
9306 -- Start of processing for Process_Interface_Name
9309 -- If we are looking at a pragma that comes from an aspect then it
9310 -- needs to have its corresponding aspect argument expressions
9311 -- analyzed in addition to the generated pragma so that aspects
9312 -- within generic units get properly resolved.
9314 if Present
(Prag
) and then From_Aspect_Specification
(Prag
) then
9316 Asp
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
9324 -- Obtain all interfacing aspects used to construct the pragma
9326 Get_Interfacing_Aspects
9327 (Asp
, Dummy_1
, EN
, Dummy_2
, Dummy_3
, LN
);
9329 -- Analyze the expression of aspect External_Name
9331 if Present
(EN
) then
9332 Analyze
(Expression
(EN
));
9335 -- Analyze the expressio of aspect Link_Name
9337 if Present
(LN
) then
9338 Analyze
(Expression
(LN
));
9343 if No
(Link_Arg
) then
9344 if No
(Ext_Arg
) then
9347 elsif Chars
(Ext_Arg
) = Name_Link_Name
then
9349 Link_Nam
:= Expression
(Ext_Arg
);
9352 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9353 Ext_Nam
:= Expression
(Ext_Arg
);
9358 Check_Optional_Identifier
(Ext_Arg
, Name_External_Name
);
9359 Check_Optional_Identifier
(Link_Arg
, Name_Link_Name
);
9360 Ext_Nam
:= Expression
(Ext_Arg
);
9361 Link_Nam
:= Expression
(Link_Arg
);
9364 -- Check expressions for external name and link name are static
9366 if Present
(Ext_Nam
) then
9367 Check_Arg_Is_OK_Static_Expression
(Ext_Nam
, Standard_String
);
9368 Check_Form_Of_Interface_Name
(Ext_Nam
);
9370 -- Verify that external name is not the name of a local entity,
9371 -- which would hide the imported one and could lead to run-time
9372 -- surprises. The problem can only arise for entities declared in
9373 -- a package body (otherwise the external name is fully qualified
9374 -- and will not conflict).
9382 if Prag_Id
= Pragma_Import
then
9383 Nam
:= String_To_Name
(Strval
(Expr_Value_S
(Ext_Nam
)));
9384 E
:= Entity_Id
(Get_Name_Table_Int
(Nam
));
9386 if Nam
/= Chars
(Subprogram_Def
)
9387 and then Present
(E
)
9388 and then not Is_Overloadable
(E
)
9389 and then Is_Immediately_Visible
(E
)
9390 and then not Is_Imported
(E
)
9391 and then Ekind
(Scope
(E
)) = E_Package
9394 while Present
(Par
) loop
9395 if Nkind
(Par
) = N_Package_Body
then
9396 Error_Msg_Sloc
:= Sloc
(E
);
9398 ("imported entity is hidden by & declared#",
9403 Par
:= Parent
(Par
);
9410 if Present
(Link_Nam
) then
9411 Check_Arg_Is_OK_Static_Expression
(Link_Nam
, Standard_String
);
9412 Check_Form_Of_Interface_Name
(Link_Nam
);
9415 -- If there is no link name, just set the external name
9417 if No
(Link_Nam
) then
9418 Link_Nam
:= Adjust_External_Name_Case
(Expr_Value_S
(Ext_Nam
));
9420 -- For the Link_Name case, the given literal is preceded by an
9421 -- asterisk, which indicates to GCC that the given name should be
9422 -- taken literally, and in particular that no prepending of
9423 -- underlines should occur, even in systems where this is the
9428 Store_String_Char
(Get_Char_Code
('*'));
9429 String_Val
:= Strval
(Expr_Value_S
(Link_Nam
));
9430 Store_String_Chars
(String_Val
);
9432 Make_String_Literal
(Sloc
(Link_Nam
),
9433 Strval
=> End_String
);
9436 -- Set the interface name. If the entity is a generic instance, use
9437 -- its alias, which is the callable entity.
9439 if Is_Generic_Instance
(Subprogram_Def
) then
9440 Set_Encoded_Interface_Name
9441 (Alias
(Get_Base_Subprogram
(Subprogram_Def
)), Link_Nam
);
9443 Set_Encoded_Interface_Name
9444 (Get_Base_Subprogram
(Subprogram_Def
), Link_Nam
);
9447 Check_Duplicated_Export_Name
(Link_Nam
);
9448 end Process_Interface_Name
;
9450 -----------------------------------------
9451 -- Process_Interrupt_Or_Attach_Handler --
9452 -----------------------------------------
9454 procedure Process_Interrupt_Or_Attach_Handler
is
9455 Handler
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
9456 Prot_Typ
: constant Entity_Id
:= Scope
(Handler
);
9459 -- A pragma that applies to a Ghost entity becomes Ghost for the
9460 -- purposes of legality checks and removal of ignored Ghost code.
9462 Mark_Ghost_Pragma
(N
, Handler
);
9463 Set_Is_Interrupt_Handler
(Handler
);
9465 pragma Assert
(Ekind
(Prot_Typ
) = E_Protected_Type
);
9467 Record_Rep_Item
(Prot_Typ
, N
);
9469 -- Chain the pragma on the contract for completeness
9471 Add_Contract_Item
(N
, Handler
);
9472 end Process_Interrupt_Or_Attach_Handler
;
9474 --------------------------------------------------
9475 -- Process_Restrictions_Or_Restriction_Warnings --
9476 --------------------------------------------------
9478 -- Note: some of the simple identifier cases were handled in par-prag,
9479 -- but it is harmless (and more straightforward) to simply handle all
9480 -- cases here, even if it means we repeat a bit of work in some cases.
9482 procedure Process_Restrictions_Or_Restriction_Warnings
9486 R_Id
: Restriction_Id
;
9492 -- Ignore all Restrictions pragmas in CodePeer mode
9494 if CodePeer_Mode
then
9498 Check_Ada_83_Warning
;
9499 Check_At_Least_N_Arguments
(1);
9500 Check_Valid_Configuration_Pragma
;
9503 while Present
(Arg
) loop
9505 Expr
:= Get_Pragma_Arg
(Arg
);
9507 -- Case of no restriction identifier present
9509 if Id
= No_Name
then
9510 if Nkind
(Expr
) /= N_Identifier
then
9512 ("invalid form for restriction", Arg
);
9517 (Process_Restriction_Synonyms
(Expr
));
9519 if R_Id
not in All_Boolean_Restrictions
then
9520 Error_Msg_Name_1
:= Pname
;
9522 ("invalid restriction identifier&", Get_Pragma_Arg
(Arg
));
9524 -- Check for possible misspelling
9526 for J
in Restriction_Id
loop
9528 Rnm
: constant String := Restriction_Id
'Image (J
);
9531 Name_Buffer
(1 .. Rnm
'Length) := Rnm
;
9532 Name_Len
:= Rnm
'Length;
9533 Set_Casing
(All_Lower_Case
);
9535 if Is_Bad_Spelling_Of
(Chars
(Expr
), Name_Enter
) then
9538 (Source_Index
(Current_Sem_Unit
)));
9539 Error_Msg_String
(1 .. Rnm
'Length) :=
9540 Name_Buffer
(1 .. Name_Len
);
9541 Error_Msg_Strlen
:= Rnm
'Length;
9542 Error_Msg_N
-- CODEFIX
9543 ("\possible misspelling of ""~""",
9544 Get_Pragma_Arg
(Arg
));
9553 if Implementation_Restriction
(R_Id
) then
9554 Check_Restriction
(No_Implementation_Restrictions
, Arg
);
9557 -- Special processing for No_Elaboration_Code restriction
9559 if R_Id
= No_Elaboration_Code
then
9561 -- Restriction is only recognized within a configuration
9562 -- pragma file, or within a unit of the main extended
9563 -- program. Note: the test for Main_Unit is needed to
9564 -- properly include the case of configuration pragma files.
9566 if not (Current_Sem_Unit
= Main_Unit
9567 or else In_Extended_Main_Source_Unit
(N
))
9571 -- Don't allow in a subunit unless already specified in
9574 elsif Nkind
(Parent
(N
)) = N_Compilation_Unit
9575 and then Nkind
(Unit
(Parent
(N
))) = N_Subunit
9576 and then not Restriction_Active
(No_Elaboration_Code
)
9579 ("invalid specification of ""No_Elaboration_Code""",
9582 ("\restriction cannot be specified in a subunit", N
);
9584 ("\unless also specified in body or spec", N
);
9587 -- If we accept a No_Elaboration_Code restriction, then it
9588 -- needs to be added to the configuration restriction set so
9589 -- that we get proper application to other units in the main
9590 -- extended source as required.
9593 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
9597 -- If this is a warning, then set the warning unless we already
9598 -- have a real restriction active (we never want a warning to
9599 -- override a real restriction).
9602 if not Restriction_Active
(R_Id
) then
9603 Set_Restriction
(R_Id
, N
);
9604 Restriction_Warnings
(R_Id
) := True;
9607 -- If real restriction case, then set it and make sure that the
9608 -- restriction warning flag is off, since a real restriction
9609 -- always overrides a warning.
9612 Set_Restriction
(R_Id
, N
);
9613 Restriction_Warnings
(R_Id
) := False;
9616 -- Check for obsolescent restrictions in Ada 2005 mode
9619 and then Ada_Version
>= Ada_2005
9620 and then (R_Id
= No_Asynchronous_Control
9622 R_Id
= No_Unchecked_Deallocation
9624 R_Id
= No_Unchecked_Conversion
)
9626 Check_Restriction
(No_Obsolescent_Features
, N
);
9629 -- A very special case that must be processed here: pragma
9630 -- Restrictions (No_Exceptions) turns off all run-time
9631 -- checking. This is a bit dubious in terms of the formal
9632 -- language definition, but it is what is intended by RM
9633 -- H.4(12). Restriction_Warnings never affects generated code
9634 -- so this is done only in the real restriction case.
9636 -- Atomic_Synchronization is not a real check, so it is not
9637 -- affected by this processing).
9639 -- Ignore the effect of pragma Restrictions (No_Exceptions) on
9640 -- run-time checks in CodePeer and GNATprove modes: we want to
9641 -- generate checks for analysis purposes, as set respectively
9642 -- by -gnatC and -gnatd.F
9645 and then not (CodePeer_Mode
or GNATprove_Mode
)
9646 and then R_Id
= No_Exceptions
9648 for J
in Scope_Suppress
.Suppress
'Range loop
9649 if J
/= Atomic_Synchronization
then
9650 Scope_Suppress
.Suppress
(J
) := True;
9655 -- Case of No_Dependence => unit-name. Note that the parser
9656 -- already made the necessary entry in the No_Dependence table.
9658 elsif Id
= Name_No_Dependence
then
9659 if not OK_No_Dependence_Unit_Name
(Expr
) then
9663 -- Case of No_Specification_Of_Aspect => aspect-identifier
9665 elsif Id
= Name_No_Specification_Of_Aspect
then
9670 if Nkind
(Expr
) /= N_Identifier
then
9673 A_Id
:= Get_Aspect_Id
(Chars
(Expr
));
9676 if A_Id
= No_Aspect
then
9677 Error_Pragma_Arg
("invalid restriction name", Arg
);
9679 Set_Restriction_No_Specification_Of_Aspect
(Expr
, Warn
);
9683 -- Case of No_Use_Of_Attribute => attribute-identifier
9685 elsif Id
= Name_No_Use_Of_Attribute
then
9686 if Nkind
(Expr
) /= N_Identifier
9687 or else not Is_Attribute_Name
(Chars
(Expr
))
9689 Error_Msg_N
("unknown attribute name??", Expr
);
9692 Set_Restriction_No_Use_Of_Attribute
(Expr
, Warn
);
9695 -- Case of No_Use_Of_Entity => fully-qualified-name
9697 elsif Id
= Name_No_Use_Of_Entity
then
9699 -- Restriction is only recognized within a configuration
9700 -- pragma file, or within a unit of the main extended
9701 -- program. Note: the test for Main_Unit is needed to
9702 -- properly include the case of configuration pragma files.
9704 if Current_Sem_Unit
= Main_Unit
9705 or else In_Extended_Main_Source_Unit
(N
)
9707 if not OK_No_Dependence_Unit_Name
(Expr
) then
9708 Error_Msg_N
("wrong form for entity name", Expr
);
9710 Set_Restriction_No_Use_Of_Entity
9711 (Expr
, Warn
, No_Profile
);
9715 -- Case of No_Use_Of_Pragma => pragma-identifier
9717 elsif Id
= Name_No_Use_Of_Pragma
then
9718 if Nkind
(Expr
) /= N_Identifier
9719 or else not Is_Pragma_Name
(Chars
(Expr
))
9721 Error_Msg_N
("unknown pragma name??", Expr
);
9723 Set_Restriction_No_Use_Of_Pragma
(Expr
, Warn
);
9726 -- All other cases of restriction identifier present
9729 R_Id
:= Get_Restriction_Id
(Process_Restriction_Synonyms
(Arg
));
9730 Analyze_And_Resolve
(Expr
, Any_Integer
);
9732 if R_Id
not in All_Parameter_Restrictions
then
9734 ("invalid restriction parameter identifier", Arg
);
9736 elsif not Is_OK_Static_Expression
(Expr
) then
9737 Flag_Non_Static_Expr
9738 ("value must be static expression!", Expr
);
9741 elsif not Is_Integer_Type
(Etype
(Expr
))
9742 or else Expr_Value
(Expr
) < 0
9745 ("value must be non-negative integer", Arg
);
9748 -- Restriction pragma is active
9750 Val
:= Expr_Value
(Expr
);
9752 if not UI_Is_In_Int_Range
(Val
) then
9754 ("pragma ignored, value too large??", Arg
);
9757 -- Warning case. If the real restriction is active, then we
9758 -- ignore the request, since warning never overrides a real
9759 -- restriction. Otherwise we set the proper warning. Note that
9760 -- this circuit sets the warning again if it is already set,
9761 -- which is what we want, since the constant may have changed.
9764 if not Restriction_Active
(R_Id
) then
9766 (R_Id
, N
, Integer (UI_To_Int
(Val
)));
9767 Restriction_Warnings
(R_Id
) := True;
9770 -- Real restriction case, set restriction and make sure warning
9771 -- flag is off since real restriction always overrides warning.
9774 Set_Restriction
(R_Id
, N
, Integer (UI_To_Int
(Val
)));
9775 Restriction_Warnings
(R_Id
) := False;
9781 end Process_Restrictions_Or_Restriction_Warnings
;
9783 ---------------------------------
9784 -- Process_Suppress_Unsuppress --
9785 ---------------------------------
9787 -- Note: this procedure makes entries in the check suppress data
9788 -- structures managed by Sem. See spec of package Sem for full
9789 -- details on how we handle recording of check suppression.
9791 procedure Process_Suppress_Unsuppress
(Suppress_Case
: Boolean) is
9796 In_Package_Spec
: constant Boolean :=
9797 Is_Package_Or_Generic_Package
(Current_Scope
)
9798 and then not In_Package_Body
(Current_Scope
);
9800 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
);
9801 -- Used to suppress a single check on the given entity
9803 --------------------------------
9804 -- Suppress_Unsuppress_Echeck --
9805 --------------------------------
9807 procedure Suppress_Unsuppress_Echeck
(E
: Entity_Id
; C
: Check_Id
) is
9809 -- Check for error of trying to set atomic synchronization for
9810 -- a non-atomic variable.
9812 if C
= Atomic_Synchronization
9813 and then not (Is_Atomic
(E
) or else Has_Atomic_Components
(E
))
9816 ("pragma & requires atomic type or variable",
9817 Pragma_Identifier
(Original_Node
(N
)));
9820 Set_Checks_May_Be_Suppressed
(E
);
9822 if In_Package_Spec
then
9823 Push_Global_Suppress_Stack_Entry
9826 Suppress
=> Suppress_Case
);
9828 Push_Local_Suppress_Stack_Entry
9831 Suppress
=> Suppress_Case
);
9834 -- If this is a first subtype, and the base type is distinct,
9835 -- then also set the suppress flags on the base type.
9837 if Is_First_Subtype
(E
) and then Etype
(E
) /= E
then
9838 Suppress_Unsuppress_Echeck
(Etype
(E
), C
);
9840 end Suppress_Unsuppress_Echeck
;
9842 -- Start of processing for Process_Suppress_Unsuppress
9845 -- Ignore pragma Suppress/Unsuppress in CodePeer and GNATprove modes
9846 -- on user code: we want to generate checks for analysis purposes, as
9847 -- set respectively by -gnatC and -gnatd.F
9849 if Comes_From_Source
(N
)
9850 and then (CodePeer_Mode
or GNATprove_Mode
)
9855 -- Suppress/Unsuppress can appear as a configuration pragma, or in a
9856 -- declarative part or a package spec (RM 11.5(5)).
9858 if not Is_Configuration_Pragma
then
9859 Check_Is_In_Decl_Part_Or_Package_Spec
;
9862 Check_At_Least_N_Arguments
(1);
9863 Check_At_Most_N_Arguments
(2);
9864 Check_No_Identifier
(Arg1
);
9865 Check_Arg_Is_Identifier
(Arg1
);
9867 C
:= Get_Check_Id
(Chars
(Get_Pragma_Arg
(Arg1
)));
9869 if C
= No_Check_Id
then
9871 ("argument of pragma% is not valid check name", Arg1
);
9874 -- Warn that suppress of Elaboration_Check has no effect in SPARK
9876 if C
= Elaboration_Check
and then SPARK_Mode
= On
then
9878 ("Suppress of Elaboration_Check ignored in SPARK??",
9879 "\elaboration checking rules are statically enforced "
9880 & "(SPARK RM 7.7)", Arg1
);
9883 -- One-argument case
9885 if Arg_Count
= 1 then
9887 -- Make an entry in the local scope suppress table. This is the
9888 -- table that directly shows the current value of the scope
9889 -- suppress check for any check id value.
9891 if C
= All_Checks
then
9893 -- For All_Checks, we set all specific predefined checks with
9894 -- the exception of Elaboration_Check, which is handled
9895 -- specially because of not wanting All_Checks to have the
9896 -- effect of deactivating static elaboration order processing.
9897 -- Atomic_Synchronization is also not affected, since this is
9898 -- not a real check.
9900 for J
in Scope_Suppress
.Suppress
'Range loop
9901 if J
/= Elaboration_Check
9903 J
/= Atomic_Synchronization
9905 Scope_Suppress
.Suppress
(J
) := Suppress_Case
;
9909 -- If not All_Checks, and predefined check, then set appropriate
9910 -- scope entry. Note that we will set Elaboration_Check if this
9911 -- is explicitly specified. Atomic_Synchronization is allowed
9912 -- only if internally generated and entity is atomic.
9914 elsif C
in Predefined_Check_Id
9915 and then (not Comes_From_Source
(N
)
9916 or else C
/= Atomic_Synchronization
)
9918 Scope_Suppress
.Suppress
(C
) := Suppress_Case
;
9921 -- Also make an entry in the Local_Entity_Suppress table
9923 Push_Local_Suppress_Stack_Entry
9926 Suppress
=> Suppress_Case
);
9928 -- Case of two arguments present, where the check is suppressed for
9929 -- a specified entity (given as the second argument of the pragma)
9932 -- This is obsolescent in Ada 2005 mode
9934 if Ada_Version
>= Ada_2005
then
9935 Check_Restriction
(No_Obsolescent_Features
, Arg2
);
9938 Check_Optional_Identifier
(Arg2
, Name_On
);
9939 E_Id
:= Get_Pragma_Arg
(Arg2
);
9942 if not Is_Entity_Name
(E_Id
) then
9944 ("second argument of pragma% must be entity name", Arg2
);
9953 -- A pragma that applies to a Ghost entity becomes Ghost for the
9954 -- purposes of legality checks and removal of ignored Ghost code.
9956 Mark_Ghost_Pragma
(N
, E
);
9958 -- Enforce RM 11.5(7) which requires that for a pragma that
9959 -- appears within a package spec, the named entity must be
9960 -- within the package spec. We allow the package name itself
9961 -- to be mentioned since that makes sense, although it is not
9962 -- strictly allowed by 11.5(7).
9965 and then E
/= Current_Scope
9966 and then Scope
(E
) /= Current_Scope
9969 ("entity in pragma% is not in package spec (RM 11.5(7))",
9973 -- Loop through homonyms. As noted below, in the case of a package
9974 -- spec, only homonyms within the package spec are considered.
9977 Suppress_Unsuppress_Echeck
(E
, C
);
9979 if Is_Generic_Instance
(E
)
9980 and then Is_Subprogram
(E
)
9981 and then Present
(Alias
(E
))
9983 Suppress_Unsuppress_Echeck
(Alias
(E
), C
);
9986 -- Move to next homonym if not aspect spec case
9988 exit when From_Aspect_Specification
(N
);
9992 -- If we are within a package specification, the pragma only
9993 -- applies to homonyms in the same scope.
9995 exit when In_Package_Spec
9996 and then Scope
(E
) /= Current_Scope
;
9999 end Process_Suppress_Unsuppress
;
10001 -------------------------------
10002 -- Record_Independence_Check --
10003 -------------------------------
10005 procedure Record_Independence_Check
(N
: Node_Id
; E
: Entity_Id
) is
10007 -- For GCC back ends the validation is done a priori
10009 if not AAMP_On_Target
then
10013 Independence_Checks
.Append
((N
, E
));
10014 end Record_Independence_Check
;
10020 procedure Set_Exported
(E
: Entity_Id
; Arg
: Node_Id
) is
10022 if Is_Imported
(E
) then
10024 ("cannot export entity& that was previously imported", Arg
);
10026 elsif Present
(Address_Clause
(E
))
10027 and then not Relaxed_RM_Semantics
10030 ("cannot export entity& that has an address clause", Arg
);
10033 Set_Is_Exported
(E
);
10035 -- Generate a reference for entity explicitly, because the
10036 -- identifier may be overloaded and name resolution will not
10039 Generate_Reference
(E
, Arg
);
10041 -- Deal with exporting non-library level entity
10043 if not Is_Library_Level_Entity
(E
) then
10045 -- Not allowed at all for subprograms
10047 if Is_Subprogram
(E
) then
10048 Error_Pragma_Arg
("local subprogram& cannot be exported", Arg
);
10050 -- Otherwise set public and statically allocated
10054 Set_Is_Statically_Allocated
(E
);
10056 -- Warn if the corresponding W flag is set
10058 if Warn_On_Export_Import
10060 -- Only do this for something that was in the source. Not
10061 -- clear if this can be False now (there used for sure to be
10062 -- cases on some systems where it was False), but anyway the
10063 -- test is harmless if not needed, so it is retained.
10065 and then Comes_From_Source
(Arg
)
10068 ("?x?& has been made static as a result of Export",
10071 ("\?x?this usage is non-standard and non-portable",
10077 if Warn_On_Export_Import
and then Is_Type
(E
) then
10078 Error_Msg_NE
("exporting a type has no effect?x?", Arg
, E
);
10081 if Warn_On_Export_Import
and Inside_A_Generic
then
10083 ("all instances of& will have the same external name?x?",
10088 ----------------------------------------------
10089 -- Set_Extended_Import_Export_External_Name --
10090 ----------------------------------------------
10092 procedure Set_Extended_Import_Export_External_Name
10093 (Internal_Ent
: Entity_Id
;
10094 Arg_External
: Node_Id
)
10096 Old_Name
: constant Node_Id
:= Interface_Name
(Internal_Ent
);
10097 New_Name
: Node_Id
;
10100 if No
(Arg_External
) then
10104 Check_Arg_Is_External_Name
(Arg_External
);
10106 if Nkind
(Arg_External
) = N_String_Literal
then
10107 if String_Length
(Strval
(Arg_External
)) = 0 then
10110 New_Name
:= Adjust_External_Name_Case
(Arg_External
);
10113 elsif Nkind
(Arg_External
) = N_Identifier
then
10114 New_Name
:= Get_Default_External_Name
(Arg_External
);
10116 -- Check_Arg_Is_External_Name should let through only identifiers and
10117 -- string literals or static string expressions (which are folded to
10118 -- string literals).
10121 raise Program_Error
;
10124 -- If we already have an external name set (by a prior normal Import
10125 -- or Export pragma), then the external names must match
10127 if Present
(Interface_Name
(Internal_Ent
)) then
10129 -- Ignore mismatching names in CodePeer mode, to support some
10130 -- old compilers which would export the same procedure under
10131 -- different names, e.g:
10133 -- pragma Export_Procedure (P, "a");
10134 -- pragma Export_Procedure (P, "b");
10136 if CodePeer_Mode
then
10140 Check_Matching_Internal_Names
: declare
10141 S1
: constant String_Id
:= Strval
(Old_Name
);
10142 S2
: constant String_Id
:= Strval
(New_Name
);
10144 procedure Mismatch
;
10145 pragma No_Return
(Mismatch
);
10146 -- Called if names do not match
10152 procedure Mismatch
is
10154 Error_Msg_Sloc
:= Sloc
(Old_Name
);
10156 ("external name does not match that given #",
10160 -- Start of processing for Check_Matching_Internal_Names
10163 if String_Length
(S1
) /= String_Length
(S2
) then
10167 for J
in 1 .. String_Length
(S1
) loop
10168 if Get_String_Char
(S1
, J
) /= Get_String_Char
(S2
, J
) then
10173 end Check_Matching_Internal_Names
;
10175 -- Otherwise set the given name
10178 Set_Encoded_Interface_Name
(Internal_Ent
, New_Name
);
10179 Check_Duplicated_Export_Name
(New_Name
);
10181 end Set_Extended_Import_Export_External_Name
;
10187 procedure Set_Imported
(E
: Entity_Id
) is
10189 -- Error message if already imported or exported
10191 if Is_Exported
(E
) or else Is_Imported
(E
) then
10193 -- Error if being set Exported twice
10195 if Is_Exported
(E
) then
10196 Error_Msg_NE
("entity& was previously exported", N
, E
);
10198 -- Ignore error in CodePeer mode where we treat all imported
10199 -- subprograms as unknown.
10201 elsif CodePeer_Mode
then
10204 -- OK if Import/Interface case
10206 elsif Import_Interface_Present
(N
) then
10209 -- Error if being set Imported twice
10212 Error_Msg_NE
("entity& was previously imported", N
, E
);
10215 Error_Msg_Name_1
:= Pname
;
10217 ("\(pragma% applies to all previous entities)", N
);
10219 Error_Msg_Sloc
:= Sloc
(E
);
10220 Error_Msg_NE
("\import not allowed for& declared#", N
, E
);
10222 -- Here if not previously imported or exported, OK to import
10225 Set_Is_Imported
(E
);
10227 -- For subprogram, set Import_Pragma field
10229 if Is_Subprogram
(E
) then
10230 Set_Import_Pragma
(E
, N
);
10233 -- If the entity is an object that is not at the library level,
10234 -- then it is statically allocated. We do not worry about objects
10235 -- with address clauses in this context since they are not really
10236 -- imported in the linker sense.
10239 and then not Is_Library_Level_Entity
(E
)
10240 and then No
(Address_Clause
(E
))
10242 Set_Is_Statically_Allocated
(E
);
10249 -------------------------
10250 -- Set_Mechanism_Value --
10251 -------------------------
10253 -- Note: the mechanism name has not been analyzed (and cannot indeed be
10254 -- analyzed, since it is semantic nonsense), so we get it in the exact
10255 -- form created by the parser.
10257 procedure Set_Mechanism_Value
(Ent
: Entity_Id
; Mech_Name
: Node_Id
) is
10258 procedure Bad_Mechanism
;
10259 pragma No_Return
(Bad_Mechanism
);
10260 -- Signal bad mechanism name
10262 -------------------------
10263 -- Bad_Mechanism_Value --
10264 -------------------------
10266 procedure Bad_Mechanism
is
10268 Error_Pragma_Arg
("unrecognized mechanism name", Mech_Name
);
10271 -- Start of processing for Set_Mechanism_Value
10274 if Mechanism
(Ent
) /= Default_Mechanism
then
10276 ("mechanism for & has already been set", Mech_Name
, Ent
);
10279 -- MECHANISM_NAME ::= value | reference
10281 if Nkind
(Mech_Name
) = N_Identifier
then
10282 if Chars
(Mech_Name
) = Name_Value
then
10283 Set_Mechanism
(Ent
, By_Copy
);
10286 elsif Chars
(Mech_Name
) = Name_Reference
then
10287 Set_Mechanism
(Ent
, By_Reference
);
10290 elsif Chars
(Mech_Name
) = Name_Copy
then
10292 ("bad mechanism name, Value assumed", Mech_Name
);
10301 end Set_Mechanism_Value
;
10303 --------------------------
10304 -- Set_Rational_Profile --
10305 --------------------------
10307 -- The Rational profile includes Implicit_Packing, Use_Vads_Size, and
10308 -- extension to the semantics of renaming declarations.
10310 procedure Set_Rational_Profile
is
10312 Implicit_Packing
:= True;
10313 Overriding_Renamings
:= True;
10314 Use_VADS_Size
:= True;
10315 end Set_Rational_Profile
;
10317 ---------------------------
10318 -- Set_Ravenscar_Profile --
10319 ---------------------------
10321 -- The tasks to be done here are
10323 -- Set required policies
10325 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10326 -- (For Ravenscar and GNAT_Extended_Ravenscar profiles)
10327 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10328 -- (For GNAT_Ravenscar_EDF profile)
10329 -- pragma Locking_Policy (Ceiling_Locking)
10331 -- Set Detect_Blocking mode
10333 -- Set required restrictions (see System.Rident for detailed list)
10335 -- Set the No_Dependence rules
10336 -- No_Dependence => Ada.Asynchronous_Task_Control
10337 -- No_Dependence => Ada.Calendar
10338 -- No_Dependence => Ada.Execution_Time.Group_Budget
10339 -- No_Dependence => Ada.Execution_Time.Timers
10340 -- No_Dependence => Ada.Task_Attributes
10341 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10343 procedure Set_Ravenscar_Profile
(Profile
: Profile_Name
; N
: Node_Id
) is
10344 procedure Set_Error_Msg_To_Profile_Name
;
10345 -- Set Error_Msg_String and Error_Msg_Strlen to the name of the
10348 -----------------------------------
10349 -- Set_Error_Msg_To_Profile_Name --
10350 -----------------------------------
10352 procedure Set_Error_Msg_To_Profile_Name
is
10353 Prof_Nam
: constant Node_Id
:=
10355 (First
(Pragma_Argument_Associations
(N
)));
10358 Get_Name_String
(Chars
(Prof_Nam
));
10359 Adjust_Name_Case
(Global_Name_Buffer
, Sloc
(Prof_Nam
));
10360 Error_Msg_Strlen
:= Name_Len
;
10361 Error_Msg_String
(1 .. Name_Len
) := Name_Buffer
(1 .. Name_Len
);
10362 end Set_Error_Msg_To_Profile_Name
;
10371 Profile_Dispatching_Policy
: Character;
10373 -- Start of processing for Set_Ravenscar_Profile
10376 -- pragma Task_Dispatching_Policy (EDF_Across_Priorities)
10378 if Profile
= GNAT_Ravenscar_EDF
then
10379 Profile_Dispatching_Policy
:= 'E';
10381 -- pragma Task_Dispatching_Policy (FIFO_Within_Priorities)
10384 Profile_Dispatching_Policy
:= 'F';
10387 if Task_Dispatching_Policy
/= ' '
10388 and then Task_Dispatching_Policy
/= Profile_Dispatching_Policy
10390 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
10391 Set_Error_Msg_To_Profile_Name
;
10392 Error_Pragma
("Profile (~) incompatible with policy#");
10394 -- Set the FIFO_Within_Priorities policy, but always preserve
10395 -- System_Location since we like the error message with the run time
10399 Task_Dispatching_Policy
:= Profile_Dispatching_Policy
;
10401 if Task_Dispatching_Policy_Sloc
/= System_Location
then
10402 Task_Dispatching_Policy_Sloc
:= Loc
;
10406 -- pragma Locking_Policy (Ceiling_Locking)
10408 if Locking_Policy
/= ' '
10409 and then Locking_Policy
/= 'C'
10411 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
10412 Set_Error_Msg_To_Profile_Name
;
10413 Error_Pragma
("Profile (~) incompatible with policy#");
10415 -- Set the Ceiling_Locking policy, but preserve System_Location since
10416 -- we like the error message with the run time name.
10419 Locking_Policy
:= 'C';
10421 if Locking_Policy_Sloc
/= System_Location
then
10422 Locking_Policy_Sloc
:= Loc
;
10426 -- pragma Detect_Blocking
10428 Detect_Blocking
:= True;
10430 -- Set the corresponding restrictions
10432 Set_Profile_Restrictions
10433 (Profile
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
10435 -- Set the No_Dependence restrictions
10437 -- The following No_Dependence restrictions:
10438 -- No_Dependence => Ada.Asynchronous_Task_Control
10439 -- No_Dependence => Ada.Calendar
10440 -- No_Dependence => Ada.Task_Attributes
10441 -- are already set by previous call to Set_Profile_Restrictions.
10443 -- Set the following restrictions which were added to Ada 2005:
10444 -- No_Dependence => Ada.Execution_Time.Group_Budget
10445 -- No_Dependence => Ada.Execution_Time.Timers
10447 if Ada_Version
>= Ada_2005
then
10448 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("ada"));
10449 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("execution_time"));
10452 Make_Selected_Component
10455 Selector_Name
=> Sel_Id
);
10457 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("group_budgets"));
10460 Make_Selected_Component
10463 Selector_Name
=> Sel_Id
);
10465 Set_Restriction_No_Dependence
10467 Warn
=> Treat_Restrictions_As_Warnings
,
10468 Profile
=> Ravenscar
);
10470 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("timers"));
10473 Make_Selected_Component
10476 Selector_Name
=> Sel_Id
);
10478 Set_Restriction_No_Dependence
10480 Warn
=> Treat_Restrictions_As_Warnings
,
10481 Profile
=> Ravenscar
);
10484 -- Set the following restriction which was added to Ada 2012 (see
10486 -- No_Dependence => System.Multiprocessors.Dispatching_Domains
10488 if Ada_Version
>= Ada_2012
then
10489 Pref_Id
:= Make_Identifier
(Loc
, Name_Find
("system"));
10490 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("multiprocessors"));
10493 Make_Selected_Component
10496 Selector_Name
=> Sel_Id
);
10498 Sel_Id
:= Make_Identifier
(Loc
, Name_Find
("dispatching_domains"));
10501 Make_Selected_Component
10504 Selector_Name
=> Sel_Id
);
10506 Set_Restriction_No_Dependence
10508 Warn
=> Treat_Restrictions_As_Warnings
,
10509 Profile
=> Ravenscar
);
10511 end Set_Ravenscar_Profile
;
10513 -- Start of processing for Analyze_Pragma
10516 -- The following code is a defense against recursion. Not clear that
10517 -- this can happen legitimately, but perhaps some error situations can
10518 -- cause it, and we did see this recursion during testing.
10520 if Analyzed
(N
) then
10526 Check_Restriction_No_Use_Of_Pragma
(N
);
10528 -- Ignore pragma if Ignore_Pragma applies. Also ignore pragma
10529 -- Default_Scalar_Storage_Order if the -gnatI switch was given.
10531 if Should_Ignore_Pragma_Sem
(N
)
10532 or else (Prag_Id
= Pragma_Default_Scalar_Storage_Order
10533 and then Ignore_Rep_Clauses
)
10538 -- Deal with unrecognized pragma
10540 if not Is_Pragma_Name
(Pname
) then
10541 if Warn_On_Unrecognized_Pragma
then
10542 Error_Msg_Name_1
:= Pname
;
10543 Error_Msg_N
("?g?unrecognized pragma%!", Pragma_Identifier
(N
));
10545 for PN
in First_Pragma_Name
.. Last_Pragma_Name
loop
10546 if Is_Bad_Spelling_Of
(Pname
, PN
) then
10547 Error_Msg_Name_1
:= PN
;
10548 Error_Msg_N
-- CODEFIX
10549 ("\?g?possible misspelling of %!", Pragma_Identifier
(N
));
10558 -- Here to start processing for recognized pragma
10560 Pname
:= Original_Aspect_Pragma_Name
(N
);
10562 -- Capture setting of Opt.Uneval_Old
10564 case Opt
.Uneval_Old
is
10566 Set_Uneval_Old_Accept
(N
);
10572 Set_Uneval_Old_Warn
(N
);
10575 raise Program_Error
;
10578 -- Check applicable policy. We skip this if Is_Checked or Is_Ignored
10579 -- is already set, indicating that we have already checked the policy
10580 -- at the right point. This happens for example in the case of a pragma
10581 -- that is derived from an Aspect.
10583 if Is_Ignored
(N
) or else Is_Checked
(N
) then
10586 -- For a pragma that is a rewriting of another pragma, copy the
10587 -- Is_Checked/Is_Ignored status from the rewritten pragma.
10589 elsif Is_Rewrite_Substitution
(N
)
10590 and then Nkind
(Original_Node
(N
)) = N_Pragma
10591 and then Original_Node
(N
) /= N
10593 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
10594 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
10596 -- Otherwise query the applicable policy at this point
10599 Check_Applicable_Policy
(N
);
10601 -- If pragma is disabled, rewrite as NULL and skip analysis
10603 if Is_Disabled
(N
) then
10604 Rewrite
(N
, Make_Null_Statement
(Loc
));
10610 -- Preset arguments
10618 if Present
(Pragma_Argument_Associations
(N
)) then
10619 Arg_Count
:= List_Length
(Pragma_Argument_Associations
(N
));
10620 Arg1
:= First
(Pragma_Argument_Associations
(N
));
10622 if Present
(Arg1
) then
10623 Arg2
:= Next
(Arg1
);
10625 if Present
(Arg2
) then
10626 Arg3
:= Next
(Arg2
);
10628 if Present
(Arg3
) then
10629 Arg4
:= Next
(Arg3
);
10635 -- An enumeration type defines the pragmas that are supported by the
10636 -- implementation. Get_Pragma_Id (in package Prag) transforms a name
10637 -- into the corresponding enumeration value for the following case.
10645 -- pragma Abort_Defer;
10647 when Pragma_Abort_Defer
=>
10649 Check_Arg_Count
(0);
10651 -- The only required semantic processing is to check the
10652 -- placement. This pragma must appear at the start of the
10653 -- statement sequence of a handled sequence of statements.
10655 if Nkind
(Parent
(N
)) /= N_Handled_Sequence_Of_Statements
10656 or else N
/= First
(Statements
(Parent
(N
)))
10661 --------------------
10662 -- Abstract_State --
10663 --------------------
10665 -- pragma Abstract_State (ABSTRACT_STATE_LIST);
10667 -- ABSTRACT_STATE_LIST ::=
10669 -- | STATE_NAME_WITH_OPTIONS
10670 -- | (STATE_NAME_WITH_OPTIONS {, STATE_NAME_WITH_OPTIONS})
10672 -- STATE_NAME_WITH_OPTIONS ::=
10674 -- | (STATE_NAME with OPTION_LIST)
10676 -- OPTION_LIST ::= OPTION {, OPTION}
10680 -- | NAME_VALUE_OPTION
10682 -- SIMPLE_OPTION ::= Ghost | Synchronous
10684 -- NAME_VALUE_OPTION ::=
10685 -- Part_Of => ABSTRACT_STATE
10686 -- | External [=> EXTERNAL_PROPERTY_LIST]
10688 -- EXTERNAL_PROPERTY_LIST ::=
10689 -- EXTERNAL_PROPERTY
10690 -- | (EXTERNAL_PROPERTY {, EXTERNAL_PROPERTY})
10692 -- EXTERNAL_PROPERTY ::=
10693 -- Async_Readers [=> boolean_EXPRESSION]
10694 -- | Async_Writers [=> boolean_EXPRESSION]
10695 -- | Effective_Reads [=> boolean_EXPRESSION]
10696 -- | Effective_Writes [=> boolean_EXPRESSION]
10697 -- others => boolean_EXPRESSION
10699 -- STATE_NAME ::= defining_identifier
10701 -- ABSTRACT_STATE ::= name
10703 -- Characteristics:
10705 -- * Analysis - The annotation is fully analyzed immediately upon
10706 -- elaboration as it cannot forward reference entities.
10708 -- * Expansion - None.
10710 -- * Template - The annotation utilizes the generic template of the
10711 -- related package declaration.
10713 -- * Globals - The annotation cannot reference global entities.
10715 -- * Instance - The annotation is instantiated automatically when
10716 -- the related generic package is instantiated.
10718 when Pragma_Abstract_State
=> Abstract_State
: declare
10719 Missing_Parentheses
: Boolean := False;
10720 -- Flag set when a state declaration with options is not properly
10723 -- Flags used to verify the consistency of states
10725 Non_Null_Seen
: Boolean := False;
10726 Null_Seen
: Boolean := False;
10728 procedure Analyze_Abstract_State
10730 Pack_Id
: Entity_Id
);
10731 -- Verify the legality of a single state declaration. Create and
10732 -- decorate a state abstraction entity and introduce it into the
10733 -- visibility chain. Pack_Id denotes the entity or the related
10734 -- package where pragma Abstract_State appears.
10736 procedure Malformed_State_Error
(State
: Node_Id
);
10737 -- Emit an error concerning the illegal declaration of abstract
10738 -- state State. This routine diagnoses syntax errors that lead to
10739 -- a different parse tree. The error is issued regardless of the
10740 -- SPARK mode in effect.
10742 ----------------------------
10743 -- Analyze_Abstract_State --
10744 ----------------------------
10746 procedure Analyze_Abstract_State
10748 Pack_Id
: Entity_Id
)
10750 -- Flags used to verify the consistency of options
10752 AR_Seen
: Boolean := False;
10753 AW_Seen
: Boolean := False;
10754 ER_Seen
: Boolean := False;
10755 EW_Seen
: Boolean := False;
10756 External_Seen
: Boolean := False;
10757 Ghost_Seen
: Boolean := False;
10758 Others_Seen
: Boolean := False;
10759 Part_Of_Seen
: Boolean := False;
10760 Synchronous_Seen
: Boolean := False;
10762 -- Flags used to store the static value of all external states'
10765 AR_Val
: Boolean := False;
10766 AW_Val
: Boolean := False;
10767 ER_Val
: Boolean := False;
10768 EW_Val
: Boolean := False;
10770 State_Id
: Entity_Id
:= Empty
;
10771 -- The entity to be generated for the current state declaration
10773 procedure Analyze_External_Option
(Opt
: Node_Id
);
10774 -- Verify the legality of option External
10776 procedure Analyze_External_Property
10778 Expr
: Node_Id
:= Empty
);
10779 -- Verify the legailty of a single external property. Prop
10780 -- denotes the external property. Expr is the expression used
10781 -- to set the property.
10783 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
);
10784 -- Verify the legality of option Part_Of
10786 procedure Check_Duplicate_Option
10788 Status
: in out Boolean);
10789 -- Flag Status denotes whether a particular option has been
10790 -- seen while processing a state. This routine verifies that
10791 -- Opt is not a duplicate option and sets the flag Status
10792 -- (SPARK RM 7.1.4(1)).
10794 procedure Check_Duplicate_Property
10796 Status
: in out Boolean);
10797 -- Flag Status denotes whether a particular property has been
10798 -- seen while processing option External. This routine verifies
10799 -- that Prop is not a duplicate property and sets flag Status.
10800 -- Opt is not a duplicate property and sets the flag Status.
10801 -- (SPARK RM 7.1.4(2))
10803 procedure Check_Ghost_Synchronous
;
10804 -- Ensure that the abstract state is not subject to both Ghost
10805 -- and Synchronous simple options. Emit an error if this is the
10808 procedure Create_Abstract_State
10812 Is_Null
: Boolean);
10813 -- Generate an abstract state entity with name Nam and enter it
10814 -- into visibility. Decl is the "declaration" of the state as
10815 -- it appears in pragma Abstract_State. Loc is the location of
10816 -- the related state "declaration". Flag Is_Null should be set
10817 -- when the associated Abstract_State pragma defines a null
10820 -----------------------------
10821 -- Analyze_External_Option --
10822 -----------------------------
10824 procedure Analyze_External_Option
(Opt
: Node_Id
) is
10825 Errors
: constant Nat
:= Serious_Errors_Detected
;
10827 Props
: Node_Id
:= Empty
;
10830 if Nkind
(Opt
) = N_Component_Association
then
10831 Props
:= Expression
(Opt
);
10834 -- External state with properties
10836 if Present
(Props
) then
10838 -- Multiple properties appear as an aggregate
10840 if Nkind
(Props
) = N_Aggregate
then
10842 -- Simple property form
10844 Prop
:= First
(Expressions
(Props
));
10845 while Present
(Prop
) loop
10846 Analyze_External_Property
(Prop
);
10850 -- Property with expression form
10852 Prop
:= First
(Component_Associations
(Props
));
10853 while Present
(Prop
) loop
10854 Analyze_External_Property
10855 (Prop
=> First
(Choices
(Prop
)),
10856 Expr
=> Expression
(Prop
));
10864 Analyze_External_Property
(Props
);
10867 -- An external state defined without any properties defaults
10868 -- all properties to True.
10877 -- Once all external properties have been processed, verify
10878 -- their mutual interaction. Do not perform the check when
10879 -- at least one of the properties is illegal as this will
10880 -- produce a bogus error.
10882 if Errors
= Serious_Errors_Detected
then
10883 Check_External_Properties
10884 (State
, AR_Val
, AW_Val
, ER_Val
, EW_Val
);
10886 end Analyze_External_Option
;
10888 -------------------------------
10889 -- Analyze_External_Property --
10890 -------------------------------
10892 procedure Analyze_External_Property
10894 Expr
: Node_Id
:= Empty
)
10896 Expr_Val
: Boolean;
10899 -- Check the placement of "others" (if available)
10901 if Nkind
(Prop
) = N_Others_Choice
then
10902 if Others_Seen
then
10904 ("only one others choice allowed in option External",
10907 Others_Seen
:= True;
10910 elsif Others_Seen
then
10912 ("others must be the last property in option External",
10915 -- The only remaining legal options are the four predefined
10916 -- external properties.
10918 elsif Nkind
(Prop
) = N_Identifier
10919 and then Nam_In
(Chars
(Prop
), Name_Async_Readers
,
10920 Name_Async_Writers
,
10921 Name_Effective_Reads
,
10922 Name_Effective_Writes
)
10926 -- Otherwise the construct is not a valid property
10929 SPARK_Msg_N
("invalid external state property", Prop
);
10933 -- Ensure that the expression of the external state property
10934 -- is static Boolean (if applicable) (SPARK RM 7.1.2(5)).
10936 if Present
(Expr
) then
10937 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
10939 if Is_OK_Static_Expression
(Expr
) then
10940 Expr_Val
:= Is_True
(Expr_Value
(Expr
));
10943 ("expression of external state property must be "
10947 -- The lack of expression defaults the property to True
10953 -- Named properties
10955 if Nkind
(Prop
) = N_Identifier
then
10956 if Chars
(Prop
) = Name_Async_Readers
then
10957 Check_Duplicate_Property
(Prop
, AR_Seen
);
10958 AR_Val
:= Expr_Val
;
10960 elsif Chars
(Prop
) = Name_Async_Writers
then
10961 Check_Duplicate_Property
(Prop
, AW_Seen
);
10962 AW_Val
:= Expr_Val
;
10964 elsif Chars
(Prop
) = Name_Effective_Reads
then
10965 Check_Duplicate_Property
(Prop
, ER_Seen
);
10966 ER_Val
:= Expr_Val
;
10969 Check_Duplicate_Property
(Prop
, EW_Seen
);
10970 EW_Val
:= Expr_Val
;
10973 -- The handling of property "others" must take into account
10974 -- all other named properties that have been encountered so
10975 -- far. Only those that have not been seen are affected by
10979 if not AR_Seen
then
10980 AR_Val
:= Expr_Val
;
10983 if not AW_Seen
then
10984 AW_Val
:= Expr_Val
;
10987 if not ER_Seen
then
10988 ER_Val
:= Expr_Val
;
10991 if not EW_Seen
then
10992 EW_Val
:= Expr_Val
;
10995 end Analyze_External_Property
;
10997 ----------------------------
10998 -- Analyze_Part_Of_Option --
10999 ----------------------------
11001 procedure Analyze_Part_Of_Option
(Opt
: Node_Id
) is
11002 Encap
: constant Node_Id
:= Expression
(Opt
);
11003 Constits
: Elist_Id
;
11004 Encap_Id
: Entity_Id
;
11008 Check_Duplicate_Option
(Opt
, Part_Of_Seen
);
11011 (Indic
=> First
(Choices
(Opt
)),
11012 Item_Id
=> State_Id
,
11014 Encap_Id
=> Encap_Id
,
11017 -- The Part_Of indicator transforms the abstract state into
11018 -- a constituent of the encapsulating state or single
11019 -- concurrent type.
11022 pragma Assert
(Present
(Encap_Id
));
11023 Constits
:= Part_Of_Constituents
(Encap_Id
);
11025 if No
(Constits
) then
11026 Constits
:= New_Elmt_List
;
11027 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
11030 Append_Elmt
(State_Id
, Constits
);
11031 Set_Encapsulating_State
(State_Id
, Encap_Id
);
11033 end Analyze_Part_Of_Option
;
11035 ----------------------------
11036 -- Check_Duplicate_Option --
11037 ----------------------------
11039 procedure Check_Duplicate_Option
11041 Status
: in out Boolean)
11045 SPARK_Msg_N
("duplicate state option", Opt
);
11049 end Check_Duplicate_Option
;
11051 ------------------------------
11052 -- Check_Duplicate_Property --
11053 ------------------------------
11055 procedure Check_Duplicate_Property
11057 Status
: in out Boolean)
11061 SPARK_Msg_N
("duplicate external property", Prop
);
11065 end Check_Duplicate_Property
;
11067 -----------------------------
11068 -- Check_Ghost_Synchronous --
11069 -----------------------------
11071 procedure Check_Ghost_Synchronous
is
11073 -- A synchronized abstract state cannot be Ghost and vice
11074 -- versa (SPARK RM 6.9(19)).
11076 if Ghost_Seen
and Synchronous_Seen
then
11077 SPARK_Msg_N
("synchronized state cannot be ghost", State
);
11079 end Check_Ghost_Synchronous
;
11081 ---------------------------
11082 -- Create_Abstract_State --
11083 ---------------------------
11085 procedure Create_Abstract_State
11092 -- The abstract state may be semi-declared when the related
11093 -- package was withed through a limited with clause. In that
11094 -- case reuse the entity to fully declare the state.
11096 if Present
(Decl
) and then Present
(Entity
(Decl
)) then
11097 State_Id
:= Entity
(Decl
);
11099 -- Otherwise the elaboration of pragma Abstract_State
11100 -- declares the state.
11103 State_Id
:= Make_Defining_Identifier
(Loc
, Nam
);
11105 if Present
(Decl
) then
11106 Set_Entity
(Decl
, State_Id
);
11110 -- Null states never come from source
11112 Set_Comes_From_Source
(State_Id
, not Is_Null
);
11113 Set_Parent
(State_Id
, State
);
11114 Set_Ekind
(State_Id
, E_Abstract_State
);
11115 Set_Etype
(State_Id
, Standard_Void_Type
);
11116 Set_Encapsulating_State
(State_Id
, Empty
);
11118 -- An abstract state declared within a Ghost region becomes
11119 -- Ghost (SPARK RM 6.9(2)).
11121 if Ghost_Mode
> None
or else Is_Ghost_Entity
(Pack_Id
) then
11122 Set_Is_Ghost_Entity
(State_Id
);
11125 -- Establish a link between the state declaration and the
11126 -- abstract state entity. Note that a null state remains as
11127 -- N_Null and does not carry any linkages.
11129 if not Is_Null
then
11130 if Present
(Decl
) then
11131 Set_Entity
(Decl
, State_Id
);
11132 Set_Etype
(Decl
, Standard_Void_Type
);
11135 -- Every non-null state must be defined, nameable and
11138 Push_Scope
(Pack_Id
);
11139 Generate_Definition
(State_Id
);
11140 Enter_Name
(State_Id
);
11143 end Create_Abstract_State
;
11150 -- Start of processing for Analyze_Abstract_State
11153 -- A package with a null abstract state is not allowed to
11154 -- declare additional states.
11158 ("package & has null abstract state", State
, Pack_Id
);
11160 -- Null states appear as internally generated entities
11162 elsif Nkind
(State
) = N_Null
then
11163 Create_Abstract_State
11164 (Nam
=> New_Internal_Name
('S'),
11166 Loc
=> Sloc
(State
),
11170 -- Catch a case where a null state appears in a list of
11171 -- non-null states.
11173 if Non_Null_Seen
then
11175 ("package & has non-null abstract state",
11179 -- Simple state declaration
11181 elsif Nkind
(State
) = N_Identifier
then
11182 Create_Abstract_State
11183 (Nam
=> Chars
(State
),
11185 Loc
=> Sloc
(State
),
11187 Non_Null_Seen
:= True;
11189 -- State declaration with various options. This construct
11190 -- appears as an extension aggregate in the tree.
11192 elsif Nkind
(State
) = N_Extension_Aggregate
then
11193 if Nkind
(Ancestor_Part
(State
)) = N_Identifier
then
11194 Create_Abstract_State
11195 (Nam
=> Chars
(Ancestor_Part
(State
)),
11196 Decl
=> Ancestor_Part
(State
),
11197 Loc
=> Sloc
(Ancestor_Part
(State
)),
11199 Non_Null_Seen
:= True;
11202 ("state name must be an identifier",
11203 Ancestor_Part
(State
));
11206 -- Options External, Ghost and Synchronous appear as
11209 Opt
:= First
(Expressions
(State
));
11210 while Present
(Opt
) loop
11211 if Nkind
(Opt
) = N_Identifier
then
11215 if Chars
(Opt
) = Name_External
then
11216 Check_Duplicate_Option
(Opt
, External_Seen
);
11217 Analyze_External_Option
(Opt
);
11221 elsif Chars
(Opt
) = Name_Ghost
then
11222 Check_Duplicate_Option
(Opt
, Ghost_Seen
);
11223 Check_Ghost_Synchronous
;
11225 if Present
(State_Id
) then
11226 Set_Is_Ghost_Entity
(State_Id
);
11231 elsif Chars
(Opt
) = Name_Synchronous
then
11232 Check_Duplicate_Option
(Opt
, Synchronous_Seen
);
11233 Check_Ghost_Synchronous
;
11235 -- Option Part_Of without an encapsulating state is
11236 -- illegal (SPARK RM 7.1.4(9)).
11238 elsif Chars
(Opt
) = Name_Part_Of
then
11240 ("indicator Part_Of must denote abstract state, "
11241 & "single protected type or single task type",
11244 -- Do not emit an error message when a previous state
11245 -- declaration with options was not parenthesized as
11246 -- the option is actually another state declaration.
11248 -- with Abstract_State
11249 -- (State_1 with ..., -- missing parentheses
11250 -- (State_2 with ...),
11251 -- State_3) -- ok state declaration
11253 elsif Missing_Parentheses
then
11256 -- Otherwise the option is not allowed. Note that it
11257 -- is not possible to distinguish between an option
11258 -- and a state declaration when a previous state with
11259 -- options not properly parentheses.
11261 -- with Abstract_State
11262 -- (State_1 with ..., -- missing parentheses
11263 -- State_2); -- could be an option
11267 ("simple option not allowed in state declaration",
11271 -- Catch a case where missing parentheses around a state
11272 -- declaration with options cause a subsequent state
11273 -- declaration with options to be treated as an option.
11275 -- with Abstract_State
11276 -- (State_1 with ..., -- missing parentheses
11277 -- (State_2 with ...))
11279 elsif Nkind
(Opt
) = N_Extension_Aggregate
then
11280 Missing_Parentheses
:= True;
11282 ("state declaration must be parenthesized",
11283 Ancestor_Part
(State
));
11285 -- Otherwise the option is malformed
11288 SPARK_Msg_N
("malformed option", Opt
);
11294 -- Options External and Part_Of appear as component
11297 Opt
:= First
(Component_Associations
(State
));
11298 while Present
(Opt
) loop
11299 Opt_Nam
:= First
(Choices
(Opt
));
11301 if Nkind
(Opt_Nam
) = N_Identifier
then
11302 if Chars
(Opt_Nam
) = Name_External
then
11303 Analyze_External_Option
(Opt
);
11305 elsif Chars
(Opt_Nam
) = Name_Part_Of
then
11306 Analyze_Part_Of_Option
(Opt
);
11309 SPARK_Msg_N
("invalid state option", Opt
);
11312 SPARK_Msg_N
("invalid state option", Opt
);
11318 -- Any other attempt to declare a state is illegal
11321 Malformed_State_Error
(State
);
11325 -- Guard against a junk state. In such cases no entity is
11326 -- generated and the subsequent checks cannot be applied.
11328 if Present
(State_Id
) then
11330 -- Verify whether the state does not introduce an illegal
11331 -- hidden state within a package subject to a null abstract
11334 Check_No_Hidden_State
(State_Id
);
11336 -- Check whether the lack of option Part_Of agrees with the
11337 -- placement of the abstract state with respect to the state
11340 if not Part_Of_Seen
then
11341 Check_Missing_Part_Of
(State_Id
);
11344 -- Associate the state with its related package
11346 if No
(Abstract_States
(Pack_Id
)) then
11347 Set_Abstract_States
(Pack_Id
, New_Elmt_List
);
11350 Append_Elmt
(State_Id
, Abstract_States
(Pack_Id
));
11352 end Analyze_Abstract_State
;
11354 ---------------------------
11355 -- Malformed_State_Error --
11356 ---------------------------
11358 procedure Malformed_State_Error
(State
: Node_Id
) is
11360 Error_Msg_N
("malformed abstract state declaration", State
);
11362 -- An abstract state with a simple option is being declared
11363 -- with "=>" rather than the legal "with". The state appears
11364 -- as a component association.
11366 if Nkind
(State
) = N_Component_Association
then
11367 Error_Msg_N
("\use WITH to specify simple option", State
);
11369 end Malformed_State_Error
;
11373 Pack_Decl
: Node_Id
;
11374 Pack_Id
: Entity_Id
;
11378 -- Start of processing for Abstract_State
11382 Check_No_Identifiers
;
11383 Check_Arg_Count
(1);
11385 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
11387 -- Ensure the proper placement of the pragma. Abstract states must
11388 -- be associated with a package declaration.
11390 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
11391 N_Package_Declaration
)
11395 -- Otherwise the pragma is associated with an illegal construct
11402 Pack_Id
:= Defining_Entity
(Pack_Decl
);
11404 -- A pragma that applies to a Ghost entity becomes Ghost for the
11405 -- purposes of legality checks and removal of ignored Ghost code.
11407 Mark_Ghost_Pragma
(N
, Pack_Id
);
11408 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
11410 -- Chain the pragma on the contract for completeness
11412 Add_Contract_Item
(N
, Pack_Id
);
11414 -- The legality checks of pragmas Abstract_State, Initializes, and
11415 -- Initial_Condition are affected by the SPARK mode in effect. In
11416 -- addition, these three pragmas are subject to an inherent order:
11418 -- 1) Abstract_State
11420 -- 3) Initial_Condition
11422 -- Analyze all these pragmas in the order outlined above
11424 Analyze_If_Present
(Pragma_SPARK_Mode
);
11425 States
:= Expression
(Get_Argument
(N
, Pack_Id
));
11427 -- Multiple non-null abstract states appear as an aggregate
11429 if Nkind
(States
) = N_Aggregate
then
11430 State
:= First
(Expressions
(States
));
11431 while Present
(State
) loop
11432 Analyze_Abstract_State
(State
, Pack_Id
);
11436 -- An abstract state with a simple option is being illegaly
11437 -- declared with "=>" rather than "with". In this case the
11438 -- state declaration appears as a component association.
11440 if Present
(Component_Associations
(States
)) then
11441 State
:= First
(Component_Associations
(States
));
11442 while Present
(State
) loop
11443 Malformed_State_Error
(State
);
11448 -- Various forms of a single abstract state. Note that these may
11449 -- include malformed state declarations.
11452 Analyze_Abstract_State
(States
, Pack_Id
);
11455 Analyze_If_Present
(Pragma_Initializes
);
11456 Analyze_If_Present
(Pragma_Initial_Condition
);
11457 end Abstract_State
;
11465 -- Note: this pragma also has some specific processing in Par.Prag
11466 -- because we want to set the Ada version mode during parsing.
11468 when Pragma_Ada_83
=>
11470 Check_Arg_Count
(0);
11472 -- We really should check unconditionally for proper configuration
11473 -- pragma placement, since we really don't want mixed Ada modes
11474 -- within a single unit, and the GNAT reference manual has always
11475 -- said this was a configuration pragma, but we did not check and
11476 -- are hesitant to add the check now.
11478 -- However, we really cannot tolerate mixing Ada 2005 or Ada 2012
11479 -- with Ada 83 or Ada 95, so we must check if we are in Ada 2005
11480 -- or Ada 2012 mode.
11482 if Ada_Version
>= Ada_2005
then
11483 Check_Valid_Configuration_Pragma
;
11486 -- Now set Ada 83 mode
11488 if Latest_Ada_Only
then
11489 Error_Pragma
("??pragma% ignored");
11491 Ada_Version
:= Ada_83
;
11492 Ada_Version_Explicit
:= Ada_83
;
11493 Ada_Version_Pragma
:= N
;
11502 -- Note: this pragma also has some specific processing in Par.Prag
11503 -- because we want to set the Ada 83 version mode during parsing.
11505 when Pragma_Ada_95
=>
11507 Check_Arg_Count
(0);
11509 -- We really should check unconditionally for proper configuration
11510 -- pragma placement, since we really don't want mixed Ada modes
11511 -- within a single unit, and the GNAT reference manual has always
11512 -- said this was a configuration pragma, but we did not check and
11513 -- are hesitant to add the check now.
11515 -- However, we really cannot tolerate mixing Ada 2005 with Ada 83
11516 -- or Ada 95, so we must check if we are in Ada 2005 mode.
11518 if Ada_Version
>= Ada_2005
then
11519 Check_Valid_Configuration_Pragma
;
11522 -- Now set Ada 95 mode
11524 if Latest_Ada_Only
then
11525 Error_Pragma
("??pragma% ignored");
11527 Ada_Version
:= Ada_95
;
11528 Ada_Version_Explicit
:= Ada_95
;
11529 Ada_Version_Pragma
:= N
;
11532 ---------------------
11533 -- Ada_05/Ada_2005 --
11534 ---------------------
11537 -- pragma Ada_05 (LOCAL_NAME);
11539 -- pragma Ada_2005;
11540 -- pragma Ada_2005 (LOCAL_NAME):
11542 -- Note: these pragmas also have some specific processing in Par.Prag
11543 -- because we want to set the Ada 2005 version mode during parsing.
11545 -- The one argument form is used for managing the transition from
11546 -- Ada 95 to Ada 2005 in the run-time library. If an entity is marked
11547 -- as Ada_2005 only, then referencing the entity in Ada_83 or Ada_95
11548 -- mode will generate a warning. In addition, in Ada_83 or Ada_95
11549 -- mode, a preference rule is established which does not choose
11550 -- such an entity unless it is unambiguously specified. This avoids
11551 -- extra subprograms marked this way from generating ambiguities in
11552 -- otherwise legal pre-Ada_2005 programs. The one argument form is
11553 -- intended for exclusive use in the GNAT run-time library.
11564 if Arg_Count
= 1 then
11565 Check_Arg_Is_Local_Name
(Arg1
);
11566 E_Id
:= Get_Pragma_Arg
(Arg1
);
11568 if Etype
(E_Id
) = Any_Type
then
11572 Set_Is_Ada_2005_Only
(Entity
(E_Id
));
11573 Record_Rep_Item
(Entity
(E_Id
), N
);
11576 Check_Arg_Count
(0);
11578 -- For Ada_2005 we unconditionally enforce the documented
11579 -- configuration pragma placement, since we do not want to
11580 -- tolerate mixed modes in a unit involving Ada 2005. That
11581 -- would cause real difficulties for those cases where there
11582 -- are incompatibilities between Ada 95 and Ada 2005.
11584 Check_Valid_Configuration_Pragma
;
11586 -- Now set appropriate Ada mode
11588 if Latest_Ada_Only
then
11589 Error_Pragma
("??pragma% ignored");
11591 Ada_Version
:= Ada_2005
;
11592 Ada_Version_Explicit
:= Ada_2005
;
11593 Ada_Version_Pragma
:= N
;
11598 ---------------------
11599 -- Ada_12/Ada_2012 --
11600 ---------------------
11603 -- pragma Ada_12 (LOCAL_NAME);
11605 -- pragma Ada_2012;
11606 -- pragma Ada_2012 (LOCAL_NAME):
11608 -- Note: these pragmas also have some specific processing in Par.Prag
11609 -- because we want to set the Ada 2012 version mode during parsing.
11611 -- The one argument form is used for managing the transition from Ada
11612 -- 2005 to Ada 2012 in the run-time library. If an entity is marked
11613 -- as Ada_201 only, then referencing the entity in any pre-Ada_2012
11614 -- mode will generate a warning. In addition, in any pre-Ada_2012
11615 -- mode, a preference rule is established which does not choose
11616 -- such an entity unless it is unambiguously specified. This avoids
11617 -- extra subprograms marked this way from generating ambiguities in
11618 -- otherwise legal pre-Ada_2012 programs. The one argument form is
11619 -- intended for exclusive use in the GNAT run-time library.
11630 if Arg_Count
= 1 then
11631 Check_Arg_Is_Local_Name
(Arg1
);
11632 E_Id
:= Get_Pragma_Arg
(Arg1
);
11634 if Etype
(E_Id
) = Any_Type
then
11638 Set_Is_Ada_2012_Only
(Entity
(E_Id
));
11639 Record_Rep_Item
(Entity
(E_Id
), N
);
11642 Check_Arg_Count
(0);
11644 -- For Ada_2012 we unconditionally enforce the documented
11645 -- configuration pragma placement, since we do not want to
11646 -- tolerate mixed modes in a unit involving Ada 2012. That
11647 -- would cause real difficulties for those cases where there
11648 -- are incompatibilities between Ada 95 and Ada 2012. We could
11649 -- allow mixing of Ada 2005 and Ada 2012 but it's not worth it.
11651 Check_Valid_Configuration_Pragma
;
11653 -- Now set appropriate Ada mode
11655 Ada_Version
:= Ada_2012
;
11656 Ada_Version_Explicit
:= Ada_2012
;
11657 Ada_Version_Pragma
:= N
;
11661 ----------------------
11662 -- All_Calls_Remote --
11663 ----------------------
11665 -- pragma All_Calls_Remote [(library_package_NAME)];
11667 when Pragma_All_Calls_Remote
=> All_Calls_Remote
: declare
11668 Lib_Entity
: Entity_Id
;
11671 Check_Ada_83_Warning
;
11672 Check_Valid_Library_Unit_Pragma
;
11674 if Nkind
(N
) = N_Null_Statement
then
11678 Lib_Entity
:= Find_Lib_Unit_Name
;
11680 -- A pragma that applies to a Ghost entity becomes Ghost for the
11681 -- purposes of legality checks and removal of ignored Ghost code.
11683 Mark_Ghost_Pragma
(N
, Lib_Entity
);
11685 -- This pragma should only apply to a RCI unit (RM E.2.3(23))
11687 if Present
(Lib_Entity
) and then not Debug_Flag_U
then
11688 if not Is_Remote_Call_Interface
(Lib_Entity
) then
11689 Error_Pragma
("pragma% only apply to rci unit");
11691 -- Set flag for entity of the library unit
11694 Set_Has_All_Calls_Remote
(Lib_Entity
);
11697 end All_Calls_Remote
;
11699 ---------------------------
11700 -- Allow_Integer_Address --
11701 ---------------------------
11703 -- pragma Allow_Integer_Address;
11705 when Pragma_Allow_Integer_Address
=>
11707 Check_Valid_Configuration_Pragma
;
11708 Check_Arg_Count
(0);
11710 -- If Address is a private type, then set the flag to allow
11711 -- integer address values. If Address is not private, then this
11712 -- pragma has no purpose, so it is simply ignored. Not clear if
11713 -- there are any such targets now.
11715 if Opt
.Address_Is_Private
then
11716 Opt
.Allow_Integer_Address
:= True;
11724 -- (IDENTIFIER [, IDENTIFIER {, ARG}] [,Entity => local_NAME]);
11725 -- ARG ::= NAME | EXPRESSION
11727 -- The first two arguments are by convention intended to refer to an
11728 -- external tool and a tool-specific function. These arguments are
11731 when Pragma_Annotate
=> Annotate
: declare
11738 Check_At_Least_N_Arguments
(1);
11740 Nam_Arg
:= Last
(Pragma_Argument_Associations
(N
));
11742 -- Determine whether the last argument is "Entity => local_NAME"
11743 -- and if it is, perform the required semantic checks. Remove the
11744 -- argument from further processing.
11746 if Nkind
(Nam_Arg
) = N_Pragma_Argument_Association
11747 and then Chars
(Nam_Arg
) = Name_Entity
11749 Check_Arg_Is_Local_Name
(Nam_Arg
);
11750 Arg_Count
:= Arg_Count
- 1;
11752 -- A pragma that applies to a Ghost entity becomes Ghost for
11753 -- the purposes of legality checks and removal of ignored Ghost
11756 if Is_Entity_Name
(Get_Pragma_Arg
(Nam_Arg
))
11757 and then Present
(Entity
(Get_Pragma_Arg
(Nam_Arg
)))
11759 Mark_Ghost_Pragma
(N
, Entity
(Get_Pragma_Arg
(Nam_Arg
)));
11762 -- Not allowed in compiler units (bootstrap issues)
11764 Check_Compiler_Unit
("Entity for pragma Annotate", N
);
11767 -- Continue the processing with last argument removed for now
11769 Check_Arg_Is_Identifier
(Arg1
);
11770 Check_No_Identifiers
;
11773 -- The second parameter is optional, it is never analyzed
11778 -- Otherwise there is a second parameter
11781 -- The second parameter must be an identifier
11783 Check_Arg_Is_Identifier
(Arg2
);
11785 -- Process the remaining parameters (if any)
11787 Arg
:= Next
(Arg2
);
11788 while Present
(Arg
) loop
11789 Expr
:= Get_Pragma_Arg
(Arg
);
11792 if Is_Entity_Name
(Expr
) then
11795 -- For string literals, we assume Standard_String as the
11796 -- type, unless the string contains wide or wide_wide
11799 elsif Nkind
(Expr
) = N_String_Literal
then
11800 if Has_Wide_Wide_Character
(Expr
) then
11801 Resolve
(Expr
, Standard_Wide_Wide_String
);
11802 elsif Has_Wide_Character
(Expr
) then
11803 Resolve
(Expr
, Standard_Wide_String
);
11805 Resolve
(Expr
, Standard_String
);
11808 elsif Is_Overloaded
(Expr
) then
11809 Error_Pragma_Arg
("ambiguous argument for pragma%", Expr
);
11820 -------------------------------------------------
11821 -- Assert/Assert_And_Cut/Assume/Loop_Invariant --
11822 -------------------------------------------------
11825 -- ( [Check => ] Boolean_EXPRESSION
11826 -- [, [Message =>] Static_String_EXPRESSION]);
11828 -- pragma Assert_And_Cut
11829 -- ( [Check => ] Boolean_EXPRESSION
11830 -- [, [Message =>] Static_String_EXPRESSION]);
11833 -- ( [Check => ] Boolean_EXPRESSION
11834 -- [, [Message =>] Static_String_EXPRESSION]);
11836 -- pragma Loop_Invariant
11837 -- ( [Check => ] Boolean_EXPRESSION
11838 -- [, [Message =>] Static_String_EXPRESSION]);
11841 | Pragma_Assert_And_Cut
11843 | Pragma_Loop_Invariant
11846 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean;
11847 -- Determine whether expression Expr contains a Loop_Entry
11848 -- attribute reference.
11850 -------------------------
11851 -- Contains_Loop_Entry --
11852 -------------------------
11854 function Contains_Loop_Entry
(Expr
: Node_Id
) return Boolean is
11855 Has_Loop_Entry
: Boolean := False;
11857 function Process
(N
: Node_Id
) return Traverse_Result
;
11858 -- Process function for traversal to look for Loop_Entry
11864 function Process
(N
: Node_Id
) return Traverse_Result
is
11866 if Nkind
(N
) = N_Attribute_Reference
11867 and then Attribute_Name
(N
) = Name_Loop_Entry
11869 Has_Loop_Entry
:= True;
11876 procedure Traverse
is new Traverse_Proc
(Process
);
11878 -- Start of processing for Contains_Loop_Entry
11882 return Has_Loop_Entry
;
11883 end Contains_Loop_Entry
;
11888 New_Args
: List_Id
;
11890 -- Start of processing for Assert
11893 -- Assert is an Ada 2005 RM-defined pragma
11895 if Prag_Id
= Pragma_Assert
then
11898 -- The remaining ones are GNAT pragmas
11904 Check_At_Least_N_Arguments
(1);
11905 Check_At_Most_N_Arguments
(2);
11906 Check_Arg_Order
((Name_Check
, Name_Message
));
11907 Check_Optional_Identifier
(Arg1
, Name_Check
);
11908 Expr
:= Get_Pragma_Arg
(Arg1
);
11910 -- Special processing for Loop_Invariant, Loop_Variant or for
11911 -- other cases where a Loop_Entry attribute is present. If the
11912 -- assertion pragma contains attribute Loop_Entry, ensure that
11913 -- the related pragma is within a loop.
11915 if Prag_Id
= Pragma_Loop_Invariant
11916 or else Prag_Id
= Pragma_Loop_Variant
11917 or else Contains_Loop_Entry
(Expr
)
11919 Check_Loop_Pragma_Placement
;
11921 -- Perform preanalysis to deal with embedded Loop_Entry
11924 Preanalyze_Assert_Expression
(Expr
, Any_Boolean
);
11927 -- Implement Assert[_And_Cut]/Assume/Loop_Invariant by generating
11928 -- a corresponding Check pragma:
11930 -- pragma Check (name, condition [, msg]);
11932 -- Where name is the identifier matching the pragma name. So
11933 -- rewrite pragma in this manner, transfer the message argument
11934 -- if present, and analyze the result
11936 -- Note: When dealing with a semantically analyzed tree, the
11937 -- information that a Check node N corresponds to a source Assert,
11938 -- Assume, or Assert_And_Cut pragma can be retrieved from the
11939 -- pragma kind of Original_Node(N).
11941 New_Args
:= New_List
(
11942 Make_Pragma_Argument_Association
(Loc
,
11943 Expression
=> Make_Identifier
(Loc
, Pname
)),
11944 Make_Pragma_Argument_Association
(Sloc
(Expr
),
11945 Expression
=> Expr
));
11947 if Arg_Count
> 1 then
11948 Check_Optional_Identifier
(Arg2
, Name_Message
);
11950 -- Provide semantic annnotations for optional argument, for
11951 -- ASIS use, before rewriting.
11953 Preanalyze_And_Resolve
(Expression
(Arg2
), Standard_String
);
11954 Append_To
(New_Args
, New_Copy_Tree
(Arg2
));
11957 -- Rewrite as Check pragma
11961 Chars
=> Name_Check
,
11962 Pragma_Argument_Associations
=> New_Args
));
11967 ----------------------
11968 -- Assertion_Policy --
11969 ----------------------
11971 -- pragma Assertion_Policy (POLICY_IDENTIFIER);
11973 -- The following form is Ada 2012 only, but we allow it in all modes
11975 -- Pragma Assertion_Policy (
11976 -- ASSERTION_KIND => POLICY_IDENTIFIER
11977 -- {, ASSERTION_KIND => POLICY_IDENTIFIER});
11979 -- ASSERTION_KIND ::= RM_ASSERTION_KIND | ID_ASSERTION_KIND
11981 -- RM_ASSERTION_KIND ::= Assert |
11982 -- Static_Predicate |
11983 -- Dynamic_Predicate |
11988 -- Type_Invariant |
11989 -- Type_Invariant'Class
11991 -- ID_ASSERTION_KIND ::= Assert_And_Cut |
11993 -- Contract_Cases |
11995 -- Default_Initial_Condition |
11997 -- Initial_Condition |
11998 -- Loop_Invariant |
12004 -- Statement_Assertions
12006 -- Note: The RM_ASSERTION_KIND list is language-defined, and the
12007 -- ID_ASSERTION_KIND list contains implementation-defined additions
12008 -- recognized by GNAT. The effect is to control the behavior of
12009 -- identically named aspects and pragmas, depending on the specified
12010 -- policy identifier:
12012 -- POLICY_IDENTIFIER ::= Check | Disable | Ignore | Suppressible
12014 -- Note: Check and Ignore are language-defined. Disable is a GNAT
12015 -- implementation-defined addition that results in totally ignoring
12016 -- the corresponding assertion. If Disable is specified, then the
12017 -- argument of the assertion is not even analyzed. This is useful
12018 -- when the aspect/pragma argument references entities in a with'ed
12019 -- package that is replaced by a dummy package in the final build.
12021 -- Note: the attribute forms Pre'Class, Post'Class, Invariant'Class,
12022 -- and Type_Invariant'Class were recognized by the parser and
12023 -- transformed into references to the special internal identifiers
12024 -- _Pre, _Post, _Invariant, and _Type_Invariant, so no special
12025 -- processing is required here.
12027 when Pragma_Assertion_Policy
=> Assertion_Policy
: declare
12028 procedure Resolve_Suppressible
(Policy
: Node_Id
);
12029 -- Converts the assertion policy 'Suppressible' to either Check or
12030 -- Ignore based on whether checks are suppressed via -gnatp.
12032 --------------------------
12033 -- Resolve_Suppressible --
12034 --------------------------
12036 procedure Resolve_Suppressible
(Policy
: Node_Id
) is
12037 Arg
: constant Node_Id
:= Get_Pragma_Arg
(Policy
);
12041 -- Transform policy argument Suppressible into either Ignore or
12042 -- Check depending on whether checks are enabled or suppressed.
12044 if Chars
(Arg
) = Name_Suppressible
then
12045 if Suppress_Checks
then
12046 Nam
:= Name_Ignore
;
12051 Rewrite
(Arg
, Make_Identifier
(Sloc
(Arg
), Nam
));
12053 end Resolve_Suppressible
;
12065 -- This can always appear as a configuration pragma
12067 if Is_Configuration_Pragma
then
12070 -- It can also appear in a declarative part or package spec in Ada
12071 -- 2012 mode. We allow this in other modes, but in that case we
12072 -- consider that we have an Ada 2012 pragma on our hands.
12075 Check_Is_In_Decl_Part_Or_Package_Spec
;
12079 -- One argument case with no identifier (first form above)
12082 and then (Nkind
(Arg1
) /= N_Pragma_Argument_Association
12083 or else Chars
(Arg1
) = No_Name
)
12085 Check_Arg_Is_One_Of
(Arg1
,
12086 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12088 Resolve_Suppressible
(Arg1
);
12090 -- Treat one argument Assertion_Policy as equivalent to:
12092 -- pragma Check_Policy (Assertion, policy)
12094 -- So rewrite pragma in that manner and link on to the chain
12095 -- of Check_Policy pragmas, marking the pragma as analyzed.
12097 Policy
:= Get_Pragma_Arg
(Arg1
);
12101 Chars
=> Name_Check_Policy
,
12102 Pragma_Argument_Associations
=> New_List
(
12103 Make_Pragma_Argument_Association
(Loc
,
12104 Expression
=> Make_Identifier
(Loc
, Name_Assertion
)),
12106 Make_Pragma_Argument_Association
(Loc
,
12108 Make_Identifier
(Sloc
(Policy
), Chars
(Policy
))))));
12111 -- Here if we have two or more arguments
12114 Check_At_Least_N_Arguments
(1);
12117 -- Loop through arguments
12120 while Present
(Arg
) loop
12121 LocP
:= Sloc
(Arg
);
12123 -- Kind must be specified
12125 if Nkind
(Arg
) /= N_Pragma_Argument_Association
12126 or else Chars
(Arg
) = No_Name
12129 ("missing assertion kind for pragma%", Arg
);
12132 -- Check Kind and Policy have allowed forms
12134 Kind
:= Chars
(Arg
);
12135 Policy
:= Get_Pragma_Arg
(Arg
);
12137 if not Is_Valid_Assertion_Kind
(Kind
) then
12139 ("invalid assertion kind for pragma%", Arg
);
12142 Check_Arg_Is_One_Of
(Arg
,
12143 Name_Check
, Name_Disable
, Name_Ignore
, Name_Suppressible
);
12145 Resolve_Suppressible
(Arg
);
12147 if Kind
= Name_Ghost
then
12149 -- The Ghost policy must be either Check or Ignore
12150 -- (SPARK RM 6.9(6)).
12152 if not Nam_In
(Chars
(Policy
), Name_Check
,
12156 ("argument of pragma % Ghost must be Check or "
12157 & "Ignore", Policy
);
12160 -- Pragma Assertion_Policy specifying a Ghost policy
12161 -- cannot occur within a Ghost subprogram or package
12162 -- (SPARK RM 6.9(14)).
12164 if Ghost_Mode
> None
then
12166 ("pragma % cannot appear within ghost subprogram or "
12171 -- Rewrite the Assertion_Policy pragma as a series of
12172 -- Check_Policy pragmas of the form:
12174 -- Check_Policy (Kind, Policy);
12176 -- Note: the insertion of the pragmas cannot be done with
12177 -- Insert_Action because in the configuration case, there
12178 -- are no scopes on the scope stack and the mechanism will
12181 Insert_Before_And_Analyze
(N
,
12183 Chars
=> Name_Check_Policy
,
12184 Pragma_Argument_Associations
=> New_List
(
12185 Make_Pragma_Argument_Association
(LocP
,
12186 Expression
=> Make_Identifier
(LocP
, Kind
)),
12187 Make_Pragma_Argument_Association
(LocP
,
12188 Expression
=> Policy
))));
12193 -- Rewrite the Assertion_Policy pragma as null since we have
12194 -- now inserted all the equivalent Check pragmas.
12196 Rewrite
(N
, Make_Null_Statement
(Loc
));
12199 end Assertion_Policy
;
12201 ------------------------------
12202 -- Assume_No_Invalid_Values --
12203 ------------------------------
12205 -- pragma Assume_No_Invalid_Values (On | Off);
12207 when Pragma_Assume_No_Invalid_Values
=>
12209 Check_Valid_Configuration_Pragma
;
12210 Check_Arg_Count
(1);
12211 Check_No_Identifiers
;
12212 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
12214 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
12215 Assume_No_Invalid_Values
:= True;
12217 Assume_No_Invalid_Values
:= False;
12220 --------------------------
12221 -- Attribute_Definition --
12222 --------------------------
12224 -- pragma Attribute_Definition
12225 -- ([Attribute =>] ATTRIBUTE_DESIGNATOR,
12226 -- [Entity =>] LOCAL_NAME,
12227 -- [Expression =>] EXPRESSION | NAME);
12229 when Pragma_Attribute_Definition
=> Attribute_Definition
: declare
12230 Attribute_Designator
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
12235 Check_Arg_Count
(3);
12236 Check_Optional_Identifier
(Arg1
, "attribute");
12237 Check_Optional_Identifier
(Arg2
, "entity");
12238 Check_Optional_Identifier
(Arg3
, "expression");
12240 if Nkind
(Attribute_Designator
) /= N_Identifier
then
12241 Error_Msg_N
("attribute name expected", Attribute_Designator
);
12245 Check_Arg_Is_Local_Name
(Arg2
);
12247 -- If the attribute is not recognized, then issue a warning (not
12248 -- an error), and ignore the pragma.
12250 Aname
:= Chars
(Attribute_Designator
);
12252 if not Is_Attribute_Name
(Aname
) then
12253 Bad_Attribute
(Attribute_Designator
, Aname
, Warn
=> True);
12257 -- Otherwise, rewrite the pragma as an attribute definition clause
12260 Make_Attribute_Definition_Clause
(Loc
,
12261 Name
=> Get_Pragma_Arg
(Arg2
),
12263 Expression
=> Get_Pragma_Arg
(Arg3
)));
12265 end Attribute_Definition
;
12267 ------------------------------------------------------------------
12268 -- Async_Readers/Async_Writers/Effective_Reads/Effective_Writes --
12269 ------------------------------------------------------------------
12271 -- pragma Asynch_Readers [ (boolean_EXPRESSION) ];
12272 -- pragma Asynch_Writers [ (boolean_EXPRESSION) ];
12273 -- pragma Effective_Reads [ (boolean_EXPRESSION) ];
12274 -- pragma Effective_Writes [ (boolean_EXPRESSION) ];
12276 when Pragma_Async_Readers
12277 | Pragma_Async_Writers
12278 | Pragma_Effective_Reads
12279 | Pragma_Effective_Writes
12281 Async_Effective
: declare
12282 Obj_Decl
: Node_Id
;
12283 Obj_Id
: Entity_Id
;
12287 Check_No_Identifiers
;
12288 Check_At_Most_N_Arguments
(1);
12290 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
12292 -- Object declaration
12294 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
12297 -- Otherwise the pragma is associated with an illegal construact
12304 Obj_Id
:= Defining_Entity
(Obj_Decl
);
12306 -- Perform minimal verification to ensure that the argument is at
12307 -- least a variable. Subsequent finer grained checks will be done
12308 -- at the end of the declarative region the contains the pragma.
12310 if Ekind
(Obj_Id
) = E_Variable
then
12312 -- A pragma that applies to a Ghost entity becomes Ghost for
12313 -- the purposes of legality checks and removal of ignored Ghost
12316 Mark_Ghost_Pragma
(N
, Obj_Id
);
12318 -- Chain the pragma on the contract for further processing by
12319 -- Analyze_External_Property_In_Decl_Part.
12321 Add_Contract_Item
(N
, Obj_Id
);
12323 -- Analyze the Boolean expression (if any)
12325 if Present
(Arg1
) then
12326 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
12329 -- Otherwise the external property applies to a constant
12332 Error_Pragma
("pragma % must apply to a volatile object");
12334 end Async_Effective
;
12340 -- pragma Asynchronous (LOCAL_NAME);
12342 when Pragma_Asynchronous
=> Asynchronous
: declare
12345 Formal
: Entity_Id
;
12350 procedure Process_Async_Pragma
;
12351 -- Common processing for procedure and access-to-procedure case
12353 --------------------------
12354 -- Process_Async_Pragma --
12355 --------------------------
12357 procedure Process_Async_Pragma
is
12360 Set_Is_Asynchronous
(Nm
);
12364 -- The formals should be of mode IN (RM E.4.1(6))
12367 while Present
(S
) loop
12368 Formal
:= Defining_Identifier
(S
);
12370 if Nkind
(Formal
) = N_Defining_Identifier
12371 and then Ekind
(Formal
) /= E_In_Parameter
12374 ("pragma% procedure can only have IN parameter",
12381 Set_Is_Asynchronous
(Nm
);
12382 end Process_Async_Pragma
;
12384 -- Start of processing for pragma Asynchronous
12387 Check_Ada_83_Warning
;
12388 Check_No_Identifiers
;
12389 Check_Arg_Count
(1);
12390 Check_Arg_Is_Local_Name
(Arg1
);
12392 if Debug_Flag_U
then
12396 C_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
12397 Analyze
(Get_Pragma_Arg
(Arg1
));
12398 Nm
:= Entity
(Get_Pragma_Arg
(Arg1
));
12400 -- A pragma that applies to a Ghost entity becomes Ghost for the
12401 -- purposes of legality checks and removal of ignored Ghost code.
12403 Mark_Ghost_Pragma
(N
, Nm
);
12405 if not Is_Remote_Call_Interface
(C_Ent
)
12406 and then not Is_Remote_Types
(C_Ent
)
12408 -- This pragma should only appear in an RCI or Remote Types
12409 -- unit (RM E.4.1(4)).
12412 ("pragma% not in Remote_Call_Interface or Remote_Types unit");
12415 if Ekind
(Nm
) = E_Procedure
12416 and then Nkind
(Parent
(Nm
)) = N_Procedure_Specification
12418 if not Is_Remote_Call_Interface
(Nm
) then
12420 ("pragma% cannot be applied on non-remote procedure",
12424 L
:= Parameter_Specifications
(Parent
(Nm
));
12425 Process_Async_Pragma
;
12428 elsif Ekind
(Nm
) = E_Function
then
12430 ("pragma% cannot be applied to function", Arg1
);
12432 elsif Is_Remote_Access_To_Subprogram_Type
(Nm
) then
12433 if Is_Record_Type
(Nm
) then
12435 -- A record type that is the Equivalent_Type for a remote
12436 -- access-to-subprogram type.
12438 Decl
:= Declaration_Node
(Corresponding_Remote_Type
(Nm
));
12441 -- A non-expanded RAS type (distribution is not enabled)
12443 Decl
:= Declaration_Node
(Nm
);
12446 if Nkind
(Decl
) = N_Full_Type_Declaration
12447 and then Nkind
(Type_Definition
(Decl
)) =
12448 N_Access_Procedure_Definition
12450 L
:= Parameter_Specifications
(Type_Definition
(Decl
));
12451 Process_Async_Pragma
;
12453 if Is_Asynchronous
(Nm
)
12454 and then Expander_Active
12455 and then Get_PCS_Name
/= Name_No_DSA
12457 RACW_Type_Is_Asynchronous
(Underlying_RACW_Type
(Nm
));
12462 ("pragma% cannot reference access-to-function type",
12466 -- Only other possibility is Access-to-class-wide type
12468 elsif Is_Access_Type
(Nm
)
12469 and then Is_Class_Wide_Type
(Designated_Type
(Nm
))
12471 Check_First_Subtype
(Arg1
);
12472 Set_Is_Asynchronous
(Nm
);
12473 if Expander_Active
then
12474 RACW_Type_Is_Asynchronous
(Nm
);
12478 Error_Pragma_Arg
("inappropriate argument for pragma%", Arg1
);
12486 -- pragma Atomic (LOCAL_NAME);
12488 when Pragma_Atomic
=>
12489 Process_Atomic_Independent_Shared_Volatile
;
12491 -----------------------
12492 -- Atomic_Components --
12493 -----------------------
12495 -- pragma Atomic_Components (array_LOCAL_NAME);
12497 -- This processing is shared by Volatile_Components
12499 when Pragma_Atomic_Components
12500 | Pragma_Volatile_Components
12502 Atomic_Components
: declare
12509 Check_Ada_83_Warning
;
12510 Check_No_Identifiers
;
12511 Check_Arg_Count
(1);
12512 Check_Arg_Is_Local_Name
(Arg1
);
12513 E_Id
:= Get_Pragma_Arg
(Arg1
);
12515 if Etype
(E_Id
) = Any_Type
then
12519 E
:= Entity
(E_Id
);
12521 -- A pragma that applies to a Ghost entity becomes Ghost for the
12522 -- purposes of legality checks and removal of ignored Ghost code.
12524 Mark_Ghost_Pragma
(N
, E
);
12525 Check_Duplicate_Pragma
(E
);
12527 if Rep_Item_Too_Early
(E
, N
)
12529 Rep_Item_Too_Late
(E
, N
)
12534 D
:= Declaration_Node
(E
);
12537 if (K
= N_Full_Type_Declaration
and then Is_Array_Type
(E
))
12539 ((Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
12540 and then Nkind
(D
) = N_Object_Declaration
12541 and then Nkind
(Object_Definition
(D
)) =
12542 N_Constrained_Array_Definition
)
12544 -- The flag is set on the object, or on the base type
12546 if Nkind
(D
) /= N_Object_Declaration
then
12547 E
:= Base_Type
(E
);
12550 -- Atomic implies both Independent and Volatile
12552 if Prag_Id
= Pragma_Atomic_Components
then
12553 Set_Has_Atomic_Components
(E
);
12554 Set_Has_Independent_Components
(E
);
12557 Set_Has_Volatile_Components
(E
);
12560 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
12562 end Atomic_Components
;
12564 --------------------
12565 -- Attach_Handler --
12566 --------------------
12568 -- pragma Attach_Handler (handler_NAME, EXPRESSION);
12570 when Pragma_Attach_Handler
=>
12571 Check_Ada_83_Warning
;
12572 Check_No_Identifiers
;
12573 Check_Arg_Count
(2);
12575 if No_Run_Time_Mode
then
12576 Error_Msg_CRT
("Attach_Handler pragma", N
);
12578 Check_Interrupt_Or_Attach_Handler
;
12580 -- The expression that designates the attribute may depend on a
12581 -- discriminant, and is therefore a per-object expression, to
12582 -- be expanded in the init proc. If expansion is enabled, then
12583 -- perform semantic checks on a copy only.
12588 Parg2
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
12591 -- In Relaxed_RM_Semantics mode, we allow any static
12592 -- integer value, for compatibility with other compilers.
12594 if Relaxed_RM_Semantics
12595 and then Nkind
(Parg2
) = N_Integer_Literal
12597 Typ
:= Standard_Integer
;
12599 Typ
:= RTE
(RE_Interrupt_ID
);
12602 if Expander_Active
then
12603 Temp
:= New_Copy_Tree
(Parg2
);
12604 Set_Parent
(Temp
, N
);
12605 Preanalyze_And_Resolve
(Temp
, Typ
);
12608 Resolve
(Parg2
, Typ
);
12612 Process_Interrupt_Or_Attach_Handler
;
12615 --------------------
12616 -- C_Pass_By_Copy --
12617 --------------------
12619 -- pragma C_Pass_By_Copy ([Max_Size =>] static_integer_EXPRESSION);
12621 when Pragma_C_Pass_By_Copy
=> C_Pass_By_Copy
: declare
12627 Check_Valid_Configuration_Pragma
;
12628 Check_Arg_Count
(1);
12629 Check_Optional_Identifier
(Arg1
, "max_size");
12631 Arg
:= Get_Pragma_Arg
(Arg1
);
12632 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
12634 Val
:= Expr_Value
(Arg
);
12638 ("maximum size for pragma% must be positive", Arg1
);
12640 elsif UI_Is_In_Int_Range
(Val
) then
12641 Default_C_Record_Mechanism
:= UI_To_Int
(Val
);
12643 -- If a giant value is given, Int'Last will do well enough.
12644 -- If sometime someone complains that a record larger than
12645 -- two gigabytes is not copied, we will worry about it then.
12648 Default_C_Record_Mechanism
:= Mechanism_Type
'Last;
12650 end C_Pass_By_Copy
;
12656 -- pragma Check ([Name =>] CHECK_KIND,
12657 -- [Check =>] Boolean_EXPRESSION
12658 -- [,[Message =>] String_EXPRESSION]);
12660 -- CHECK_KIND ::= IDENTIFIER |
12663 -- Invariant'Class |
12664 -- Type_Invariant'Class
12666 -- The identifiers Assertions and Statement_Assertions are not
12667 -- allowed, since they have special meaning for Check_Policy.
12669 -- WARNING: The code below manages Ghost regions. Return statements
12670 -- must be replaced by gotos which jump to the end of the code and
12671 -- restore the Ghost mode.
12673 when Pragma_Check
=> Check
: declare
12674 Saved_GM
: constant Ghost_Mode_Type
:= Ghost_Mode
;
12675 -- Save the Ghost mode to restore on exit
12683 -- Pragma Check is Ghost when it applies to a Ghost entity. Set
12684 -- the mode now to ensure that any nodes generated during analysis
12685 -- and expansion are marked as Ghost.
12687 Set_Ghost_Mode
(N
);
12690 Check_At_Least_N_Arguments
(2);
12691 Check_At_Most_N_Arguments
(3);
12692 Check_Optional_Identifier
(Arg1
, Name_Name
);
12693 Check_Optional_Identifier
(Arg2
, Name_Check
);
12695 if Arg_Count
= 3 then
12696 Check_Optional_Identifier
(Arg3
, Name_Message
);
12697 Str
:= Get_Pragma_Arg
(Arg3
);
12700 Rewrite_Assertion_Kind
(Get_Pragma_Arg
(Arg1
));
12701 Check_Arg_Is_Identifier
(Arg1
);
12702 Cname
:= Chars
(Get_Pragma_Arg
(Arg1
));
12704 -- Check forbidden name Assertions or Statement_Assertions
12707 when Name_Assertions
=>
12709 ("""Assertions"" is not allowed as a check kind for "
12710 & "pragma%", Arg1
);
12712 when Name_Statement_Assertions
=>
12714 ("""Statement_Assertions"" is not allowed as a check kind "
12715 & "for pragma%", Arg1
);
12721 -- Check applicable policy. We skip this if Checked/Ignored status
12722 -- is already set (e.g. in the case of a pragma from an aspect).
12724 if Is_Checked
(N
) or else Is_Ignored
(N
) then
12727 -- For a non-source pragma that is a rewriting of another pragma,
12728 -- copy the Is_Checked/Ignored status from the rewritten pragma.
12730 elsif Is_Rewrite_Substitution
(N
)
12731 and then Nkind
(Original_Node
(N
)) = N_Pragma
12732 and then Original_Node
(N
) /= N
12734 Set_Is_Ignored
(N
, Is_Ignored
(Original_Node
(N
)));
12735 Set_Is_Checked
(N
, Is_Checked
(Original_Node
(N
)));
12737 -- Otherwise query the applicable policy at this point
12740 case Check_Kind
(Cname
) is
12741 when Name_Ignore
=>
12742 Set_Is_Ignored
(N
, True);
12743 Set_Is_Checked
(N
, False);
12746 Set_Is_Ignored
(N
, False);
12747 Set_Is_Checked
(N
, True);
12749 -- For disable, rewrite pragma as null statement and skip
12750 -- rest of the analysis of the pragma.
12752 when Name_Disable
=>
12753 Rewrite
(N
, Make_Null_Statement
(Loc
));
12757 -- No other possibilities
12760 raise Program_Error
;
12764 -- If check kind was not Disable, then continue pragma analysis
12766 Expr
:= Get_Pragma_Arg
(Arg2
);
12768 -- Deal with SCO generation
12770 if Is_Checked
(N
) and then not Split_PPC
(N
) then
12771 Set_SCO_Pragma_Enabled
(Loc
);
12774 -- Deal with analyzing the string argument
12776 if Arg_Count
= 3 then
12778 -- If checks are not on we don't want any expansion (since
12779 -- such expansion would not get properly deleted) but
12780 -- we do want to analyze (to get proper references).
12781 -- The Preanalyze_And_Resolve routine does just what we want
12783 if Is_Ignored
(N
) then
12784 Preanalyze_And_Resolve
(Str
, Standard_String
);
12786 -- Otherwise we need a proper analysis and expansion
12789 Analyze_And_Resolve
(Str
, Standard_String
);
12793 -- Now you might think we could just do the same with the Boolean
12794 -- expression if checks are off (and expansion is on) and then
12795 -- rewrite the check as a null statement. This would work but we
12796 -- would lose the useful warnings about an assertion being bound
12797 -- to fail even if assertions are turned off.
12799 -- So instead we wrap the boolean expression in an if statement
12800 -- that looks like:
12802 -- if False and then condition then
12806 -- The reason we do this rewriting during semantic analysis rather
12807 -- than as part of normal expansion is that we cannot analyze and
12808 -- expand the code for the boolean expression directly, or it may
12809 -- cause insertion of actions that would escape the attempt to
12810 -- suppress the check code.
12812 -- Note that the Sloc for the if statement corresponds to the
12813 -- argument condition, not the pragma itself. The reason for
12814 -- this is that we may generate a warning if the condition is
12815 -- False at compile time, and we do not want to delete this
12816 -- warning when we delete the if statement.
12818 if Expander_Active
and Is_Ignored
(N
) then
12819 Eloc
:= Sloc
(Expr
);
12822 Make_If_Statement
(Eloc
,
12824 Make_And_Then
(Eloc
,
12825 Left_Opnd
=> Make_Identifier
(Eloc
, Name_False
),
12826 Right_Opnd
=> Expr
),
12827 Then_Statements
=> New_List
(
12828 Make_Null_Statement
(Eloc
))));
12830 -- Now go ahead and analyze the if statement
12832 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12834 -- One rather special treatment. If we are now in Eliminated
12835 -- overflow mode, then suppress overflow checking since we do
12836 -- not want to drag in the bignum stuff if we are in Ignore
12837 -- mode anyway. This is particularly important if we are using
12838 -- a configurable run time that does not support bignum ops.
12840 if Scope_Suppress
.Overflow_Mode_Assertions
= Eliminated
then
12842 Svo
: constant Boolean :=
12843 Scope_Suppress
.Suppress
(Overflow_Check
);
12845 Scope_Suppress
.Overflow_Mode_Assertions
:= Strict
;
12846 Scope_Suppress
.Suppress
(Overflow_Check
) := True;
12848 Scope_Suppress
.Suppress
(Overflow_Check
) := Svo
;
12849 Scope_Suppress
.Overflow_Mode_Assertions
:= Eliminated
;
12852 -- Not that special case
12858 -- All done with this check
12860 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12862 -- Check is active or expansion not active. In these cases we can
12863 -- just go ahead and analyze the boolean with no worries.
12866 In_Assertion_Expr
:= In_Assertion_Expr
+ 1;
12867 Analyze_And_Resolve
(Expr
, Any_Boolean
);
12868 In_Assertion_Expr
:= In_Assertion_Expr
- 1;
12871 Restore_Ghost_Mode
(Saved_GM
);
12874 --------------------------
12875 -- Check_Float_Overflow --
12876 --------------------------
12878 -- pragma Check_Float_Overflow;
12880 when Pragma_Check_Float_Overflow
=>
12882 Check_Valid_Configuration_Pragma
;
12883 Check_Arg_Count
(0);
12884 Check_Float_Overflow
:= not Machine_Overflows_On_Target
;
12890 -- pragma Check_Name (check_IDENTIFIER);
12892 when Pragma_Check_Name
=>
12894 Check_No_Identifiers
;
12895 Check_Valid_Configuration_Pragma
;
12896 Check_Arg_Count
(1);
12897 Check_Arg_Is_Identifier
(Arg1
);
12900 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
12903 for J
in Check_Names
.First
.. Check_Names
.Last
loop
12904 if Check_Names
.Table
(J
) = Nam
then
12909 Check_Names
.Append
(Nam
);
12916 -- This is the old style syntax, which is still allowed in all modes:
12918 -- pragma Check_Policy ([Name =>] CHECK_KIND
12919 -- [Policy =>] POLICY_IDENTIFIER);
12921 -- POLICY_IDENTIFIER ::= On | Off | Check | Disable | Ignore
12923 -- CHECK_KIND ::= IDENTIFIER |
12926 -- Type_Invariant'Class |
12929 -- This is the new style syntax, compatible with Assertion_Policy
12930 -- and also allowed in all modes.
12932 -- Pragma Check_Policy (
12933 -- CHECK_KIND => POLICY_IDENTIFIER
12934 -- {, CHECK_KIND => POLICY_IDENTIFIER});
12936 -- Note: the identifiers Name and Policy are not allowed as
12937 -- Check_Kind values. This avoids ambiguities between the old and
12938 -- new form syntax.
12940 when Pragma_Check_Policy
=> Check_Policy
: declare
12945 Check_At_Least_N_Arguments
(1);
12947 -- A Check_Policy pragma can appear either as a configuration
12948 -- pragma, or in a declarative part or a package spec (see RM
12949 -- 11.5(5) for rules for Suppress/Unsuppress which are also
12950 -- followed for Check_Policy).
12952 if not Is_Configuration_Pragma
then
12953 Check_Is_In_Decl_Part_Or_Package_Spec
;
12956 -- Figure out if we have the old or new syntax. We have the
12957 -- old syntax if the first argument has no identifier, or the
12958 -- identifier is Name.
12960 if Nkind
(Arg1
) /= N_Pragma_Argument_Association
12961 or else Nam_In
(Chars
(Arg1
), No_Name
, Name_Name
)
12965 Check_Arg_Count
(2);
12966 Check_Optional_Identifier
(Arg1
, Name_Name
);
12967 Kind
:= Get_Pragma_Arg
(Arg1
);
12968 Rewrite_Assertion_Kind
(Kind
,
12969 From_Policy
=> Comes_From_Source
(N
));
12970 Check_Arg_Is_Identifier
(Arg1
);
12972 -- Check forbidden check kind
12974 if Nam_In
(Chars
(Kind
), Name_Name
, Name_Policy
) then
12975 Error_Msg_Name_2
:= Chars
(Kind
);
12977 ("pragma% does not allow% as check name", Arg1
);
12982 Check_Optional_Identifier
(Arg2
, Name_Policy
);
12983 Check_Arg_Is_One_Of
12985 Name_On
, Name_Off
, Name_Check
, Name_Disable
, Name_Ignore
);
12987 -- And chain pragma on the Check_Policy_List for search
12989 Set_Next_Pragma
(N
, Opt
.Check_Policy_List
);
12990 Opt
.Check_Policy_List
:= N
;
12992 -- For the new syntax, what we do is to convert each argument to
12993 -- an old syntax equivalent. We do that because we want to chain
12994 -- old style Check_Policy pragmas for the search (we don't want
12995 -- to have to deal with multiple arguments in the search).
13006 while Present
(Arg
) loop
13007 LocP
:= Sloc
(Arg
);
13008 Argx
:= Get_Pragma_Arg
(Arg
);
13010 -- Kind must be specified
13012 if Nkind
(Arg
) /= N_Pragma_Argument_Association
13013 or else Chars
(Arg
) = No_Name
13016 ("missing assertion kind for pragma%", Arg
);
13019 -- Construct equivalent old form syntax Check_Policy
13020 -- pragma and insert it to get remaining checks.
13024 Chars
=> Name_Check_Policy
,
13025 Pragma_Argument_Associations
=> New_List
(
13026 Make_Pragma_Argument_Association
(LocP
,
13028 Make_Identifier
(LocP
, Chars
(Arg
))),
13029 Make_Pragma_Argument_Association
(Sloc
(Argx
),
13030 Expression
=> Argx
)));
13034 -- For a configuration pragma, insert old form in
13035 -- the corresponding file.
13037 if Is_Configuration_Pragma
then
13038 Insert_After
(N
, New_P
);
13042 Insert_Action
(N
, New_P
);
13046 -- Rewrite original Check_Policy pragma to null, since we
13047 -- have converted it into a series of old syntax pragmas.
13049 Rewrite
(N
, Make_Null_Statement
(Loc
));
13059 -- pragma Comment (static_string_EXPRESSION)
13061 -- Processing for pragma Comment shares the circuitry for pragma
13062 -- Ident. The only differences are that Ident enforces a limit of 31
13063 -- characters on its argument, and also enforces limitations on
13064 -- placement for DEC compatibility. Pragma Comment shares neither of
13065 -- these restrictions.
13067 -------------------
13068 -- Common_Object --
13069 -------------------
13071 -- pragma Common_Object (
13072 -- [Internal =>] LOCAL_NAME
13073 -- [, [External =>] EXTERNAL_SYMBOL]
13074 -- [, [Size =>] EXTERNAL_SYMBOL]);
13076 -- Processing for this pragma is shared with Psect_Object
13078 ------------------------
13079 -- Compile_Time_Error --
13080 ------------------------
13082 -- pragma Compile_Time_Error
13083 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13085 when Pragma_Compile_Time_Error
=>
13087 Process_Compile_Time_Warning_Or_Error
;
13089 --------------------------
13090 -- Compile_Time_Warning --
13091 --------------------------
13093 -- pragma Compile_Time_Warning
13094 -- (boolean_EXPRESSION, static_string_EXPRESSION);
13096 when Pragma_Compile_Time_Warning
=>
13098 Process_Compile_Time_Warning_Or_Error
;
13100 ---------------------------
13101 -- Compiler_Unit_Warning --
13102 ---------------------------
13104 -- pragma Compiler_Unit_Warning;
13108 -- Originally, we had only pragma Compiler_Unit, and it resulted in
13109 -- errors not warnings. This means that we had introduced a big extra
13110 -- inertia to compiler changes, since even if we implemented a new
13111 -- feature, and even if all versions to be used for bootstrapping
13112 -- implemented this new feature, we could not use it, since old
13113 -- compilers would give errors for using this feature in units
13114 -- having Compiler_Unit pragmas.
13116 -- By changing Compiler_Unit to Compiler_Unit_Warning, we solve the
13117 -- problem. We no longer have any units mentioning Compiler_Unit,
13118 -- so old compilers see Compiler_Unit_Warning which is unrecognized,
13119 -- and thus generates a warning which can be ignored. So that deals
13120 -- with the problem of old compilers not implementing the newer form
13123 -- Newer compilers recognize the new pragma, but generate warning
13124 -- messages instead of errors, which again can be ignored in the
13125 -- case of an old compiler which implements a wanted new feature
13126 -- but at the time felt like warning about it for older compilers.
13128 -- We retain Compiler_Unit so that new compilers can be used to build
13129 -- older run-times that use this pragma. That's an unusual case, but
13130 -- it's easy enough to handle, so why not?
13132 when Pragma_Compiler_Unit
13133 | Pragma_Compiler_Unit_Warning
13136 Check_Arg_Count
(0);
13138 -- Only recognized in main unit
13140 if Current_Sem_Unit
= Main_Unit
then
13141 Compiler_Unit
:= True;
13144 -----------------------------
13145 -- Complete_Representation --
13146 -----------------------------
13148 -- pragma Complete_Representation;
13150 when Pragma_Complete_Representation
=>
13152 Check_Arg_Count
(0);
13154 if Nkind
(Parent
(N
)) /= N_Record_Representation_Clause
then
13156 ("pragma & must appear within record representation clause");
13159 ----------------------------
13160 -- Complex_Representation --
13161 ----------------------------
13163 -- pragma Complex_Representation ([Entity =>] LOCAL_NAME);
13165 when Pragma_Complex_Representation
=> Complex_Representation
: declare
13172 Check_Arg_Count
(1);
13173 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13174 Check_Arg_Is_Local_Name
(Arg1
);
13175 E_Id
:= Get_Pragma_Arg
(Arg1
);
13177 if Etype
(E_Id
) = Any_Type
then
13181 E
:= Entity
(E_Id
);
13183 if not Is_Record_Type
(E
) then
13185 ("argument for pragma% must be record type", Arg1
);
13188 Ent
:= First_Entity
(E
);
13191 or else No
(Next_Entity
(Ent
))
13192 or else Present
(Next_Entity
(Next_Entity
(Ent
)))
13193 or else not Is_Floating_Point_Type
(Etype
(Ent
))
13194 or else Etype
(Ent
) /= Etype
(Next_Entity
(Ent
))
13197 ("record for pragma% must have two fields of the same "
13198 & "floating-point type", Arg1
);
13201 Set_Has_Complex_Representation
(Base_Type
(E
));
13203 -- We need to treat the type has having a non-standard
13204 -- representation, for back-end purposes, even though in
13205 -- general a complex will have the default representation
13206 -- of a record with two real components.
13208 Set_Has_Non_Standard_Rep
(Base_Type
(E
));
13210 end Complex_Representation
;
13212 -------------------------
13213 -- Component_Alignment --
13214 -------------------------
13216 -- pragma Component_Alignment (
13217 -- [Form =>] ALIGNMENT_CHOICE
13218 -- [, [Name =>] type_LOCAL_NAME]);
13220 -- ALIGNMENT_CHOICE ::=
13222 -- | Component_Size_4
13226 when Pragma_Component_Alignment
=> Component_AlignmentP
: declare
13227 Args
: Args_List
(1 .. 2);
13228 Names
: constant Name_List
(1 .. 2) := (
13232 Form
: Node_Id
renames Args
(1);
13233 Name
: Node_Id
renames Args
(2);
13235 Atype
: Component_Alignment_Kind
;
13240 Gather_Associations
(Names
, Args
);
13243 Error_Pragma
("missing Form argument for pragma%");
13246 Check_Arg_Is_Identifier
(Form
);
13248 -- Get proper alignment, note that Default = Component_Size on all
13249 -- machines we have so far, and we want to set this value rather
13250 -- than the default value to indicate that it has been explicitly
13251 -- set (and thus will not get overridden by the default component
13252 -- alignment for the current scope)
13254 if Chars
(Form
) = Name_Component_Size
then
13255 Atype
:= Calign_Component_Size
;
13257 elsif Chars
(Form
) = Name_Component_Size_4
then
13258 Atype
:= Calign_Component_Size_4
;
13260 elsif Chars
(Form
) = Name_Default
then
13261 Atype
:= Calign_Component_Size
;
13263 elsif Chars
(Form
) = Name_Storage_Unit
then
13264 Atype
:= Calign_Storage_Unit
;
13268 ("invalid Form parameter for pragma%", Form
);
13271 -- The pragma appears in a configuration file
13273 if No
(Parent
(N
)) then
13274 Check_Valid_Configuration_Pragma
;
13276 -- Capture the component alignment in a global variable when
13277 -- the pragma appears in a configuration file. Note that the
13278 -- scope stack is empty at this point and cannot be used to
13279 -- store the alignment value.
13281 Configuration_Component_Alignment
:= Atype
;
13283 -- Case with no name, supplied, affects scope table entry
13285 elsif No
(Name
) then
13287 (Scope_Stack
.Last
).Component_Alignment_Default
:= Atype
;
13289 -- Case of name supplied
13292 Check_Arg_Is_Local_Name
(Name
);
13294 Typ
:= Entity
(Name
);
13297 or else Rep_Item_Too_Early
(Typ
, N
)
13301 Typ
:= Underlying_Type
(Typ
);
13304 if not Is_Record_Type
(Typ
)
13305 and then not Is_Array_Type
(Typ
)
13308 ("Name parameter of pragma% must identify record or "
13309 & "array type", Name
);
13312 -- An explicit Component_Alignment pragma overrides an
13313 -- implicit pragma Pack, but not an explicit one.
13315 if not Has_Pragma_Pack
(Base_Type
(Typ
)) then
13316 Set_Is_Packed
(Base_Type
(Typ
), False);
13317 Set_Component_Alignment
(Base_Type
(Typ
), Atype
);
13320 end Component_AlignmentP
;
13322 --------------------------------
13323 -- Constant_After_Elaboration --
13324 --------------------------------
13326 -- pragma Constant_After_Elaboration [ (boolean_EXPRESSION) ];
13328 when Pragma_Constant_After_Elaboration
=> Constant_After_Elaboration
:
13330 Obj_Decl
: Node_Id
;
13331 Obj_Id
: Entity_Id
;
13335 Check_No_Identifiers
;
13336 Check_At_Most_N_Arguments
(1);
13338 Obj_Decl
:= Find_Related_Context
(N
, Do_Checks
=> True);
13340 -- Object declaration
13342 if Nkind
(Obj_Decl
) = N_Object_Declaration
then
13345 -- Otherwise the pragma is associated with an illegal construct
13352 Obj_Id
:= Defining_Entity
(Obj_Decl
);
13354 -- The object declaration must be a library-level variable which
13355 -- is either explicitly initialized or obtains a value during the
13356 -- elaboration of a package body (SPARK RM 3.3.1).
13358 if Ekind
(Obj_Id
) = E_Variable
then
13359 if not Is_Library_Level_Entity
(Obj_Id
) then
13361 ("pragma % must apply to a library level variable");
13365 -- Otherwise the pragma applies to a constant, which is illegal
13368 Error_Pragma
("pragma % must apply to a variable declaration");
13372 -- A pragma that applies to a Ghost entity becomes Ghost for the
13373 -- purposes of legality checks and removal of ignored Ghost code.
13375 Mark_Ghost_Pragma
(N
, Obj_Id
);
13377 -- Chain the pragma on the contract for completeness
13379 Add_Contract_Item
(N
, Obj_Id
);
13381 -- Analyze the Boolean expression (if any)
13383 if Present
(Arg1
) then
13384 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
13386 end Constant_After_Elaboration
;
13388 --------------------
13389 -- Contract_Cases --
13390 --------------------
13392 -- pragma Contract_Cases ((CONTRACT_CASE {, CONTRACT_CASE));
13394 -- CONTRACT_CASE ::= CASE_GUARD => CONSEQUENCE
13396 -- CASE_GUARD ::= boolean_EXPRESSION | others
13398 -- CONSEQUENCE ::= boolean_EXPRESSION
13400 -- Characteristics:
13402 -- * Analysis - The annotation undergoes initial checks to verify
13403 -- the legal placement and context. Secondary checks preanalyze the
13406 -- Analyze_Contract_Cases_In_Decl_Part
13408 -- * Expansion - The annotation is expanded during the expansion of
13409 -- the related subprogram [body] contract as performed in:
13411 -- Expand_Subprogram_Contract
13413 -- * Template - The annotation utilizes the generic template of the
13414 -- related subprogram [body] when it is:
13416 -- aspect on subprogram declaration
13417 -- aspect on stand alone subprogram body
13418 -- pragma on stand alone subprogram body
13420 -- The annotation must prepare its own template when it is:
13422 -- pragma on subprogram declaration
13424 -- * Globals - Capture of global references must occur after full
13427 -- * Instance - The annotation is instantiated automatically when
13428 -- the related generic subprogram [body] is instantiated except for
13429 -- the "pragma on subprogram declaration" case. In that scenario
13430 -- the annotation must instantiate itself.
13432 when Pragma_Contract_Cases
=> Contract_Cases
: declare
13433 Spec_Id
: Entity_Id
;
13434 Subp_Decl
: Node_Id
;
13438 Check_No_Identifiers
;
13439 Check_Arg_Count
(1);
13441 -- Ensure the proper placement of the pragma. Contract_Cases must
13442 -- be associated with a subprogram declaration or a body that acts
13446 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
13450 if Nkind
(Subp_Decl
) = N_Entry_Declaration
then
13453 -- Generic subprogram
13455 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
13458 -- Body acts as spec
13460 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
13461 and then No
(Corresponding_Spec
(Subp_Decl
))
13465 -- Body stub acts as spec
13467 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
13468 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
13474 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
13482 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
13484 -- A pragma that applies to a Ghost entity becomes Ghost for the
13485 -- purposes of legality checks and removal of ignored Ghost code.
13487 Mark_Ghost_Pragma
(N
, Spec_Id
);
13488 Ensure_Aggregate_Form
(Get_Argument
(N
, Spec_Id
));
13490 -- Chain the pragma on the contract for further processing by
13491 -- Analyze_Contract_Cases_In_Decl_Part.
13493 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
13495 -- Fully analyze the pragma when it appears inside an entry
13496 -- or subprogram body because it cannot benefit from forward
13499 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
13501 N_Subprogram_Body_Stub
)
13503 -- The legality checks of pragma Contract_Cases are affected by
13504 -- the SPARK mode in effect and the volatility of the context.
13505 -- Analyze all pragmas in a specific order.
13507 Analyze_If_Present
(Pragma_SPARK_Mode
);
13508 Analyze_If_Present
(Pragma_Volatile_Function
);
13509 Analyze_Contract_Cases_In_Decl_Part
(N
);
13511 end Contract_Cases
;
13517 -- pragma Controlled (first_subtype_LOCAL_NAME);
13519 when Pragma_Controlled
=> Controlled
: declare
13523 Check_No_Identifiers
;
13524 Check_Arg_Count
(1);
13525 Check_Arg_Is_Local_Name
(Arg1
);
13526 Arg
:= Get_Pragma_Arg
(Arg1
);
13528 if not Is_Entity_Name
(Arg
)
13529 or else not Is_Access_Type
(Entity
(Arg
))
13531 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
13533 Set_Has_Pragma_Controlled
(Base_Type
(Entity
(Arg
)));
13541 -- pragma Convention ([Convention =>] convention_IDENTIFIER,
13542 -- [Entity =>] LOCAL_NAME);
13544 when Pragma_Convention
=> Convention
: declare
13547 pragma Warnings
(Off
, C
);
13548 pragma Warnings
(Off
, E
);
13551 Check_Arg_Order
((Name_Convention
, Name_Entity
));
13552 Check_Ada_83_Warning
;
13553 Check_Arg_Count
(2);
13554 Process_Convention
(C
, E
);
13556 -- A pragma that applies to a Ghost entity becomes Ghost for the
13557 -- purposes of legality checks and removal of ignored Ghost code.
13559 Mark_Ghost_Pragma
(N
, E
);
13562 ---------------------------
13563 -- Convention_Identifier --
13564 ---------------------------
13566 -- pragma Convention_Identifier ([Name =>] IDENTIFIER,
13567 -- [Convention =>] convention_IDENTIFIER);
13569 when Pragma_Convention_Identifier
=> Convention_Identifier
: declare
13575 Check_Arg_Order
((Name_Name
, Name_Convention
));
13576 Check_Arg_Count
(2);
13577 Check_Optional_Identifier
(Arg1
, Name_Name
);
13578 Check_Optional_Identifier
(Arg2
, Name_Convention
);
13579 Check_Arg_Is_Identifier
(Arg1
);
13580 Check_Arg_Is_Identifier
(Arg2
);
13581 Idnam
:= Chars
(Get_Pragma_Arg
(Arg1
));
13582 Cname
:= Chars
(Get_Pragma_Arg
(Arg2
));
13584 if Is_Convention_Name
(Cname
) then
13585 Record_Convention_Identifier
13586 (Idnam
, Get_Convention_Id
(Cname
));
13589 ("second arg for % pragma must be convention", Arg2
);
13591 end Convention_Identifier
;
13597 -- pragma CPP_Class ([Entity =>] LOCAL_NAME)
13599 when Pragma_CPP_Class
=>
13602 if Warn_On_Obsolescent_Feature
then
13604 ("'G'N'A'T pragma cpp'_class is now obsolete and has no "
13605 & "effect; replace it by pragma import?j?", N
);
13608 Check_Arg_Count
(1);
13612 Chars
=> Name_Import
,
13613 Pragma_Argument_Associations
=> New_List
(
13614 Make_Pragma_Argument_Association
(Loc
,
13615 Expression
=> Make_Identifier
(Loc
, Name_CPP
)),
13616 New_Copy
(First
(Pragma_Argument_Associations
(N
))))));
13619 ---------------------
13620 -- CPP_Constructor --
13621 ---------------------
13623 -- pragma CPP_Constructor ([Entity =>] LOCAL_NAME
13624 -- [, [External_Name =>] static_string_EXPRESSION ]
13625 -- [, [Link_Name =>] static_string_EXPRESSION ]);
13627 when Pragma_CPP_Constructor
=> CPP_Constructor
: declare
13630 Def_Id
: Entity_Id
;
13631 Tag_Typ
: Entity_Id
;
13635 Check_At_Least_N_Arguments
(1);
13636 Check_At_Most_N_Arguments
(3);
13637 Check_Optional_Identifier
(Arg1
, Name_Entity
);
13638 Check_Arg_Is_Local_Name
(Arg1
);
13640 Id
:= Get_Pragma_Arg
(Arg1
);
13641 Find_Program_Unit_Name
(Id
);
13643 -- If we did not find the name, we are done
13645 if Etype
(Id
) = Any_Type
then
13649 Def_Id
:= Entity
(Id
);
13651 -- Check if already defined as constructor
13653 if Is_Constructor
(Def_Id
) then
13655 ("??duplicate argument for pragma 'C'P'P_Constructor", Arg1
);
13659 if Ekind
(Def_Id
) = E_Function
13660 and then (Is_CPP_Class
(Etype
(Def_Id
))
13661 or else (Is_Class_Wide_Type
(Etype
(Def_Id
))
13663 Is_CPP_Class
(Root_Type
(Etype
(Def_Id
)))))
13665 if Scope
(Def_Id
) /= Scope
(Etype
(Def_Id
)) then
13667 ("'C'P'P constructor must be defined in the scope of "
13668 & "its returned type", Arg1
);
13671 if Arg_Count
>= 2 then
13672 Set_Imported
(Def_Id
);
13673 Set_Is_Public
(Def_Id
);
13674 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
13677 Set_Has_Completion
(Def_Id
);
13678 Set_Is_Constructor
(Def_Id
);
13679 Set_Convention
(Def_Id
, Convention_CPP
);
13681 -- Imported C++ constructors are not dispatching primitives
13682 -- because in C++ they don't have a dispatch table slot.
13683 -- However, in Ada the constructor has the profile of a
13684 -- function that returns a tagged type and therefore it has
13685 -- been treated as a primitive operation during semantic
13686 -- analysis. We now remove it from the list of primitive
13687 -- operations of the type.
13689 if Is_Tagged_Type
(Etype
(Def_Id
))
13690 and then not Is_Class_Wide_Type
(Etype
(Def_Id
))
13691 and then Is_Dispatching_Operation
(Def_Id
)
13693 Tag_Typ
:= Etype
(Def_Id
);
13695 Elmt
:= First_Elmt
(Primitive_Operations
(Tag_Typ
));
13696 while Present
(Elmt
) and then Node
(Elmt
) /= Def_Id
loop
13700 Remove_Elmt
(Primitive_Operations
(Tag_Typ
), Elmt
);
13701 Set_Is_Dispatching_Operation
(Def_Id
, False);
13704 -- For backward compatibility, if the constructor returns a
13705 -- class wide type, and we internally change the return type to
13706 -- the corresponding root type.
13708 if Is_Class_Wide_Type
(Etype
(Def_Id
)) then
13709 Set_Etype
(Def_Id
, Root_Type
(Etype
(Def_Id
)));
13713 ("pragma% requires function returning a 'C'P'P_Class type",
13716 end CPP_Constructor
;
13722 when Pragma_CPP_Virtual
=>
13725 if Warn_On_Obsolescent_Feature
then
13727 ("'G'N'A'T pragma Cpp'_Virtual is now obsolete and has no "
13735 when Pragma_CPP_Vtable
=>
13738 if Warn_On_Obsolescent_Feature
then
13740 ("'G'N'A'T pragma Cpp'_Vtable is now obsolete and has no "
13748 -- pragma CPU (EXPRESSION);
13750 when Pragma_CPU
=> CPU
: declare
13751 P
: constant Node_Id
:= Parent
(N
);
13757 Check_No_Identifiers
;
13758 Check_Arg_Count
(1);
13762 if Nkind
(P
) = N_Subprogram_Body
then
13763 Check_In_Main_Program
;
13765 Arg
:= Get_Pragma_Arg
(Arg1
);
13766 Analyze_And_Resolve
(Arg
, Any_Integer
);
13768 Ent
:= Defining_Unit_Name
(Specification
(P
));
13770 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
13771 Ent
:= Defining_Identifier
(Ent
);
13776 if not Is_OK_Static_Expression
(Arg
) then
13777 Flag_Non_Static_Expr
13778 ("main subprogram affinity is not static!", Arg
);
13781 -- If constraint error, then we already signalled an error
13783 elsif Raises_Constraint_Error
(Arg
) then
13786 -- Otherwise check in range
13790 CPU_Id
: constant Entity_Id
:= RTE
(RE_CPU_Range
);
13791 -- This is the entity System.Multiprocessors.CPU_Range;
13793 Val
: constant Uint
:= Expr_Value
(Arg
);
13796 if Val
< Expr_Value
(Type_Low_Bound
(CPU_Id
))
13798 Val
> Expr_Value
(Type_High_Bound
(CPU_Id
))
13801 ("main subprogram CPU is out of range", Arg1
);
13807 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
13811 elsif Nkind
(P
) = N_Task_Definition
then
13812 Arg
:= Get_Pragma_Arg
(Arg1
);
13813 Ent
:= Defining_Identifier
(Parent
(P
));
13815 -- The expression must be analyzed in the special manner
13816 -- described in "Handling of Default and Per-Object
13817 -- Expressions" in sem.ads.
13819 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_CPU_Range
));
13821 -- Anything else is incorrect
13827 -- Check duplicate pragma before we chain the pragma in the Rep
13828 -- Item chain of Ent.
13830 Check_Duplicate_Pragma
(Ent
);
13831 Record_Rep_Item
(Ent
, N
);
13834 --------------------
13835 -- Deadline_Floor --
13836 --------------------
13838 -- pragma Deadline_Floor (time_span_EXPRESSION);
13840 when Pragma_Deadline_Floor
=> Deadline_Floor
: declare
13841 P
: constant Node_Id
:= Parent
(N
);
13847 Check_No_Identifiers
;
13848 Check_Arg_Count
(1);
13850 Arg
:= Get_Pragma_Arg
(Arg1
);
13852 -- The expression must be analyzed in the special manner described
13853 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
13855 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
13857 -- Only protected types allowed
13859 if Nkind
(P
) /= N_Protected_Definition
then
13863 Ent
:= Defining_Identifier
(Parent
(P
));
13865 -- Check duplicate pragma before we chain the pragma in the Rep
13866 -- Item chain of Ent.
13868 Check_Duplicate_Pragma
(Ent
);
13869 Record_Rep_Item
(Ent
, N
);
13871 end Deadline_Floor
;
13877 -- pragma Debug ([boolean_EXPRESSION,] PROCEDURE_CALL_STATEMENT);
13879 when Pragma_Debug
=> Debug
: declare
13886 -- The condition for executing the call is that the expander
13887 -- is active and that we are not ignoring this debug pragma.
13892 (Expander_Active
and then not Is_Ignored
(N
)),
13895 if not Is_Ignored
(N
) then
13896 Set_SCO_Pragma_Enabled
(Loc
);
13899 if Arg_Count
= 2 then
13901 Make_And_Then
(Loc
,
13902 Left_Opnd
=> Relocate_Node
(Cond
),
13903 Right_Opnd
=> Get_Pragma_Arg
(Arg1
));
13904 Call
:= Get_Pragma_Arg
(Arg2
);
13906 Call
:= Get_Pragma_Arg
(Arg1
);
13910 N_Indexed_Component
,
13914 N_Selected_Component
)
13916 -- If this pragma Debug comes from source, its argument was
13917 -- parsed as a name form (which is syntactically identical).
13918 -- In a generic context a parameterless call will be left as
13919 -- an expanded name (if global) or selected_component if local.
13920 -- Change it to a procedure call statement now.
13922 Change_Name_To_Procedure_Call_Statement
(Call
);
13924 elsif Nkind
(Call
) = N_Procedure_Call_Statement
then
13926 -- Already in the form of a procedure call statement: nothing
13927 -- to do (could happen in case of an internally generated
13933 -- All other cases: diagnose error
13936 ("argument of pragma ""Debug"" is not procedure call",
13941 -- Rewrite into a conditional with an appropriate condition. We
13942 -- wrap the procedure call in a block so that overhead from e.g.
13943 -- use of the secondary stack does not generate execution overhead
13944 -- for suppressed conditions.
13946 -- Normally the analysis that follows will freeze the subprogram
13947 -- being called. However, if the call is to a null procedure,
13948 -- we want to freeze it before creating the block, because the
13949 -- analysis that follows may be done with expansion disabled, in
13950 -- which case the body will not be generated, leading to spurious
13953 if Nkind
(Call
) = N_Procedure_Call_Statement
13954 and then Is_Entity_Name
(Name
(Call
))
13956 Analyze
(Name
(Call
));
13957 Freeze_Before
(N
, Entity
(Name
(Call
)));
13961 Make_Implicit_If_Statement
(N
,
13963 Then_Statements
=> New_List
(
13964 Make_Block_Statement
(Loc
,
13965 Handled_Statement_Sequence
=>
13966 Make_Handled_Sequence_Of_Statements
(Loc
,
13967 Statements
=> New_List
(Relocate_Node
(Call
)))))));
13970 -- Ignore pragma Debug in GNATprove mode. Do this rewriting
13971 -- after analysis of the normally rewritten node, to capture all
13972 -- references to entities, which avoids issuing wrong warnings
13973 -- about unused entities.
13975 if GNATprove_Mode
then
13976 Rewrite
(N
, Make_Null_Statement
(Loc
));
13984 -- pragma Debug_Policy (On | Off | Check | Disable | Ignore)
13986 when Pragma_Debug_Policy
=>
13988 Check_Arg_Count
(1);
13989 Check_No_Identifiers
;
13990 Check_Arg_Is_Identifier
(Arg1
);
13992 -- Exactly equivalent to pragma Check_Policy (Debug, arg), so
13993 -- rewrite it that way, and let the rest of the checking come
13994 -- from analyzing the rewritten pragma.
13998 Chars
=> Name_Check_Policy
,
13999 Pragma_Argument_Associations
=> New_List
(
14000 Make_Pragma_Argument_Association
(Loc
,
14001 Expression
=> Make_Identifier
(Loc
, Name_Debug
)),
14003 Make_Pragma_Argument_Association
(Loc
,
14004 Expression
=> Get_Pragma_Arg
(Arg1
)))));
14007 -------------------------------
14008 -- Default_Initial_Condition --
14009 -------------------------------
14011 -- pragma Default_Initial_Condition [ (null | boolean_EXPRESSION) ];
14013 when Pragma_Default_Initial_Condition
=> DIC
: declare
14020 Check_No_Identifiers
;
14021 Check_At_Most_N_Arguments
(1);
14025 while Present
(Stmt
) loop
14027 -- Skip prior pragmas, but check for duplicates
14029 if Nkind
(Stmt
) = N_Pragma
then
14030 if Pragma_Name
(Stmt
) = Pname
then
14037 -- Skip internally generated code. Note that derived type
14038 -- declarations of untagged types with discriminants are
14039 -- rewritten as private type declarations.
14041 elsif not Comes_From_Source
(Stmt
)
14042 and then Nkind
(Stmt
) /= N_Private_Type_Declaration
14046 -- The associated private type [extension] has been found, stop
14049 elsif Nkind_In
(Stmt
, N_Private_Extension_Declaration
,
14050 N_Private_Type_Declaration
)
14052 Typ
:= Defining_Entity
(Stmt
);
14055 -- The pragma does not apply to a legal construct, issue an
14056 -- error and stop the analysis.
14063 Stmt
:= Prev
(Stmt
);
14066 -- The pragma does not apply to a legal construct, issue an error
14067 -- and stop the analysis.
14074 -- A pragma that applies to a Ghost entity becomes Ghost for the
14075 -- purposes of legality checks and removal of ignored Ghost code.
14077 Mark_Ghost_Pragma
(N
, Typ
);
14079 -- The pragma signals that the type defines its own DIC assertion
14082 Set_Has_Own_DIC
(Typ
);
14084 -- Chain the pragma on the rep item chain for further processing
14086 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
14088 -- Create the declaration of the procedure which verifies the
14089 -- assertion expression of pragma DIC at runtime.
14091 Build_DIC_Procedure_Declaration
(Typ
);
14094 ----------------------------------
14095 -- Default_Scalar_Storage_Order --
14096 ----------------------------------
14098 -- pragma Default_Scalar_Storage_Order
14099 -- (High_Order_First | Low_Order_First);
14101 when Pragma_Default_Scalar_Storage_Order
=> DSSO
: declare
14102 Default
: Character;
14106 Check_Arg_Count
(1);
14108 -- Default_Scalar_Storage_Order can appear as a configuration
14109 -- pragma, or in a declarative part of a package spec.
14111 if not Is_Configuration_Pragma
then
14112 Check_Is_In_Decl_Part_Or_Package_Spec
;
14115 Check_No_Identifiers
;
14116 Check_Arg_Is_One_Of
14117 (Arg1
, Name_High_Order_First
, Name_Low_Order_First
);
14118 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
14119 Default
:= Fold_Upper
(Name_Buffer
(1));
14121 if not Support_Nondefault_SSO_On_Target
14122 and then (Ttypes
.Bytes_Big_Endian
/= (Default
= 'H'))
14124 if Warn_On_Unrecognized_Pragma
then
14126 ("non-default Scalar_Storage_Order not supported "
14127 & "on target?g?", N
);
14129 ("\pragma Default_Scalar_Storage_Order ignored?g?", N
);
14132 -- Here set the specified default
14135 Opt
.Default_SSO
:= Default
;
14139 --------------------------
14140 -- Default_Storage_Pool --
14141 --------------------------
14143 -- pragma Default_Storage_Pool (storage_pool_NAME | null);
14145 when Pragma_Default_Storage_Pool
=> Default_Storage_Pool
: declare
14150 Check_Arg_Count
(1);
14152 -- Default_Storage_Pool can appear as a configuration pragma, or
14153 -- in a declarative part of a package spec.
14155 if not Is_Configuration_Pragma
then
14156 Check_Is_In_Decl_Part_Or_Package_Spec
;
14159 if From_Aspect_Specification
(N
) then
14161 E
: constant Entity_Id
:= Entity
(Corresponding_Aspect
(N
));
14163 if not In_Open_Scopes
(E
) then
14165 ("aspect must apply to package or subprogram", N
);
14170 if Present
(Arg1
) then
14171 Pool
:= Get_Pragma_Arg
(Arg1
);
14173 -- Case of Default_Storage_Pool (null);
14175 if Nkind
(Pool
) = N_Null
then
14178 -- This is an odd case, this is not really an expression,
14179 -- so we don't have a type for it. So just set the type to
14182 Set_Etype
(Pool
, Empty
);
14184 -- Case of Default_Storage_Pool (storage_pool_NAME);
14187 -- If it's a configuration pragma, then the only allowed
14188 -- argument is "null".
14190 if Is_Configuration_Pragma
then
14191 Error_Pragma_Arg
("NULL expected", Arg1
);
14194 -- The expected type for a non-"null" argument is
14195 -- Root_Storage_Pool'Class, and the pool must be a variable.
14197 Analyze_And_Resolve
14198 (Pool
, Class_Wide_Type
(RTE
(RE_Root_Storage_Pool
)));
14200 if Is_Variable
(Pool
) then
14202 -- A pragma that applies to a Ghost entity becomes Ghost
14203 -- for the purposes of legality checks and removal of
14204 -- ignored Ghost code.
14206 Mark_Ghost_Pragma
(N
, Entity
(Pool
));
14210 ("default storage pool must be a variable", Arg1
);
14214 -- Record the pool name (or null). Freeze.Freeze_Entity for an
14215 -- access type will use this information to set the appropriate
14216 -- attributes of the access type.
14218 Default_Pool
:= Pool
;
14220 end Default_Storage_Pool
;
14226 -- pragma Depends (DEPENDENCY_RELATION);
14228 -- DEPENDENCY_RELATION ::=
14230 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
14232 -- DEPENDENCY_CLAUSE ::=
14233 -- OUTPUT_LIST =>[+] INPUT_LIST
14234 -- | NULL_DEPENDENCY_CLAUSE
14236 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
14238 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
14240 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
14242 -- OUTPUT ::= NAME | FUNCTION_RESULT
14245 -- where FUNCTION_RESULT is a function Result attribute_reference
14247 -- Characteristics:
14249 -- * Analysis - The annotation undergoes initial checks to verify
14250 -- the legal placement and context. Secondary checks fully analyze
14251 -- the dependency clauses in:
14253 -- Analyze_Depends_In_Decl_Part
14255 -- * Expansion - None.
14257 -- * Template - The annotation utilizes the generic template of the
14258 -- related subprogram [body] when it is:
14260 -- aspect on subprogram declaration
14261 -- aspect on stand alone subprogram body
14262 -- pragma on stand alone subprogram body
14264 -- The annotation must prepare its own template when it is:
14266 -- pragma on subprogram declaration
14268 -- * Globals - Capture of global references must occur after full
14271 -- * Instance - The annotation is instantiated automatically when
14272 -- the related generic subprogram [body] is instantiated except for
14273 -- the "pragma on subprogram declaration" case. In that scenario
14274 -- the annotation must instantiate itself.
14276 when Pragma_Depends
=> Depends
: declare
14278 Spec_Id
: Entity_Id
;
14279 Subp_Decl
: Node_Id
;
14282 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
14286 -- Chain the pragma on the contract for further processing by
14287 -- Analyze_Depends_In_Decl_Part.
14289 Add_Contract_Item
(N
, Spec_Id
);
14291 -- Fully analyze the pragma when it appears inside an entry
14292 -- or subprogram body because it cannot benefit from forward
14295 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
14297 N_Subprogram_Body_Stub
)
14299 -- The legality checks of pragmas Depends and Global are
14300 -- affected by the SPARK mode in effect and the volatility
14301 -- of the context. In addition these two pragmas are subject
14302 -- to an inherent order:
14307 -- Analyze all these pragmas in the order outlined above
14309 Analyze_If_Present
(Pragma_SPARK_Mode
);
14310 Analyze_If_Present
(Pragma_Volatile_Function
);
14311 Analyze_If_Present
(Pragma_Global
);
14312 Analyze_Depends_In_Decl_Part
(N
);
14317 ---------------------
14318 -- Detect_Blocking --
14319 ---------------------
14321 -- pragma Detect_Blocking;
14323 when Pragma_Detect_Blocking
=>
14325 Check_Arg_Count
(0);
14326 Check_Valid_Configuration_Pragma
;
14327 Detect_Blocking
:= True;
14329 ------------------------------------
14330 -- Disable_Atomic_Synchronization --
14331 ------------------------------------
14333 -- pragma Disable_Atomic_Synchronization [(Entity)];
14335 when Pragma_Disable_Atomic_Synchronization
=>
14337 Process_Disable_Enable_Atomic_Sync
(Name_Suppress
);
14339 -------------------
14340 -- Discard_Names --
14341 -------------------
14343 -- pragma Discard_Names [([On =>] LOCAL_NAME)];
14345 when Pragma_Discard_Names
=> Discard_Names
: declare
14350 Check_Ada_83_Warning
;
14352 -- Deal with configuration pragma case
14354 if Arg_Count
= 0 and then Is_Configuration_Pragma
then
14355 Global_Discard_Names
:= True;
14358 -- Otherwise, check correct appropriate context
14361 Check_Is_In_Decl_Part_Or_Package_Spec
;
14363 if Arg_Count
= 0 then
14365 -- If there is no parameter, then from now on this pragma
14366 -- applies to any enumeration, exception or tagged type
14367 -- defined in the current declarative part, and recursively
14368 -- to any nested scope.
14370 Set_Discard_Names
(Current_Scope
);
14374 Check_Arg_Count
(1);
14375 Check_Optional_Identifier
(Arg1
, Name_On
);
14376 Check_Arg_Is_Local_Name
(Arg1
);
14378 E_Id
:= Get_Pragma_Arg
(Arg1
);
14380 if Etype
(E_Id
) = Any_Type
then
14383 E
:= Entity
(E_Id
);
14386 -- A pragma that applies to a Ghost entity becomes Ghost for
14387 -- the purposes of legality checks and removal of ignored
14390 Mark_Ghost_Pragma
(N
, E
);
14392 if (Is_First_Subtype
(E
)
14394 (Is_Enumeration_Type
(E
) or else Is_Tagged_Type
(E
)))
14395 or else Ekind
(E
) = E_Exception
14397 Set_Discard_Names
(E
);
14398 Record_Rep_Item
(E
, N
);
14402 ("inappropriate entity for pragma%", Arg1
);
14408 ------------------------
14409 -- Dispatching_Domain --
14410 ------------------------
14412 -- pragma Dispatching_Domain (EXPRESSION);
14414 when Pragma_Dispatching_Domain
=> Dispatching_Domain
: declare
14415 P
: constant Node_Id
:= Parent
(N
);
14421 Check_No_Identifiers
;
14422 Check_Arg_Count
(1);
14424 -- This pragma is born obsolete, but not the aspect
14426 if not From_Aspect_Specification
(N
) then
14428 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
14431 if Nkind
(P
) = N_Task_Definition
then
14432 Arg
:= Get_Pragma_Arg
(Arg1
);
14433 Ent
:= Defining_Identifier
(Parent
(P
));
14435 -- A pragma that applies to a Ghost entity becomes Ghost for
14436 -- the purposes of legality checks and removal of ignored Ghost
14439 Mark_Ghost_Pragma
(N
, Ent
);
14441 -- The expression must be analyzed in the special manner
14442 -- described in "Handling of Default and Per-Object
14443 -- Expressions" in sem.ads.
14445 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Dispatching_Domain
));
14447 -- Check duplicate pragma before we chain the pragma in the Rep
14448 -- Item chain of Ent.
14450 Check_Duplicate_Pragma
(Ent
);
14451 Record_Rep_Item
(Ent
, N
);
14453 -- Anything else is incorrect
14458 end Dispatching_Domain
;
14464 -- pragma Elaborate (library_unit_NAME {, library_unit_NAME});
14466 when Pragma_Elaborate
=> Elaborate
: declare
14471 -- Pragma must be in context items list of a compilation unit
14473 if not Is_In_Context_Clause
then
14477 -- Must be at least one argument
14479 if Arg_Count
= 0 then
14480 Error_Pragma
("pragma% requires at least one argument");
14483 -- In Ada 83 mode, there can be no items following it in the
14484 -- context list except other pragmas and implicit with clauses
14485 -- (e.g. those added by use of Rtsfind). In Ada 95 mode, this
14486 -- placement rule does not apply.
14488 if Ada_Version
= Ada_83
and then Comes_From_Source
(N
) then
14490 while Present
(Citem
) loop
14491 if Nkind
(Citem
) = N_Pragma
14492 or else (Nkind
(Citem
) = N_With_Clause
14493 and then Implicit_With
(Citem
))
14498 ("(Ada 83) pragma% must be at end of context clause");
14505 -- Finally, the arguments must all be units mentioned in a with
14506 -- clause in the same context clause. Note we already checked (in
14507 -- Par.Prag) that the arguments are all identifiers or selected
14511 Outer
: while Present
(Arg
) loop
14512 Citem
:= First
(List_Containing
(N
));
14513 Inner
: while Citem
/= N
loop
14514 if Nkind
(Citem
) = N_With_Clause
14515 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14517 Set_Elaborate_Present
(Citem
, True);
14518 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14520 -- With the pragma present, elaboration calls on
14521 -- subprograms from the named unit need no further
14522 -- checks, as long as the pragma appears in the current
14523 -- compilation unit. If the pragma appears in some unit
14524 -- in the context, there might still be a need for an
14525 -- Elaborate_All_Desirable from the current compilation
14526 -- to the named unit, so we keep the check enabled.
14528 if In_Extended_Main_Source_Unit
(N
) then
14530 -- This does not apply in SPARK mode, where we allow
14531 -- pragma Elaborate, but we don't trust it to be right
14532 -- so we will still insist on the Elaborate_All.
14534 if SPARK_Mode
/= On
then
14535 Set_Suppress_Elaboration_Warnings
14536 (Entity
(Name
(Citem
)));
14548 ("argument of pragma% is not withed unit", Arg
);
14554 -- Give a warning if operating in static mode with one of the
14555 -- gnatwl/-gnatwE (elaboration warnings enabled) switches set.
14558 and not Dynamic_Elaboration_Checks
14560 -- pragma Elaborate not allowed in SPARK mode anyway. We
14561 -- already complained about it, no point in generating any
14562 -- further complaint.
14564 and SPARK_Mode
/= On
14567 ("?l?use of pragma Elaborate may not be safe", N
);
14569 ("?l?use pragma Elaborate_All instead if possible", N
);
14573 -------------------
14574 -- Elaborate_All --
14575 -------------------
14577 -- pragma Elaborate_All (library_unit_NAME {, library_unit_NAME});
14579 when Pragma_Elaborate_All
=> Elaborate_All
: declare
14584 Check_Ada_83_Warning
;
14586 -- Pragma must be in context items list of a compilation unit
14588 if not Is_In_Context_Clause
then
14592 -- Must be at least one argument
14594 if Arg_Count
= 0 then
14595 Error_Pragma
("pragma% requires at least one argument");
14598 -- Note: unlike pragma Elaborate, pragma Elaborate_All does not
14599 -- have to appear at the end of the context clause, but may
14600 -- appear mixed in with other items, even in Ada 83 mode.
14602 -- Final check: the arguments must all be units mentioned in
14603 -- a with clause in the same context clause. Note that we
14604 -- already checked (in Par.Prag) that all the arguments are
14605 -- either identifiers or selected components.
14608 Outr
: while Present
(Arg
) loop
14609 Citem
:= First
(List_Containing
(N
));
14610 Innr
: while Citem
/= N
loop
14611 if Nkind
(Citem
) = N_With_Clause
14612 and then Same_Name
(Name
(Citem
), Get_Pragma_Arg
(Arg
))
14614 Set_Elaborate_All_Present
(Citem
, True);
14615 Set_Elab_Unit_Name
(Get_Pragma_Arg
(Arg
), Name
(Citem
));
14617 -- Suppress warnings and elaboration checks on the named
14618 -- unit if the pragma is in the current compilation, as
14619 -- for pragma Elaborate.
14621 if In_Extended_Main_Source_Unit
(N
) then
14622 Set_Suppress_Elaboration_Warnings
14623 (Entity
(Name
(Citem
)));
14632 Set_Error_Posted
(N
);
14634 ("argument of pragma% is not withed unit", Arg
);
14641 --------------------
14642 -- Elaborate_Body --
14643 --------------------
14645 -- pragma Elaborate_Body [( library_unit_NAME )];
14647 when Pragma_Elaborate_Body
=> Elaborate_Body
: declare
14648 Cunit_Node
: Node_Id
;
14649 Cunit_Ent
: Entity_Id
;
14652 Check_Ada_83_Warning
;
14653 Check_Valid_Library_Unit_Pragma
;
14655 if Nkind
(N
) = N_Null_Statement
then
14659 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
14660 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
14662 -- A pragma that applies to a Ghost entity becomes Ghost for the
14663 -- purposes of legality checks and removal of ignored Ghost code.
14665 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
14667 if Nkind_In
(Unit
(Cunit_Node
), N_Package_Body
,
14670 Error_Pragma
("pragma% must refer to a spec, not a body");
14672 Set_Body_Required
(Cunit_Node
, True);
14673 Set_Has_Pragma_Elaborate_Body
(Cunit_Ent
);
14675 -- If we are in dynamic elaboration mode, then we suppress
14676 -- elaboration warnings for the unit, since it is definitely
14677 -- fine NOT to do dynamic checks at the first level (and such
14678 -- checks will be suppressed because no elaboration boolean
14679 -- is created for Elaborate_Body packages).
14681 -- But in the static model of elaboration, Elaborate_Body is
14682 -- definitely NOT good enough to ensure elaboration safety on
14683 -- its own, since the body may WITH other units that are not
14684 -- safe from an elaboration point of view, so a client must
14685 -- still do an Elaborate_All on such units.
14687 -- Debug flag -gnatdD restores the old behavior of 3.13, where
14688 -- Elaborate_Body always suppressed elab warnings.
14690 if Dynamic_Elaboration_Checks
or Debug_Flag_DD
then
14691 Set_Suppress_Elaboration_Warnings
(Cunit_Ent
);
14694 end Elaborate_Body
;
14696 ------------------------
14697 -- Elaboration_Checks --
14698 ------------------------
14700 -- pragma Elaboration_Checks (Static | Dynamic);
14702 when Pragma_Elaboration_Checks
=>
14704 Check_Arg_Count
(1);
14705 Check_Arg_Is_One_Of
(Arg1
, Name_Static
, Name_Dynamic
);
14707 -- Set flag accordingly (ignore attempt at dynamic elaboration
14708 -- checks in SPARK mode).
14710 Dynamic_Elaboration_Checks
:=
14711 Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Dynamic
;
14717 -- pragma Eliminate (
14718 -- [Unit_Name =>] IDENTIFIER | SELECTED_COMPONENT,
14719 -- [,[Entity =>] IDENTIFIER |
14720 -- SELECTED_COMPONENT |
14722 -- [, OVERLOADING_RESOLUTION]);
14724 -- OVERLOADING_RESOLUTION ::= PARAMETER_AND_RESULT_TYPE_PROFILE |
14727 -- PARAMETER_AND_RESULT_TYPE_PROFILE ::= PROCEDURE_PROFILE |
14728 -- FUNCTION_PROFILE
14730 -- PROCEDURE_PROFILE ::= Parameter_Types => PARAMETER_TYPES
14732 -- FUNCTION_PROFILE ::= [Parameter_Types => PARAMETER_TYPES,]
14733 -- Result_Type => result_SUBTYPE_NAME]
14735 -- PARAMETER_TYPES ::= (SUBTYPE_NAME {, SUBTYPE_NAME})
14736 -- SUBTYPE_NAME ::= STRING_LITERAL
14738 -- SOURCE_LOCATION ::= Source_Location => SOURCE_TRACE
14739 -- SOURCE_TRACE ::= STRING_LITERAL
14741 when Pragma_Eliminate
=> Eliminate
: declare
14742 Args
: Args_List
(1 .. 5);
14743 Names
: constant Name_List
(1 .. 5) := (
14746 Name_Parameter_Types
,
14748 Name_Source_Location
);
14750 Unit_Name
: Node_Id
renames Args
(1);
14751 Entity
: Node_Id
renames Args
(2);
14752 Parameter_Types
: Node_Id
renames Args
(3);
14753 Result_Type
: Node_Id
renames Args
(4);
14754 Source_Location
: Node_Id
renames Args
(5);
14758 Check_Valid_Configuration_Pragma
;
14759 Gather_Associations
(Names
, Args
);
14761 if No
(Unit_Name
) then
14762 Error_Pragma
("missing Unit_Name argument for pragma%");
14766 and then (Present
(Parameter_Types
)
14768 Present
(Result_Type
)
14770 Present
(Source_Location
))
14772 Error_Pragma
("missing Entity argument for pragma%");
14775 if (Present
(Parameter_Types
)
14777 Present
(Result_Type
))
14779 Present
(Source_Location
)
14782 ("parameter profile and source location cannot be used "
14783 & "together in pragma%");
14786 Process_Eliminate_Pragma
14795 -----------------------------------
14796 -- Enable_Atomic_Synchronization --
14797 -----------------------------------
14799 -- pragma Enable_Atomic_Synchronization [(Entity)];
14801 when Pragma_Enable_Atomic_Synchronization
=>
14803 Process_Disable_Enable_Atomic_Sync
(Name_Unsuppress
);
14810 -- [ Convention =>] convention_IDENTIFIER,
14811 -- [ Entity =>] LOCAL_NAME
14812 -- [, [External_Name =>] static_string_EXPRESSION ]
14813 -- [, [Link_Name =>] static_string_EXPRESSION ]);
14815 when Pragma_Export
=> Export
: declare
14817 Def_Id
: Entity_Id
;
14819 pragma Warnings
(Off
, C
);
14822 Check_Ada_83_Warning
;
14826 Name_External_Name
,
14829 Check_At_Least_N_Arguments
(2);
14830 Check_At_Most_N_Arguments
(4);
14832 -- In Relaxed_RM_Semantics, support old Ada 83 style:
14833 -- pragma Export (Entity, "external name");
14835 if Relaxed_RM_Semantics
14836 and then Arg_Count
= 2
14837 and then Nkind
(Expression
(Arg2
)) = N_String_Literal
14840 Def_Id
:= Get_Pragma_Arg
(Arg1
);
14843 if not Is_Entity_Name
(Def_Id
) then
14844 Error_Pragma_Arg
("entity name required", Arg1
);
14847 Def_Id
:= Entity
(Def_Id
);
14848 Set_Exported
(Def_Id
, Arg1
);
14851 Process_Convention
(C
, Def_Id
);
14853 -- A pragma that applies to a Ghost entity becomes Ghost for
14854 -- the purposes of legality checks and removal of ignored Ghost
14857 Mark_Ghost_Pragma
(N
, Def_Id
);
14859 if Ekind
(Def_Id
) /= E_Constant
then
14860 Note_Possible_Modification
14861 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
14864 Process_Interface_Name
(Def_Id
, Arg3
, Arg4
, N
);
14865 Set_Exported
(Def_Id
, Arg2
);
14868 -- If the entity is a deferred constant, propagate the information
14869 -- to the full view, because gigi elaborates the full view only.
14871 if Ekind
(Def_Id
) = E_Constant
14872 and then Present
(Full_View
(Def_Id
))
14875 Id2
: constant Entity_Id
:= Full_View
(Def_Id
);
14877 Set_Is_Exported
(Id2
, Is_Exported
(Def_Id
));
14878 Set_First_Rep_Item
(Id2
, First_Rep_Item
(Def_Id
));
14879 Set_Interface_Name
(Id2
, Einfo
.Interface_Name
(Def_Id
));
14884 ---------------------
14885 -- Export_Function --
14886 ---------------------
14888 -- pragma Export_Function (
14889 -- [Internal =>] LOCAL_NAME
14890 -- [, [External =>] EXTERNAL_SYMBOL]
14891 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
14892 -- [, [Result_Type =>] TYPE_DESIGNATOR]
14893 -- [, [Mechanism =>] MECHANISM]
14894 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
14896 -- EXTERNAL_SYMBOL ::=
14898 -- | static_string_EXPRESSION
14900 -- PARAMETER_TYPES ::=
14902 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14904 -- TYPE_DESIGNATOR ::=
14906 -- | subtype_Name ' Access
14910 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14912 -- MECHANISM_ASSOCIATION ::=
14913 -- [formal_parameter_NAME =>] MECHANISM_NAME
14915 -- MECHANISM_NAME ::=
14919 when Pragma_Export_Function
=> Export_Function
: declare
14920 Args
: Args_List
(1 .. 6);
14921 Names
: constant Name_List
(1 .. 6) := (
14924 Name_Parameter_Types
,
14927 Name_Result_Mechanism
);
14929 Internal
: Node_Id
renames Args
(1);
14930 External
: Node_Id
renames Args
(2);
14931 Parameter_Types
: Node_Id
renames Args
(3);
14932 Result_Type
: Node_Id
renames Args
(4);
14933 Mechanism
: Node_Id
renames Args
(5);
14934 Result_Mechanism
: Node_Id
renames Args
(6);
14938 Gather_Associations
(Names
, Args
);
14939 Process_Extended_Import_Export_Subprogram_Pragma
(
14940 Arg_Internal
=> Internal
,
14941 Arg_External
=> External
,
14942 Arg_Parameter_Types
=> Parameter_Types
,
14943 Arg_Result_Type
=> Result_Type
,
14944 Arg_Mechanism
=> Mechanism
,
14945 Arg_Result_Mechanism
=> Result_Mechanism
);
14946 end Export_Function
;
14948 -------------------
14949 -- Export_Object --
14950 -------------------
14952 -- pragma Export_Object (
14953 -- [Internal =>] LOCAL_NAME
14954 -- [, [External =>] EXTERNAL_SYMBOL]
14955 -- [, [Size =>] EXTERNAL_SYMBOL]);
14957 -- EXTERNAL_SYMBOL ::=
14959 -- | static_string_EXPRESSION
14961 -- PARAMETER_TYPES ::=
14963 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
14965 -- TYPE_DESIGNATOR ::=
14967 -- | subtype_Name ' Access
14971 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
14973 -- MECHANISM_ASSOCIATION ::=
14974 -- [formal_parameter_NAME =>] MECHANISM_NAME
14976 -- MECHANISM_NAME ::=
14980 when Pragma_Export_Object
=> Export_Object
: declare
14981 Args
: Args_List
(1 .. 3);
14982 Names
: constant Name_List
(1 .. 3) := (
14987 Internal
: Node_Id
renames Args
(1);
14988 External
: Node_Id
renames Args
(2);
14989 Size
: Node_Id
renames Args
(3);
14993 Gather_Associations
(Names
, Args
);
14994 Process_Extended_Import_Export_Object_Pragma
(
14995 Arg_Internal
=> Internal
,
14996 Arg_External
=> External
,
15000 ----------------------
15001 -- Export_Procedure --
15002 ----------------------
15004 -- pragma Export_Procedure (
15005 -- [Internal =>] LOCAL_NAME
15006 -- [, [External =>] EXTERNAL_SYMBOL]
15007 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15008 -- [, [Mechanism =>] MECHANISM]);
15010 -- EXTERNAL_SYMBOL ::=
15012 -- | static_string_EXPRESSION
15014 -- PARAMETER_TYPES ::=
15016 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15018 -- TYPE_DESIGNATOR ::=
15020 -- | subtype_Name ' Access
15024 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15026 -- MECHANISM_ASSOCIATION ::=
15027 -- [formal_parameter_NAME =>] MECHANISM_NAME
15029 -- MECHANISM_NAME ::=
15033 when Pragma_Export_Procedure
=> Export_Procedure
: declare
15034 Args
: Args_List
(1 .. 4);
15035 Names
: constant Name_List
(1 .. 4) := (
15038 Name_Parameter_Types
,
15041 Internal
: Node_Id
renames Args
(1);
15042 External
: Node_Id
renames Args
(2);
15043 Parameter_Types
: Node_Id
renames Args
(3);
15044 Mechanism
: Node_Id
renames Args
(4);
15048 Gather_Associations
(Names
, Args
);
15049 Process_Extended_Import_Export_Subprogram_Pragma
(
15050 Arg_Internal
=> Internal
,
15051 Arg_External
=> External
,
15052 Arg_Parameter_Types
=> Parameter_Types
,
15053 Arg_Mechanism
=> Mechanism
);
15054 end Export_Procedure
;
15060 -- pragma Export_Value (
15061 -- [Value =>] static_integer_EXPRESSION,
15062 -- [Link_Name =>] static_string_EXPRESSION);
15064 when Pragma_Export_Value
=>
15066 Check_Arg_Order
((Name_Value
, Name_Link_Name
));
15067 Check_Arg_Count
(2);
15069 Check_Optional_Identifier
(Arg1
, Name_Value
);
15070 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
15072 Check_Optional_Identifier
(Arg2
, Name_Link_Name
);
15073 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
15075 -----------------------------
15076 -- Export_Valued_Procedure --
15077 -----------------------------
15079 -- pragma Export_Valued_Procedure (
15080 -- [Internal =>] LOCAL_NAME
15081 -- [, [External =>] EXTERNAL_SYMBOL,]
15082 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
15083 -- [, [Mechanism =>] MECHANISM]);
15085 -- EXTERNAL_SYMBOL ::=
15087 -- | static_string_EXPRESSION
15089 -- PARAMETER_TYPES ::=
15091 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
15093 -- TYPE_DESIGNATOR ::=
15095 -- | subtype_Name ' Access
15099 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
15101 -- MECHANISM_ASSOCIATION ::=
15102 -- [formal_parameter_NAME =>] MECHANISM_NAME
15104 -- MECHANISM_NAME ::=
15108 when Pragma_Export_Valued_Procedure
=>
15109 Export_Valued_Procedure
: declare
15110 Args
: Args_List
(1 .. 4);
15111 Names
: constant Name_List
(1 .. 4) := (
15114 Name_Parameter_Types
,
15117 Internal
: Node_Id
renames Args
(1);
15118 External
: Node_Id
renames Args
(2);
15119 Parameter_Types
: Node_Id
renames Args
(3);
15120 Mechanism
: Node_Id
renames Args
(4);
15124 Gather_Associations
(Names
, Args
);
15125 Process_Extended_Import_Export_Subprogram_Pragma
(
15126 Arg_Internal
=> Internal
,
15127 Arg_External
=> External
,
15128 Arg_Parameter_Types
=> Parameter_Types
,
15129 Arg_Mechanism
=> Mechanism
);
15130 end Export_Valued_Procedure
;
15132 -------------------
15133 -- Extend_System --
15134 -------------------
15136 -- pragma Extend_System ([Name =>] Identifier);
15138 when Pragma_Extend_System
=>
15140 Check_Valid_Configuration_Pragma
;
15141 Check_Arg_Count
(1);
15142 Check_Optional_Identifier
(Arg1
, Name_Name
);
15143 Check_Arg_Is_Identifier
(Arg1
);
15145 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
15148 and then Name_Buffer
(1 .. 4) = "aux_"
15150 if Present
(System_Extend_Pragma_Arg
) then
15151 if Chars
(Get_Pragma_Arg
(Arg1
)) =
15152 Chars
(Expression
(System_Extend_Pragma_Arg
))
15156 Error_Msg_Sloc
:= Sloc
(System_Extend_Pragma_Arg
);
15157 Error_Pragma
("pragma% conflicts with that #");
15161 System_Extend_Pragma_Arg
:= Arg1
;
15163 if not GNAT_Mode
then
15164 System_Extend_Unit
:= Arg1
;
15168 Error_Pragma
("incorrect name for pragma%, must be Aux_xxx");
15171 ------------------------
15172 -- Extensions_Allowed --
15173 ------------------------
15175 -- pragma Extensions_Allowed (ON | OFF);
15177 when Pragma_Extensions_Allowed
=>
15179 Check_Arg_Count
(1);
15180 Check_No_Identifiers
;
15181 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
15183 if Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
then
15184 Extensions_Allowed
:= True;
15185 Ada_Version
:= Ada_Version_Type
'Last;
15188 Extensions_Allowed
:= False;
15189 Ada_Version
:= Ada_Version_Explicit
;
15190 Ada_Version_Pragma
:= Empty
;
15193 ------------------------
15194 -- Extensions_Visible --
15195 ------------------------
15197 -- pragma Extensions_Visible [ (boolean_EXPRESSION) ];
15199 -- Characteristics:
15201 -- * Analysis - The annotation is fully analyzed immediately upon
15202 -- elaboration as its expression must be static.
15204 -- * Expansion - None.
15206 -- * Template - The annotation utilizes the generic template of the
15207 -- related subprogram [body] when it is:
15209 -- aspect on subprogram declaration
15210 -- aspect on stand alone subprogram body
15211 -- pragma on stand alone subprogram body
15213 -- The annotation must prepare its own template when it is:
15215 -- pragma on subprogram declaration
15217 -- * Globals - Capture of global references must occur after full
15220 -- * Instance - The annotation is instantiated automatically when
15221 -- the related generic subprogram [body] is instantiated except for
15222 -- the "pragma on subprogram declaration" case. In that scenario
15223 -- the annotation must instantiate itself.
15225 when Pragma_Extensions_Visible
=> Extensions_Visible
: declare
15226 Formal
: Entity_Id
;
15227 Has_OK_Formal
: Boolean := False;
15228 Spec_Id
: Entity_Id
;
15229 Subp_Decl
: Node_Id
;
15233 Check_No_Identifiers
;
15234 Check_At_Most_N_Arguments
(1);
15237 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
15239 -- Abstract subprogram declaration
15241 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
15244 -- Generic subprogram declaration
15246 elsif Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
15249 -- Body acts as spec
15251 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
15252 and then No
(Corresponding_Spec
(Subp_Decl
))
15256 -- Body stub acts as spec
15258 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
15259 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
15263 -- Subprogram declaration
15265 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
15268 -- Otherwise the pragma is associated with an illegal construct
15271 Error_Pragma
("pragma % must apply to a subprogram");
15275 -- Mark the pragma as Ghost if the related subprogram is also
15276 -- Ghost. This also ensures that any expansion performed further
15277 -- below will produce Ghost nodes.
15279 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
15280 Mark_Ghost_Pragma
(N
, Spec_Id
);
15282 -- Chain the pragma on the contract for completeness
15284 Add_Contract_Item
(N
, Defining_Entity
(Subp_Decl
));
15286 -- The legality checks of pragma Extension_Visible are affected
15287 -- by the SPARK mode in effect. Analyze all pragmas in specific
15290 Analyze_If_Present
(Pragma_SPARK_Mode
);
15292 -- Examine the formals of the related subprogram
15294 Formal
:= First_Formal
(Spec_Id
);
15295 while Present
(Formal
) loop
15297 -- At least one of the formals is of a specific tagged type,
15298 -- the pragma is legal.
15300 if Is_Specific_Tagged_Type
(Etype
(Formal
)) then
15301 Has_OK_Formal
:= True;
15304 -- A generic subprogram with at least one formal of a private
15305 -- type ensures the legality of the pragma because the actual
15306 -- may be specifically tagged. Note that this is verified by
15307 -- the check above at instantiation time.
15309 elsif Is_Private_Type
(Etype
(Formal
))
15310 and then Is_Generic_Type
(Etype
(Formal
))
15312 Has_OK_Formal
:= True;
15316 Next_Formal
(Formal
);
15319 if not Has_OK_Formal
then
15320 Error_Msg_Name_1
:= Pname
;
15321 Error_Msg_N
(Fix_Error
("incorrect placement of pragma %"), N
);
15323 ("\subprogram & lacks parameter of specific tagged or "
15324 & "generic private type", N
, Spec_Id
);
15329 -- Analyze the Boolean expression (if any)
15331 if Present
(Arg1
) then
15332 Check_Static_Boolean_Expression
15333 (Expression
(Get_Argument
(N
, Spec_Id
)));
15335 end Extensions_Visible
;
15341 -- pragma External (
15342 -- [ Convention =>] convention_IDENTIFIER,
15343 -- [ Entity =>] LOCAL_NAME
15344 -- [, [External_Name =>] static_string_EXPRESSION ]
15345 -- [, [Link_Name =>] static_string_EXPRESSION ]);
15347 when Pragma_External
=> External
: declare
15350 pragma Warnings
(Off
, C
);
15357 Name_External_Name
,
15359 Check_At_Least_N_Arguments
(2);
15360 Check_At_Most_N_Arguments
(4);
15361 Process_Convention
(C
, E
);
15363 -- A pragma that applies to a Ghost entity becomes Ghost for the
15364 -- purposes of legality checks and removal of ignored Ghost code.
15366 Mark_Ghost_Pragma
(N
, E
);
15368 Note_Possible_Modification
15369 (Get_Pragma_Arg
(Arg2
), Sure
=> False);
15370 Process_Interface_Name
(E
, Arg3
, Arg4
, N
);
15371 Set_Exported
(E
, Arg2
);
15374 --------------------------
15375 -- External_Name_Casing --
15376 --------------------------
15378 -- pragma External_Name_Casing (
15379 -- UPPERCASE | LOWERCASE
15380 -- [, AS_IS | UPPERCASE | LOWERCASE]);
15382 when Pragma_External_Name_Casing
=>
15384 Check_No_Identifiers
;
15386 if Arg_Count
= 2 then
15387 Check_Arg_Is_One_Of
15388 (Arg2
, Name_As_Is
, Name_Uppercase
, Name_Lowercase
);
15390 case Chars
(Get_Pragma_Arg
(Arg2
)) is
15392 Opt
.External_Name_Exp_Casing
:= As_Is
;
15394 when Name_Uppercase
=>
15395 Opt
.External_Name_Exp_Casing
:= Uppercase
;
15397 when Name_Lowercase
=>
15398 Opt
.External_Name_Exp_Casing
:= Lowercase
;
15405 Check_Arg_Count
(1);
15408 Check_Arg_Is_One_Of
(Arg1
, Name_Uppercase
, Name_Lowercase
);
15410 case Chars
(Get_Pragma_Arg
(Arg1
)) is
15411 when Name_Uppercase
=>
15412 Opt
.External_Name_Imp_Casing
:= Uppercase
;
15414 when Name_Lowercase
=>
15415 Opt
.External_Name_Imp_Casing
:= Lowercase
;
15425 -- pragma Fast_Math;
15427 when Pragma_Fast_Math
=>
15429 Check_No_Identifiers
;
15430 Check_Valid_Configuration_Pragma
;
15433 --------------------------
15434 -- Favor_Top_Level --
15435 --------------------------
15437 -- pragma Favor_Top_Level (type_NAME);
15439 when Pragma_Favor_Top_Level
=> Favor_Top_Level
: declare
15444 Check_No_Identifiers
;
15445 Check_Arg_Count
(1);
15446 Check_Arg_Is_Local_Name
(Arg1
);
15447 Typ
:= Entity
(Get_Pragma_Arg
(Arg1
));
15449 -- A pragma that applies to a Ghost entity becomes Ghost for the
15450 -- purposes of legality checks and removal of ignored Ghost code.
15452 Mark_Ghost_Pragma
(N
, Typ
);
15454 -- If it's an access-to-subprogram type (in particular, not a
15455 -- subtype), set the flag on that type.
15457 if Is_Access_Subprogram_Type
(Typ
) then
15458 Set_Can_Use_Internal_Rep
(Typ
, False);
15460 -- Otherwise it's an error (name denotes the wrong sort of entity)
15464 ("access-to-subprogram type expected",
15465 Get_Pragma_Arg
(Arg1
));
15467 end Favor_Top_Level
;
15469 ---------------------------
15470 -- Finalize_Storage_Only --
15471 ---------------------------
15473 -- pragma Finalize_Storage_Only (first_subtype_LOCAL_NAME);
15475 when Pragma_Finalize_Storage_Only
=> Finalize_Storage
: declare
15476 Assoc
: constant Node_Id
:= Arg1
;
15477 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
15482 Check_No_Identifiers
;
15483 Check_Arg_Count
(1);
15484 Check_Arg_Is_Local_Name
(Arg1
);
15486 Find_Type
(Type_Id
);
15487 Typ
:= Entity
(Type_Id
);
15490 or else Rep_Item_Too_Early
(Typ
, N
)
15494 Typ
:= Underlying_Type
(Typ
);
15497 if not Is_Controlled
(Typ
) then
15498 Error_Pragma
("pragma% must specify controlled type");
15501 Check_First_Subtype
(Arg1
);
15503 if Finalize_Storage_Only
(Typ
) then
15504 Error_Pragma
("duplicate pragma%, only one allowed");
15506 elsif not Rep_Item_Too_Late
(Typ
, N
) then
15507 Set_Finalize_Storage_Only
(Base_Type
(Typ
), True);
15509 end Finalize_Storage
;
15515 -- pragma Ghost [ (boolean_EXPRESSION) ];
15517 when Pragma_Ghost
=> Ghost
: declare
15521 Orig_Stmt
: Node_Id
;
15522 Prev_Id
: Entity_Id
;
15527 Check_No_Identifiers
;
15528 Check_At_Most_N_Arguments
(1);
15532 while Present
(Stmt
) loop
15534 -- Skip prior pragmas, but check for duplicates
15536 if Nkind
(Stmt
) = N_Pragma
then
15537 if Pragma_Name
(Stmt
) = Pname
then
15544 -- Task unit declared without a definition cannot be subject to
15545 -- pragma Ghost (SPARK RM 6.9(19)).
15547 elsif Nkind_In
(Stmt
, N_Single_Task_Declaration
,
15548 N_Task_Type_Declaration
)
15550 Error_Pragma
("pragma % cannot apply to a task type");
15553 -- Skip internally generated code
15555 elsif not Comes_From_Source
(Stmt
) then
15556 Orig_Stmt
:= Original_Node
(Stmt
);
15558 -- When pragma Ghost applies to an untagged derivation, the
15559 -- derivation is transformed into a [sub]type declaration.
15561 if Nkind_In
(Stmt
, N_Full_Type_Declaration
,
15562 N_Subtype_Declaration
)
15563 and then Comes_From_Source
(Orig_Stmt
)
15564 and then Nkind
(Orig_Stmt
) = N_Full_Type_Declaration
15565 and then Nkind
(Type_Definition
(Orig_Stmt
)) =
15566 N_Derived_Type_Definition
15568 Id
:= Defining_Entity
(Stmt
);
15571 -- When pragma Ghost applies to an object declaration which
15572 -- is initialized by means of a function call that returns
15573 -- on the secondary stack, the object declaration becomes a
15576 elsif Nkind
(Stmt
) = N_Object_Renaming_Declaration
15577 and then Comes_From_Source
(Orig_Stmt
)
15578 and then Nkind
(Orig_Stmt
) = N_Object_Declaration
15580 Id
:= Defining_Entity
(Stmt
);
15583 -- When pragma Ghost applies to an expression function, the
15584 -- expression function is transformed into a subprogram.
15586 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
15587 and then Comes_From_Source
(Orig_Stmt
)
15588 and then Nkind
(Orig_Stmt
) = N_Expression_Function
15590 Id
:= Defining_Entity
(Stmt
);
15594 -- The pragma applies to a legal construct, stop the traversal
15596 elsif Nkind_In
(Stmt
, N_Abstract_Subprogram_Declaration
,
15597 N_Full_Type_Declaration
,
15598 N_Generic_Subprogram_Declaration
,
15599 N_Object_Declaration
,
15600 N_Private_Extension_Declaration
,
15601 N_Private_Type_Declaration
,
15602 N_Subprogram_Declaration
,
15603 N_Subtype_Declaration
)
15605 Id
:= Defining_Entity
(Stmt
);
15608 -- The pragma does not apply to a legal construct, issue an
15609 -- error and stop the analysis.
15613 ("pragma % must apply to an object, package, subprogram "
15618 Stmt
:= Prev
(Stmt
);
15621 Context
:= Parent
(N
);
15623 -- Handle compilation units
15625 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
15626 Context
:= Unit
(Parent
(Context
));
15629 -- Protected and task types cannot be subject to pragma Ghost
15630 -- (SPARK RM 6.9(19)).
15632 if Nkind_In
(Context
, N_Protected_Body
, N_Protected_Definition
)
15634 Error_Pragma
("pragma % cannot apply to a protected type");
15637 elsif Nkind_In
(Context
, N_Task_Body
, N_Task_Definition
) then
15638 Error_Pragma
("pragma % cannot apply to a task type");
15644 -- When pragma Ghost is associated with a [generic] package, it
15645 -- appears in the visible declarations.
15647 if Nkind
(Context
) = N_Package_Specification
15648 and then Present
(Visible_Declarations
(Context
))
15649 and then List_Containing
(N
) = Visible_Declarations
(Context
)
15651 Id
:= Defining_Entity
(Context
);
15653 -- Pragma Ghost applies to a stand alone subprogram body
15655 elsif Nkind
(Context
) = N_Subprogram_Body
15656 and then No
(Corresponding_Spec
(Context
))
15658 Id
:= Defining_Entity
(Context
);
15660 -- Pragma Ghost applies to a subprogram declaration that acts
15661 -- as a compilation unit.
15663 elsif Nkind
(Context
) = N_Subprogram_Declaration
then
15664 Id
:= Defining_Entity
(Context
);
15670 ("pragma % must apply to an object, package, subprogram or "
15675 -- Handle completions of types and constants that are subject to
15678 if Is_Record_Type
(Id
) or else Ekind
(Id
) = E_Constant
then
15679 Prev_Id
:= Incomplete_Or_Partial_View
(Id
);
15681 if Present
(Prev_Id
) and then not Is_Ghost_Entity
(Prev_Id
) then
15682 Error_Msg_Name_1
:= Pname
;
15684 -- The full declaration of a deferred constant cannot be
15685 -- subject to pragma Ghost unless the deferred declaration
15686 -- is also Ghost (SPARK RM 6.9(9)).
15688 if Ekind
(Prev_Id
) = E_Constant
then
15689 Error_Msg_Name_1
:= Pname
;
15690 Error_Msg_NE
(Fix_Error
15691 ("pragma % must apply to declaration of deferred "
15692 & "constant &"), N
, Id
);
15695 -- Pragma Ghost may appear on the full view of an incomplete
15696 -- type because the incomplete declaration lacks aspects and
15697 -- cannot be subject to pragma Ghost.
15699 elsif Ekind
(Prev_Id
) = E_Incomplete_Type
then
15702 -- The full declaration of a type cannot be subject to
15703 -- pragma Ghost unless the partial view is also Ghost
15704 -- (SPARK RM 6.9(9)).
15707 Error_Msg_NE
(Fix_Error
15708 ("pragma % must apply to partial view of type &"),
15714 -- A synchronized object cannot be subject to pragma Ghost
15715 -- (SPARK RM 6.9(19)).
15717 elsif Ekind
(Id
) = E_Variable
then
15718 if Is_Protected_Type
(Etype
(Id
)) then
15719 Error_Pragma
("pragma % cannot apply to a protected object");
15722 elsif Is_Task_Type
(Etype
(Id
)) then
15723 Error_Pragma
("pragma % cannot apply to a task object");
15728 -- Analyze the Boolean expression (if any)
15730 if Present
(Arg1
) then
15731 Expr
:= Get_Pragma_Arg
(Arg1
);
15733 Analyze_And_Resolve
(Expr
, Standard_Boolean
);
15735 if Is_OK_Static_Expression
(Expr
) then
15737 -- "Ghostness" cannot be turned off once enabled within a
15738 -- region (SPARK RM 6.9(6)).
15740 if Is_False
(Expr_Value
(Expr
))
15741 and then Ghost_Mode
> None
15744 ("pragma % with value False cannot appear in enabled "
15749 -- Otherwie the expression is not static
15753 ("expression of pragma % must be static", Expr
);
15758 Set_Is_Ghost_Entity
(Id
);
15765 -- pragma Global (GLOBAL_SPECIFICATION);
15767 -- GLOBAL_SPECIFICATION ::=
15770 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
15772 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
15774 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
15775 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
15776 -- GLOBAL_ITEM ::= NAME
15778 -- Characteristics:
15780 -- * Analysis - The annotation undergoes initial checks to verify
15781 -- the legal placement and context. Secondary checks fully analyze
15782 -- the dependency clauses in:
15784 -- Analyze_Global_In_Decl_Part
15786 -- * Expansion - None.
15788 -- * Template - The annotation utilizes the generic template of the
15789 -- related subprogram [body] when it is:
15791 -- aspect on subprogram declaration
15792 -- aspect on stand alone subprogram body
15793 -- pragma on stand alone subprogram body
15795 -- The annotation must prepare its own template when it is:
15797 -- pragma on subprogram declaration
15799 -- * Globals - Capture of global references must occur after full
15802 -- * Instance - The annotation is instantiated automatically when
15803 -- the related generic subprogram [body] is instantiated except for
15804 -- the "pragma on subprogram declaration" case. In that scenario
15805 -- the annotation must instantiate itself.
15807 when Pragma_Global
=> Global
: declare
15809 Spec_Id
: Entity_Id
;
15810 Subp_Decl
: Node_Id
;
15813 Analyze_Depends_Global
(Spec_Id
, Subp_Decl
, Legal
);
15817 -- Chain the pragma on the contract for further processing by
15818 -- Analyze_Global_In_Decl_Part.
15820 Add_Contract_Item
(N
, Spec_Id
);
15822 -- Fully analyze the pragma when it appears inside an entry
15823 -- or subprogram body because it cannot benefit from forward
15826 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
15828 N_Subprogram_Body_Stub
)
15830 -- The legality checks of pragmas Depends and Global are
15831 -- affected by the SPARK mode in effect and the volatility
15832 -- of the context. In addition these two pragmas are subject
15833 -- to an inherent order:
15838 -- Analyze all these pragmas in the order outlined above
15840 Analyze_If_Present
(Pragma_SPARK_Mode
);
15841 Analyze_If_Present
(Pragma_Volatile_Function
);
15842 Analyze_Global_In_Decl_Part
(N
);
15843 Analyze_If_Present
(Pragma_Depends
);
15852 -- pragma Ident (static_string_EXPRESSION)
15854 -- Note: pragma Comment shares this processing. Pragma Ident is
15855 -- identical in effect to pragma Commment.
15857 when Pragma_Comment
15865 Check_Arg_Count
(1);
15866 Check_No_Identifiers
;
15867 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
15870 Str
:= Expr_Value_S
(Get_Pragma_Arg
(Arg1
));
15877 GP
:= Parent
(Parent
(N
));
15879 if Nkind_In
(GP
, N_Package_Declaration
,
15880 N_Generic_Package_Declaration
)
15885 -- If we have a compilation unit, then record the ident value,
15886 -- checking for improper duplication.
15888 if Nkind
(GP
) = N_Compilation_Unit
then
15889 CS
:= Ident_String
(Current_Sem_Unit
);
15891 if Present
(CS
) then
15893 -- If we have multiple instances, concatenate them, but
15894 -- not in ASIS, where we want the original tree.
15896 if not ASIS_Mode
then
15897 Start_String
(Strval
(CS
));
15898 Store_String_Char
(' ');
15899 Store_String_Chars
(Strval
(Str
));
15900 Set_Strval
(CS
, End_String
);
15904 Set_Ident_String
(Current_Sem_Unit
, Str
);
15907 -- For subunits, we just ignore the Ident, since in GNAT these
15908 -- are not separate object files, and hence not separate units
15909 -- in the unit table.
15911 elsif Nkind
(GP
) = N_Subunit
then
15917 -------------------
15918 -- Ignore_Pragma --
15919 -------------------
15921 -- pragma Ignore_Pragma (pragma_IDENTIFIER);
15923 -- Entirely handled in the parser, nothing to do here
15925 when Pragma_Ignore_Pragma
=>
15928 ----------------------------
15929 -- Implementation_Defined --
15930 ----------------------------
15932 -- pragma Implementation_Defined (LOCAL_NAME);
15934 -- Marks previously declared entity as implementation defined. For
15935 -- an overloaded entity, applies to the most recent homonym.
15937 -- pragma Implementation_Defined;
15939 -- The form with no arguments appears anywhere within a scope, most
15940 -- typically a package spec, and indicates that all entities that are
15941 -- defined within the package spec are Implementation_Defined.
15943 when Pragma_Implementation_Defined
=> Implementation_Defined
: declare
15948 Check_No_Identifiers
;
15950 -- Form with no arguments
15952 if Arg_Count
= 0 then
15953 Set_Is_Implementation_Defined
(Current_Scope
);
15955 -- Form with one argument
15958 Check_Arg_Count
(1);
15959 Check_Arg_Is_Local_Name
(Arg1
);
15960 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
15961 Set_Is_Implementation_Defined
(Ent
);
15963 end Implementation_Defined
;
15969 -- pragma Implemented (procedure_LOCAL_NAME, IMPLEMENTATION_KIND);
15971 -- IMPLEMENTATION_KIND ::=
15972 -- By_Entry | By_Protected_Procedure | By_Any | Optional
15974 -- "By_Any" and "Optional" are treated as synonyms in order to
15975 -- support Ada 2012 aspect Synchronization.
15977 when Pragma_Implemented
=> Implemented
: declare
15978 Proc_Id
: Entity_Id
;
15983 Check_Arg_Count
(2);
15984 Check_No_Identifiers
;
15985 Check_Arg_Is_Identifier
(Arg1
);
15986 Check_Arg_Is_Local_Name
(Arg1
);
15987 Check_Arg_Is_One_Of
(Arg2
,
15990 Name_By_Protected_Procedure
,
15993 -- Extract the name of the local procedure
15995 Proc_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
15997 -- Ada 2012 (AI05-0030): The procedure_LOCAL_NAME must denote a
15998 -- primitive procedure of a synchronized tagged type.
16000 if Ekind
(Proc_Id
) = E_Procedure
16001 and then Is_Primitive
(Proc_Id
)
16002 and then Present
(First_Formal
(Proc_Id
))
16004 Typ
:= Etype
(First_Formal
(Proc_Id
));
16006 if Is_Tagged_Type
(Typ
)
16009 -- Check for a protected, a synchronized or a task interface
16011 ((Is_Interface
(Typ
)
16012 and then Is_Synchronized_Interface
(Typ
))
16014 -- Check for a protected type or a task type that implements
16018 (Is_Concurrent_Record_Type
(Typ
)
16019 and then Present
(Interfaces
(Typ
)))
16021 -- In analysis-only mode, examine original protected type
16024 (Nkind
(Parent
(Typ
)) = N_Protected_Type_Declaration
16025 and then Present
(Interface_List
(Parent
(Typ
))))
16027 -- Check for a private record extension with keyword
16031 (Ekind_In
(Typ
, E_Record_Type_With_Private
,
16032 E_Record_Subtype_With_Private
)
16033 and then Synchronized_Present
(Parent
(Typ
))))
16038 ("controlling formal must be of synchronized tagged type",
16043 -- Procedures declared inside a protected type must be accepted
16045 elsif Ekind
(Proc_Id
) = E_Procedure
16046 and then Is_Protected_Type
(Scope
(Proc_Id
))
16050 -- The first argument is not a primitive procedure
16054 ("pragma % must be applied to a primitive procedure", Arg1
);
16058 -- Ada 2012 (AI05-0030): Cannot apply the implementation_kind
16059 -- By_Protected_Procedure to the primitive procedure of a task
16062 if Chars
(Arg2
) = Name_By_Protected_Procedure
16063 and then Is_Interface
(Typ
)
16064 and then Is_Task_Interface
(Typ
)
16067 ("implementation kind By_Protected_Procedure cannot be "
16068 & "applied to a task interface primitive", Arg2
);
16072 Record_Rep_Item
(Proc_Id
, N
);
16075 ----------------------
16076 -- Implicit_Packing --
16077 ----------------------
16079 -- pragma Implicit_Packing;
16081 when Pragma_Implicit_Packing
=>
16083 Check_Arg_Count
(0);
16084 Implicit_Packing
:= True;
16091 -- [Convention =>] convention_IDENTIFIER,
16092 -- [Entity =>] LOCAL_NAME
16093 -- [, [External_Name =>] static_string_EXPRESSION ]
16094 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16096 when Pragma_Import
=>
16097 Check_Ada_83_Warning
;
16101 Name_External_Name
,
16104 Check_At_Least_N_Arguments
(2);
16105 Check_At_Most_N_Arguments
(4);
16106 Process_Import_Or_Interface
;
16108 ---------------------
16109 -- Import_Function --
16110 ---------------------
16112 -- pragma Import_Function (
16113 -- [Internal =>] LOCAL_NAME,
16114 -- [, [External =>] EXTERNAL_SYMBOL]
16115 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16116 -- [, [Result_Type =>] SUBTYPE_MARK]
16117 -- [, [Mechanism =>] MECHANISM]
16118 -- [, [Result_Mechanism =>] MECHANISM_NAME]);
16120 -- EXTERNAL_SYMBOL ::=
16122 -- | static_string_EXPRESSION
16124 -- PARAMETER_TYPES ::=
16126 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16128 -- TYPE_DESIGNATOR ::=
16130 -- | subtype_Name ' Access
16134 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16136 -- MECHANISM_ASSOCIATION ::=
16137 -- [formal_parameter_NAME =>] MECHANISM_NAME
16139 -- MECHANISM_NAME ::=
16143 when Pragma_Import_Function
=> Import_Function
: declare
16144 Args
: Args_List
(1 .. 6);
16145 Names
: constant Name_List
(1 .. 6) := (
16148 Name_Parameter_Types
,
16151 Name_Result_Mechanism
);
16153 Internal
: Node_Id
renames Args
(1);
16154 External
: Node_Id
renames Args
(2);
16155 Parameter_Types
: Node_Id
renames Args
(3);
16156 Result_Type
: Node_Id
renames Args
(4);
16157 Mechanism
: Node_Id
renames Args
(5);
16158 Result_Mechanism
: Node_Id
renames Args
(6);
16162 Gather_Associations
(Names
, Args
);
16163 Process_Extended_Import_Export_Subprogram_Pragma
(
16164 Arg_Internal
=> Internal
,
16165 Arg_External
=> External
,
16166 Arg_Parameter_Types
=> Parameter_Types
,
16167 Arg_Result_Type
=> Result_Type
,
16168 Arg_Mechanism
=> Mechanism
,
16169 Arg_Result_Mechanism
=> Result_Mechanism
);
16170 end Import_Function
;
16172 -------------------
16173 -- Import_Object --
16174 -------------------
16176 -- pragma Import_Object (
16177 -- [Internal =>] LOCAL_NAME
16178 -- [, [External =>] EXTERNAL_SYMBOL]
16179 -- [, [Size =>] EXTERNAL_SYMBOL]);
16181 -- EXTERNAL_SYMBOL ::=
16183 -- | static_string_EXPRESSION
16185 when Pragma_Import_Object
=> Import_Object
: declare
16186 Args
: Args_List
(1 .. 3);
16187 Names
: constant Name_List
(1 .. 3) := (
16192 Internal
: Node_Id
renames Args
(1);
16193 External
: Node_Id
renames Args
(2);
16194 Size
: Node_Id
renames Args
(3);
16198 Gather_Associations
(Names
, Args
);
16199 Process_Extended_Import_Export_Object_Pragma
(
16200 Arg_Internal
=> Internal
,
16201 Arg_External
=> External
,
16205 ----------------------
16206 -- Import_Procedure --
16207 ----------------------
16209 -- pragma Import_Procedure (
16210 -- [Internal =>] LOCAL_NAME
16211 -- [, [External =>] EXTERNAL_SYMBOL]
16212 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16213 -- [, [Mechanism =>] MECHANISM]);
16215 -- EXTERNAL_SYMBOL ::=
16217 -- | static_string_EXPRESSION
16219 -- PARAMETER_TYPES ::=
16221 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16223 -- TYPE_DESIGNATOR ::=
16225 -- | subtype_Name ' Access
16229 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16231 -- MECHANISM_ASSOCIATION ::=
16232 -- [formal_parameter_NAME =>] MECHANISM_NAME
16234 -- MECHANISM_NAME ::=
16238 when Pragma_Import_Procedure
=> Import_Procedure
: declare
16239 Args
: Args_List
(1 .. 4);
16240 Names
: constant Name_List
(1 .. 4) := (
16243 Name_Parameter_Types
,
16246 Internal
: Node_Id
renames Args
(1);
16247 External
: Node_Id
renames Args
(2);
16248 Parameter_Types
: Node_Id
renames Args
(3);
16249 Mechanism
: Node_Id
renames Args
(4);
16253 Gather_Associations
(Names
, Args
);
16254 Process_Extended_Import_Export_Subprogram_Pragma
(
16255 Arg_Internal
=> Internal
,
16256 Arg_External
=> External
,
16257 Arg_Parameter_Types
=> Parameter_Types
,
16258 Arg_Mechanism
=> Mechanism
);
16259 end Import_Procedure
;
16261 -----------------------------
16262 -- Import_Valued_Procedure --
16263 -----------------------------
16265 -- pragma Import_Valued_Procedure (
16266 -- [Internal =>] LOCAL_NAME
16267 -- [, [External =>] EXTERNAL_SYMBOL]
16268 -- [, [Parameter_Types =>] (PARAMETER_TYPES)]
16269 -- [, [Mechanism =>] MECHANISM]);
16271 -- EXTERNAL_SYMBOL ::=
16273 -- | static_string_EXPRESSION
16275 -- PARAMETER_TYPES ::=
16277 -- | TYPE_DESIGNATOR @{, TYPE_DESIGNATOR@}
16279 -- TYPE_DESIGNATOR ::=
16281 -- | subtype_Name ' Access
16285 -- | (MECHANISM_ASSOCIATION @{, MECHANISM_ASSOCIATION@})
16287 -- MECHANISM_ASSOCIATION ::=
16288 -- [formal_parameter_NAME =>] MECHANISM_NAME
16290 -- MECHANISM_NAME ::=
16294 when Pragma_Import_Valued_Procedure
=>
16295 Import_Valued_Procedure
: declare
16296 Args
: Args_List
(1 .. 4);
16297 Names
: constant Name_List
(1 .. 4) := (
16300 Name_Parameter_Types
,
16303 Internal
: Node_Id
renames Args
(1);
16304 External
: Node_Id
renames Args
(2);
16305 Parameter_Types
: Node_Id
renames Args
(3);
16306 Mechanism
: Node_Id
renames Args
(4);
16310 Gather_Associations
(Names
, Args
);
16311 Process_Extended_Import_Export_Subprogram_Pragma
(
16312 Arg_Internal
=> Internal
,
16313 Arg_External
=> External
,
16314 Arg_Parameter_Types
=> Parameter_Types
,
16315 Arg_Mechanism
=> Mechanism
);
16316 end Import_Valued_Procedure
;
16322 -- pragma Independent (LOCAL_NAME);
16324 when Pragma_Independent
=>
16325 Process_Atomic_Independent_Shared_Volatile
;
16327 ----------------------------
16328 -- Independent_Components --
16329 ----------------------------
16331 -- pragma Independent_Components (array_or_record_LOCAL_NAME);
16333 when Pragma_Independent_Components
=> Independent_Components
: declare
16341 Check_Ada_83_Warning
;
16343 Check_No_Identifiers
;
16344 Check_Arg_Count
(1);
16345 Check_Arg_Is_Local_Name
(Arg1
);
16346 E_Id
:= Get_Pragma_Arg
(Arg1
);
16348 if Etype
(E_Id
) = Any_Type
then
16352 E
:= Entity
(E_Id
);
16354 -- A pragma that applies to a Ghost entity becomes Ghost for the
16355 -- purposes of legality checks and removal of ignored Ghost code.
16357 Mark_Ghost_Pragma
(N
, E
);
16359 -- Check duplicate before we chain ourselves
16361 Check_Duplicate_Pragma
(E
);
16363 -- Check appropriate entity
16365 if Rep_Item_Too_Early
(E
, N
)
16367 Rep_Item_Too_Late
(E
, N
)
16372 D
:= Declaration_Node
(E
);
16375 -- The flag is set on the base type, or on the object
16377 if K
= N_Full_Type_Declaration
16378 and then (Is_Array_Type
(E
) or else Is_Record_Type
(E
))
16380 Set_Has_Independent_Components
(Base_Type
(E
));
16381 Record_Independence_Check
(N
, Base_Type
(E
));
16383 -- For record type, set all components independent
16385 if Is_Record_Type
(E
) then
16386 C
:= First_Component
(E
);
16387 while Present
(C
) loop
16388 Set_Is_Independent
(C
);
16389 Next_Component
(C
);
16393 elsif (Ekind
(E
) = E_Constant
or else Ekind
(E
) = E_Variable
)
16394 and then Nkind
(D
) = N_Object_Declaration
16395 and then Nkind
(Object_Definition
(D
)) =
16396 N_Constrained_Array_Definition
16398 Set_Has_Independent_Components
(E
);
16399 Record_Independence_Check
(N
, E
);
16402 Error_Pragma_Arg
("inappropriate entity for pragma%", Arg1
);
16404 end Independent_Components
;
16406 -----------------------
16407 -- Initial_Condition --
16408 -----------------------
16410 -- pragma Initial_Condition (boolean_EXPRESSION);
16412 -- Characteristics:
16414 -- * Analysis - The annotation undergoes initial checks to verify
16415 -- the legal placement and context. Secondary checks preanalyze the
16418 -- Analyze_Initial_Condition_In_Decl_Part
16420 -- * Expansion - The annotation is expanded during the expansion of
16421 -- the package body whose declaration is subject to the annotation
16424 -- Expand_Pragma_Initial_Condition
16426 -- * Template - The annotation utilizes the generic template of the
16427 -- related package declaration.
16429 -- * Globals - Capture of global references must occur after full
16432 -- * Instance - The annotation is instantiated automatically when
16433 -- the related generic package is instantiated.
16435 when Pragma_Initial_Condition
=> Initial_Condition
: declare
16436 Pack_Decl
: Node_Id
;
16437 Pack_Id
: Entity_Id
;
16441 Check_No_Identifiers
;
16442 Check_Arg_Count
(1);
16444 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16446 -- Ensure the proper placement of the pragma. Initial_Condition
16447 -- must be associated with a package declaration.
16449 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16450 N_Package_Declaration
)
16454 -- Otherwise the pragma is associated with an illegal context
16461 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16463 -- A pragma that applies to a Ghost entity becomes Ghost for the
16464 -- purposes of legality checks and removal of ignored Ghost code.
16466 Mark_Ghost_Pragma
(N
, Pack_Id
);
16468 -- Chain the pragma on the contract for further processing by
16469 -- Analyze_Initial_Condition_In_Decl_Part.
16471 Add_Contract_Item
(N
, Pack_Id
);
16473 -- The legality checks of pragmas Abstract_State, Initializes, and
16474 -- Initial_Condition are affected by the SPARK mode in effect. In
16475 -- addition, these three pragmas are subject to an inherent order:
16477 -- 1) Abstract_State
16479 -- 3) Initial_Condition
16481 -- Analyze all these pragmas in the order outlined above
16483 Analyze_If_Present
(Pragma_SPARK_Mode
);
16484 Analyze_If_Present
(Pragma_Abstract_State
);
16485 Analyze_If_Present
(Pragma_Initializes
);
16486 end Initial_Condition
;
16488 ------------------------
16489 -- Initialize_Scalars --
16490 ------------------------
16492 -- pragma Initialize_Scalars;
16494 when Pragma_Initialize_Scalars
=>
16496 Check_Arg_Count
(0);
16497 Check_Valid_Configuration_Pragma
;
16498 Check_Restriction
(No_Initialize_Scalars
, N
);
16500 -- Initialize_Scalars creates false positives in CodePeer, and
16501 -- incorrect negative results in GNATprove mode, so ignore this
16502 -- pragma in these modes.
16504 if not Restriction_Active
(No_Initialize_Scalars
)
16505 and then not (CodePeer_Mode
or GNATprove_Mode
)
16507 Init_Or_Norm_Scalars
:= True;
16508 Initialize_Scalars
:= True;
16515 -- pragma Initializes (INITIALIZATION_LIST);
16517 -- INITIALIZATION_LIST ::=
16519 -- | (INITIALIZATION_ITEM {, INITIALIZATION_ITEM})
16521 -- INITIALIZATION_ITEM ::= name [=> INPUT_LIST]
16526 -- | (INPUT {, INPUT})
16530 -- Characteristics:
16532 -- * Analysis - The annotation undergoes initial checks to verify
16533 -- the legal placement and context. Secondary checks preanalyze the
16536 -- Analyze_Initializes_In_Decl_Part
16538 -- * Expansion - None.
16540 -- * Template - The annotation utilizes the generic template of the
16541 -- related package declaration.
16543 -- * Globals - Capture of global references must occur after full
16546 -- * Instance - The annotation is instantiated automatically when
16547 -- the related generic package is instantiated.
16549 when Pragma_Initializes
=> Initializes
: declare
16550 Pack_Decl
: Node_Id
;
16551 Pack_Id
: Entity_Id
;
16555 Check_No_Identifiers
;
16556 Check_Arg_Count
(1);
16558 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
16560 -- Ensure the proper placement of the pragma. Initializes must be
16561 -- associated with a package declaration.
16563 if Nkind_In
(Pack_Decl
, N_Generic_Package_Declaration
,
16564 N_Package_Declaration
)
16568 -- Otherwise the pragma is associated with an illegal construc
16575 Pack_Id
:= Defining_Entity
(Pack_Decl
);
16577 -- A pragma that applies to a Ghost entity becomes Ghost for the
16578 -- purposes of legality checks and removal of ignored Ghost code.
16580 Mark_Ghost_Pragma
(N
, Pack_Id
);
16581 Ensure_Aggregate_Form
(Get_Argument
(N
, Pack_Id
));
16583 -- Chain the pragma on the contract for further processing by
16584 -- Analyze_Initializes_In_Decl_Part.
16586 Add_Contract_Item
(N
, Pack_Id
);
16588 -- The legality checks of pragmas Abstract_State, Initializes, and
16589 -- Initial_Condition are affected by the SPARK mode in effect. In
16590 -- addition, these three pragmas are subject to an inherent order:
16592 -- 1) Abstract_State
16594 -- 3) Initial_Condition
16596 -- Analyze all these pragmas in the order outlined above
16598 Analyze_If_Present
(Pragma_SPARK_Mode
);
16599 Analyze_If_Present
(Pragma_Abstract_State
);
16600 Analyze_If_Present
(Pragma_Initial_Condition
);
16607 -- pragma Inline ( NAME {, NAME} );
16609 when Pragma_Inline
=>
16611 -- Pragma always active unless in GNATprove mode. It is disabled
16612 -- in GNATprove mode because frontend inlining is applied
16613 -- independently of pragmas Inline and Inline_Always for
16614 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode
16617 if not GNATprove_Mode
then
16619 -- Inline status is Enabled if option -gnatn is specified.
16620 -- However this status determines only the value of the
16621 -- Is_Inlined flag on the subprogram and does not prevent
16622 -- the pragma itself from being recorded for later use,
16623 -- in particular for a later modification of Is_Inlined
16624 -- independently of the -gnatn option.
16626 -- In other words, if -gnatn is specified for a unit, then
16627 -- all Inline pragmas processed for the compilation of this
16628 -- unit, including those in the spec of other units, are
16629 -- activated, so subprograms will be inlined across units.
16631 -- If -gnatn is not specified, no Inline pragma is activated
16632 -- here, which means that subprograms will not be inlined
16633 -- across units. The Is_Inlined flag will nevertheless be
16634 -- set later when bodies are analyzed, so subprograms will
16635 -- be inlined within the unit.
16637 if Inline_Active
then
16638 Process_Inline
(Enabled
);
16640 Process_Inline
(Disabled
);
16644 -------------------
16645 -- Inline_Always --
16646 -------------------
16648 -- pragma Inline_Always ( NAME {, NAME} );
16650 when Pragma_Inline_Always
=>
16653 -- Pragma always active unless in CodePeer mode or GNATprove
16654 -- mode. It is disabled in CodePeer mode because inlining is
16655 -- not helpful, and enabling it caused walk order issues. It
16656 -- is disabled in GNATprove mode because frontend inlining is
16657 -- applied independently of pragmas Inline and Inline_Always for
16658 -- formal verification, see Can_Be_Inlined_In_GNATprove_Mode in
16661 if not CodePeer_Mode
and not GNATprove_Mode
then
16662 Process_Inline
(Enabled
);
16665 --------------------
16666 -- Inline_Generic --
16667 --------------------
16669 -- pragma Inline_Generic (NAME {, NAME});
16671 when Pragma_Inline_Generic
=>
16673 Process_Generic_List
;
16675 ----------------------
16676 -- Inspection_Point --
16677 ----------------------
16679 -- pragma Inspection_Point [(object_NAME {, object_NAME})];
16681 when Pragma_Inspection_Point
=> Inspection_Point
: declare
16688 if Arg_Count
> 0 then
16691 Exp
:= Get_Pragma_Arg
(Arg
);
16694 if not Is_Entity_Name
(Exp
)
16695 or else not Is_Object
(Entity
(Exp
))
16697 Error_Pragma_Arg
("object name required", Arg
);
16701 exit when No
(Arg
);
16704 end Inspection_Point
;
16710 -- pragma Interface (
16711 -- [ Convention =>] convention_IDENTIFIER,
16712 -- [ Entity =>] LOCAL_NAME
16713 -- [, [External_Name =>] static_string_EXPRESSION ]
16714 -- [, [Link_Name =>] static_string_EXPRESSION ]);
16716 when Pragma_Interface
=>
16721 Name_External_Name
,
16723 Check_At_Least_N_Arguments
(2);
16724 Check_At_Most_N_Arguments
(4);
16725 Process_Import_Or_Interface
;
16727 -- In Ada 2005, the permission to use Interface (a reserved word)
16728 -- as a pragma name is considered an obsolescent feature, and this
16729 -- pragma was already obsolescent in Ada 95.
16731 if Ada_Version
>= Ada_95
then
16733 (No_Obsolescent_Features
, Pragma_Identifier
(N
));
16735 if Warn_On_Obsolescent_Feature
then
16737 ("pragma Interface is an obsolescent feature?j?", N
);
16739 ("|use pragma Import instead?j?", N
);
16743 --------------------
16744 -- Interface_Name --
16745 --------------------
16747 -- pragma Interface_Name (
16748 -- [ Entity =>] LOCAL_NAME
16749 -- [,[External_Name =>] static_string_EXPRESSION ]
16750 -- [,[Link_Name =>] static_string_EXPRESSION ]);
16752 when Pragma_Interface_Name
=> Interface_Name
: declare
16754 Def_Id
: Entity_Id
;
16755 Hom_Id
: Entity_Id
;
16761 ((Name_Entity
, Name_External_Name
, Name_Link_Name
));
16762 Check_At_Least_N_Arguments
(2);
16763 Check_At_Most_N_Arguments
(3);
16764 Id
:= Get_Pragma_Arg
(Arg1
);
16767 -- This is obsolete from Ada 95 on, but it is an implementation
16768 -- defined pragma, so we do not consider that it violates the
16769 -- restriction (No_Obsolescent_Features).
16771 if Ada_Version
>= Ada_95
then
16772 if Warn_On_Obsolescent_Feature
then
16774 ("pragma Interface_Name is an obsolescent feature?j?", N
);
16776 ("|use pragma Import instead?j?", N
);
16780 if not Is_Entity_Name
(Id
) then
16782 ("first argument for pragma% must be entity name", Arg1
);
16783 elsif Etype
(Id
) = Any_Type
then
16786 Def_Id
:= Entity
(Id
);
16789 -- Special DEC-compatible processing for the object case, forces
16790 -- object to be imported.
16792 if Ekind
(Def_Id
) = E_Variable
then
16793 Kill_Size_Check_Code
(Def_Id
);
16794 Note_Possible_Modification
(Id
, Sure
=> False);
16796 -- Initialization is not allowed for imported variable
16798 if Present
(Expression
(Parent
(Def_Id
)))
16799 and then Comes_From_Source
(Expression
(Parent
(Def_Id
)))
16801 Error_Msg_Sloc
:= Sloc
(Def_Id
);
16803 ("no initialization allowed for declaration of& #",
16807 -- For compatibility, support VADS usage of providing both
16808 -- pragmas Interface and Interface_Name to obtain the effect
16809 -- of a single Import pragma.
16811 if Is_Imported
(Def_Id
)
16812 and then Present
(First_Rep_Item
(Def_Id
))
16813 and then Nkind
(First_Rep_Item
(Def_Id
)) = N_Pragma
16814 and then Pragma_Name
(First_Rep_Item
(Def_Id
)) =
16819 Set_Imported
(Def_Id
);
16822 Set_Is_Public
(Def_Id
);
16823 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
16826 -- Otherwise must be subprogram
16828 elsif not Is_Subprogram
(Def_Id
) then
16830 ("argument of pragma% is not subprogram", Arg1
);
16833 Check_At_Most_N_Arguments
(3);
16837 -- Loop through homonyms
16840 Def_Id
:= Get_Base_Subprogram
(Hom_Id
);
16842 if Is_Imported
(Def_Id
) then
16843 Process_Interface_Name
(Def_Id
, Arg2
, Arg3
, N
);
16847 exit when From_Aspect_Specification
(N
);
16848 Hom_Id
:= Homonym
(Hom_Id
);
16850 exit when No
(Hom_Id
)
16851 or else Scope
(Hom_Id
) /= Current_Scope
;
16856 ("argument of pragma% is not imported subprogram",
16860 end Interface_Name
;
16862 -----------------------
16863 -- Interrupt_Handler --
16864 -----------------------
16866 -- pragma Interrupt_Handler (handler_NAME);
16868 when Pragma_Interrupt_Handler
=>
16869 Check_Ada_83_Warning
;
16870 Check_Arg_Count
(1);
16871 Check_No_Identifiers
;
16873 if No_Run_Time_Mode
then
16874 Error_Msg_CRT
("Interrupt_Handler pragma", N
);
16876 Check_Interrupt_Or_Attach_Handler
;
16877 Process_Interrupt_Or_Attach_Handler
;
16880 ------------------------
16881 -- Interrupt_Priority --
16882 ------------------------
16884 -- pragma Interrupt_Priority [(EXPRESSION)];
16886 when Pragma_Interrupt_Priority
=> Interrupt_Priority
: declare
16887 P
: constant Node_Id
:= Parent
(N
);
16892 Check_Ada_83_Warning
;
16894 if Arg_Count
/= 0 then
16895 Arg
:= Get_Pragma_Arg
(Arg1
);
16896 Check_Arg_Count
(1);
16897 Check_No_Identifiers
;
16899 -- The expression must be analyzed in the special manner
16900 -- described in "Handling of Default and Per-Object
16901 -- Expressions" in sem.ads.
16903 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Interrupt_Priority
));
16906 if not Nkind_In
(P
, N_Task_Definition
, N_Protected_Definition
) then
16911 Ent
:= Defining_Identifier
(Parent
(P
));
16913 -- Check duplicate pragma before we chain the pragma in the Rep
16914 -- Item chain of Ent.
16916 Check_Duplicate_Pragma
(Ent
);
16917 Record_Rep_Item
(Ent
, N
);
16919 -- Check the No_Task_At_Interrupt_Priority restriction
16921 if Nkind
(P
) = N_Task_Definition
then
16922 Check_Restriction
(No_Task_At_Interrupt_Priority
, N
);
16925 end Interrupt_Priority
;
16927 ---------------------
16928 -- Interrupt_State --
16929 ---------------------
16931 -- pragma Interrupt_State (
16932 -- [Name =>] INTERRUPT_ID,
16933 -- [State =>] INTERRUPT_STATE);
16935 -- INTERRUPT_ID => IDENTIFIER | static_integer_EXPRESSION
16936 -- INTERRUPT_STATE => System | Runtime | User
16938 -- Note: if the interrupt id is given as an identifier, then it must
16939 -- be one of the identifiers in Ada.Interrupts.Names. Otherwise it is
16940 -- given as a static integer expression which must be in the range of
16941 -- Ada.Interrupts.Interrupt_ID.
16943 when Pragma_Interrupt_State
=> Interrupt_State
: declare
16944 Int_Id
: constant Entity_Id
:= RTE
(RE_Interrupt_ID
);
16945 -- This is the entity Ada.Interrupts.Interrupt_ID;
16947 State_Type
: Character;
16948 -- Set to 's'/'r'/'u' for System/Runtime/User
16951 -- Index to entry in Interrupt_States table
16954 -- Value of interrupt
16956 Arg1X
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
16957 -- The first argument to the pragma
16959 Int_Ent
: Entity_Id
;
16960 -- Interrupt entity in Ada.Interrupts.Names
16964 Check_Arg_Order
((Name_Name
, Name_State
));
16965 Check_Arg_Count
(2);
16967 Check_Optional_Identifier
(Arg1
, Name_Name
);
16968 Check_Optional_Identifier
(Arg2
, Name_State
);
16969 Check_Arg_Is_Identifier
(Arg2
);
16971 -- First argument is identifier
16973 if Nkind
(Arg1X
) = N_Identifier
then
16975 -- Search list of names in Ada.Interrupts.Names
16977 Int_Ent
:= First_Entity
(RTE
(RE_Names
));
16979 if No
(Int_Ent
) then
16980 Error_Pragma_Arg
("invalid interrupt name", Arg1
);
16982 elsif Chars
(Int_Ent
) = Chars
(Arg1X
) then
16983 Int_Val
:= Expr_Value
(Constant_Value
(Int_Ent
));
16987 Next_Entity
(Int_Ent
);
16990 -- First argument is not an identifier, so it must be a static
16991 -- expression of type Ada.Interrupts.Interrupt_ID.
16994 Check_Arg_Is_OK_Static_Expression
(Arg1
, Any_Integer
);
16995 Int_Val
:= Expr_Value
(Arg1X
);
16997 if Int_Val
< Expr_Value
(Type_Low_Bound
(Int_Id
))
16999 Int_Val
> Expr_Value
(Type_High_Bound
(Int_Id
))
17002 ("value not in range of type "
17003 & """Ada.Interrupts.Interrupt_'I'D""", Arg1
);
17009 case Chars
(Get_Pragma_Arg
(Arg2
)) is
17010 when Name_Runtime
=> State_Type
:= 'r';
17011 when Name_System
=> State_Type
:= 's';
17012 when Name_User
=> State_Type
:= 'u';
17015 Error_Pragma_Arg
("invalid interrupt state", Arg2
);
17018 -- Check if entry is already stored
17020 IST_Num
:= Interrupt_States
.First
;
17022 -- If entry not found, add it
17024 if IST_Num
> Interrupt_States
.Last
then
17025 Interrupt_States
.Append
17026 ((Interrupt_Number
=> UI_To_Int
(Int_Val
),
17027 Interrupt_State
=> State_Type
,
17028 Pragma_Loc
=> Loc
));
17031 -- Case of entry for the same entry
17033 elsif Int_Val
= Interrupt_States
.Table
(IST_Num
).
17036 -- If state matches, done, no need to make redundant entry
17039 State_Type
= Interrupt_States
.Table
(IST_Num
).
17042 -- Otherwise if state does not match, error
17045 Interrupt_States
.Table
(IST_Num
).Pragma_Loc
;
17047 ("state conflicts with that given #", Arg2
);
17051 IST_Num
:= IST_Num
+ 1;
17053 end Interrupt_State
;
17059 -- pragma Invariant
17060 -- ([Entity =>] type_LOCAL_NAME,
17061 -- [Check =>] EXPRESSION
17062 -- [,[Message =>] String_Expression]);
17064 when Pragma_Invariant
=> Invariant
: declare
17071 Check_At_Least_N_Arguments
(2);
17072 Check_At_Most_N_Arguments
(3);
17073 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17074 Check_Optional_Identifier
(Arg2
, Name_Check
);
17076 if Arg_Count
= 3 then
17077 Check_Optional_Identifier
(Arg3
, Name_Message
);
17078 Check_Arg_Is_OK_Static_Expression
(Arg3
, Standard_String
);
17081 Check_Arg_Is_Local_Name
(Arg1
);
17083 Typ_Arg
:= Get_Pragma_Arg
(Arg1
);
17084 Find_Type
(Typ_Arg
);
17085 Typ
:= Entity
(Typ_Arg
);
17087 -- Nothing to do of the related type is erroneous in some way
17089 if Typ
= Any_Type
then
17092 -- AI12-0041: Invariants are allowed in interface types
17094 elsif Is_Interface
(Typ
) then
17097 -- An invariant must apply to a private type, or appear in the
17098 -- private part of a package spec and apply to a completion.
17099 -- a class-wide invariant can only appear on a private declaration
17100 -- or private extension, not a completion.
17102 -- A [class-wide] invariant may be associated a [limited] private
17103 -- type or a private extension.
17105 elsif Ekind_In
(Typ
, E_Limited_Private_Type
,
17107 E_Record_Type_With_Private
)
17111 -- A non-class-wide invariant may be associated with the full view
17112 -- of a [limited] private type or a private extension.
17114 elsif Has_Private_Declaration
(Typ
)
17115 and then not Class_Present
(N
)
17119 -- A class-wide invariant may appear on the partial view only
17121 elsif Class_Present
(N
) then
17123 ("pragma % only allowed for private type", Arg1
);
17126 -- A regular invariant may appear on both views
17130 ("pragma % only allowed for private type or corresponding "
17131 & "full view", Arg1
);
17135 -- An invariant associated with an abstract type (this includes
17136 -- interfaces) must be class-wide.
17138 if Is_Abstract_Type
(Typ
) and then not Class_Present
(N
) then
17140 ("pragma % not allowed for abstract type", Arg1
);
17144 -- A pragma that applies to a Ghost entity becomes Ghost for the
17145 -- purposes of legality checks and removal of ignored Ghost code.
17147 Mark_Ghost_Pragma
(N
, Typ
);
17149 -- The pragma defines a type-specific invariant, the type is said
17150 -- to have invariants of its "own".
17152 Set_Has_Own_Invariants
(Typ
);
17154 -- If the invariant is class-wide, then it can be inherited by
17155 -- derived or interface implementing types. The type is said to
17156 -- have "inheritable" invariants.
17158 if Class_Present
(N
) then
17159 Set_Has_Inheritable_Invariants
(Typ
);
17162 -- Chain the pragma on to the rep item chain, for processing when
17163 -- the type is frozen.
17165 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
17167 -- Create the declaration of the invariant procedure that will
17168 -- verify the invariant at run time. Interfaces are treated as the
17169 -- partial view of a private type in order to achieve uniformity
17170 -- with the general case. As a result, an interface receives only
17171 -- a "partial" invariant procedure, which is never called.
17173 Build_Invariant_Procedure_Declaration
17175 Partial_Invariant
=> Is_Interface
(Typ
));
17182 -- pragma Keep_Names ([On => ] LOCAL_NAME);
17184 when Pragma_Keep_Names
=> Keep_Names
: declare
17189 Check_Arg_Count
(1);
17190 Check_Optional_Identifier
(Arg1
, Name_On
);
17191 Check_Arg_Is_Local_Name
(Arg1
);
17193 Arg
:= Get_Pragma_Arg
(Arg1
);
17196 if Etype
(Arg
) = Any_Type
then
17200 if not Is_Entity_Name
(Arg
)
17201 or else Ekind
(Entity
(Arg
)) /= E_Enumeration_Type
17204 ("pragma% requires a local enumeration type", Arg1
);
17207 Set_Discard_Names
(Entity
(Arg
), False);
17214 -- pragma License (RESTRICTED | UNRESTRICTED | GPL | MODIFIED_GPL);
17216 when Pragma_License
=>
17219 -- Do not analyze pragma any further in CodePeer mode, to avoid
17220 -- extraneous errors in this implementation-dependent pragma,
17221 -- which has a different profile on other compilers.
17223 if CodePeer_Mode
then
17227 Check_Arg_Count
(1);
17228 Check_No_Identifiers
;
17229 Check_Valid_Configuration_Pragma
;
17230 Check_Arg_Is_Identifier
(Arg1
);
17233 Sind
: constant Source_File_Index
:=
17234 Source_Index
(Current_Sem_Unit
);
17237 case Chars
(Get_Pragma_Arg
(Arg1
)) is
17239 Set_License
(Sind
, GPL
);
17241 when Name_Modified_GPL
=>
17242 Set_License
(Sind
, Modified_GPL
);
17244 when Name_Restricted
=>
17245 Set_License
(Sind
, Restricted
);
17247 when Name_Unrestricted
=>
17248 Set_License
(Sind
, Unrestricted
);
17251 Error_Pragma_Arg
("invalid license name", Arg1
);
17259 -- pragma Link_With (string_EXPRESSION {, string_EXPRESSION});
17261 when Pragma_Link_With
=> Link_With
: declare
17267 if Operating_Mode
= Generate_Code
17268 and then In_Extended_Main_Source_Unit
(N
)
17270 Check_At_Least_N_Arguments
(1);
17271 Check_No_Identifiers
;
17272 Check_Is_In_Decl_Part_Or_Package_Spec
;
17273 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17277 while Present
(Arg
) loop
17278 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17280 -- Store argument, converting sequences of spaces to a
17281 -- single null character (this is one of the differences
17282 -- in processing between Link_With and Linker_Options).
17284 Arg_Store
: declare
17285 C
: constant Char_Code
:= Get_Char_Code
(' ');
17286 S
: constant String_Id
:=
17287 Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
)));
17288 L
: constant Nat
:= String_Length
(S
);
17291 procedure Skip_Spaces
;
17292 -- Advance F past any spaces
17298 procedure Skip_Spaces
is
17300 while F
<= L
and then Get_String_Char
(S
, F
) = C
loop
17305 -- Start of processing for Arg_Store
17308 Skip_Spaces
; -- skip leading spaces
17310 -- Loop through characters, changing any embedded
17311 -- sequence of spaces to a single null character (this
17312 -- is how Link_With/Linker_Options differ)
17315 if Get_String_Char
(S
, F
) = C
then
17318 Store_String_Char
(ASCII
.NUL
);
17321 Store_String_Char
(Get_String_Char
(S
, F
));
17329 if Present
(Arg
) then
17330 Store_String_Char
(ASCII
.NUL
);
17334 Store_Linker_Option_String
(End_String
);
17342 -- pragma Linker_Alias (
17343 -- [Entity =>] LOCAL_NAME
17344 -- [Target =>] static_string_EXPRESSION);
17346 when Pragma_Linker_Alias
=>
17348 Check_Arg_Order
((Name_Entity
, Name_Target
));
17349 Check_Arg_Count
(2);
17350 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17351 Check_Optional_Identifier
(Arg2
, Name_Target
);
17352 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17353 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17355 -- The only processing required is to link this item on to the
17356 -- list of rep items for the given entity. This is accomplished
17357 -- by the call to Rep_Item_Too_Late (when no error is detected
17358 -- and False is returned).
17360 if Rep_Item_Too_Late
(Entity
(Get_Pragma_Arg
(Arg1
)), N
) then
17363 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17366 ------------------------
17367 -- Linker_Constructor --
17368 ------------------------
17370 -- pragma Linker_Constructor (procedure_LOCAL_NAME);
17372 -- Code is shared with Linker_Destructor
17374 -----------------------
17375 -- Linker_Destructor --
17376 -----------------------
17378 -- pragma Linker_Destructor (procedure_LOCAL_NAME);
17380 when Pragma_Linker_Constructor
17381 | Pragma_Linker_Destructor
17383 Linker_Constructor
: declare
17389 Check_Arg_Count
(1);
17390 Check_No_Identifiers
;
17391 Check_Arg_Is_Local_Name
(Arg1
);
17392 Arg1_X
:= Get_Pragma_Arg
(Arg1
);
17394 Proc
:= Find_Unique_Parameterless_Procedure
(Arg1_X
, Arg1
);
17396 if not Is_Library_Level_Entity
(Proc
) then
17398 ("argument for pragma% must be library level entity", Arg1
);
17401 -- The only processing required is to link this item on to the
17402 -- list of rep items for the given entity. This is accomplished
17403 -- by the call to Rep_Item_Too_Late (when no error is detected
17404 -- and False is returned).
17406 if Rep_Item_Too_Late
(Proc
, N
) then
17409 Set_Has_Gigi_Rep_Item
(Proc
);
17411 end Linker_Constructor
;
17413 --------------------
17414 -- Linker_Options --
17415 --------------------
17417 -- pragma Linker_Options (string_EXPRESSION {, string_EXPRESSION});
17419 when Pragma_Linker_Options
=> Linker_Options
: declare
17423 Check_Ada_83_Warning
;
17424 Check_No_Identifiers
;
17425 Check_Arg_Count
(1);
17426 Check_Is_In_Decl_Part_Or_Package_Spec
;
17427 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
17428 Start_String
(Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg1
))));
17431 while Present
(Arg
) loop
17432 Check_Arg_Is_OK_Static_Expression
(Arg
, Standard_String
);
17433 Store_String_Char
(ASCII
.NUL
);
17435 (Strval
(Expr_Value_S
(Get_Pragma_Arg
(Arg
))));
17439 if Operating_Mode
= Generate_Code
17440 and then In_Extended_Main_Source_Unit
(N
)
17442 Store_Linker_Option_String
(End_String
);
17444 end Linker_Options
;
17446 --------------------
17447 -- Linker_Section --
17448 --------------------
17450 -- pragma Linker_Section (
17451 -- [Entity =>] LOCAL_NAME
17452 -- [Section =>] static_string_EXPRESSION);
17454 when Pragma_Linker_Section
=> Linker_Section
: declare
17459 Ghost_Error_Posted
: Boolean := False;
17460 -- Flag set when an error concerning the illegal mix of Ghost and
17461 -- non-Ghost subprograms is emitted.
17463 Ghost_Id
: Entity_Id
:= Empty
;
17464 -- The entity of the first Ghost subprogram encountered while
17465 -- processing the arguments of the pragma.
17469 Check_Arg_Order
((Name_Entity
, Name_Section
));
17470 Check_Arg_Count
(2);
17471 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17472 Check_Optional_Identifier
(Arg2
, Name_Section
);
17473 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
17474 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17476 -- Check kind of entity
17478 Arg
:= Get_Pragma_Arg
(Arg1
);
17479 Ent
:= Entity
(Arg
);
17481 case Ekind
(Ent
) is
17483 -- Objects (constants and variables) and types. For these cases
17484 -- all we need to do is to set the Linker_Section_pragma field,
17485 -- checking that we do not have a duplicate.
17491 LPE
:= Linker_Section_Pragma
(Ent
);
17493 if Present
(LPE
) then
17494 Error_Msg_Sloc
:= Sloc
(LPE
);
17496 ("Linker_Section already specified for &#", Arg1
, Ent
);
17499 Set_Linker_Section_Pragma
(Ent
, N
);
17501 -- A pragma that applies to a Ghost entity becomes Ghost for
17502 -- the purposes of legality checks and removal of ignored
17505 Mark_Ghost_Pragma
(N
, Ent
);
17509 when Subprogram_Kind
=>
17511 -- Aspect case, entity already set
17513 if From_Aspect_Specification
(N
) then
17514 Set_Linker_Section_Pragma
17515 (Entity
(Corresponding_Aspect
(N
)), N
);
17517 -- Pragma case, we must climb the homonym chain, but skip
17518 -- any for which the linker section is already set.
17522 if No
(Linker_Section_Pragma
(Ent
)) then
17523 Set_Linker_Section_Pragma
(Ent
, N
);
17525 -- A pragma that applies to a Ghost entity becomes
17526 -- Ghost for the purposes of legality checks and
17527 -- removal of ignored Ghost code.
17529 Mark_Ghost_Pragma
(N
, Ent
);
17531 -- Capture the entity of the first Ghost subprogram
17532 -- being processed for error detection purposes.
17534 if Is_Ghost_Entity
(Ent
) then
17535 if No
(Ghost_Id
) then
17539 -- Otherwise the subprogram is non-Ghost. It is
17540 -- illegal to mix references to Ghost and non-Ghost
17541 -- entities (SPARK RM 6.9).
17543 elsif Present
(Ghost_Id
)
17544 and then not Ghost_Error_Posted
17546 Ghost_Error_Posted
:= True;
17548 Error_Msg_Name_1
:= Pname
;
17550 ("pragma % cannot mention ghost and "
17551 & "non-ghost subprograms", N
);
17553 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
17555 ("\& # declared as ghost", N
, Ghost_Id
);
17557 Error_Msg_Sloc
:= Sloc
(Ent
);
17559 ("\& # declared as non-ghost", N
, Ent
);
17563 Ent
:= Homonym
(Ent
);
17565 or else Scope
(Ent
) /= Current_Scope
;
17569 -- All other cases are illegal
17573 ("pragma% applies only to objects, subprograms, and types",
17576 end Linker_Section
;
17582 -- pragma List (On | Off)
17584 -- There is nothing to do here, since we did all the processing for
17585 -- this pragma in Par.Prag (so that it works properly even in syntax
17588 when Pragma_List
=>
17595 -- pragma Lock_Free [(Boolean_EXPRESSION)];
17597 when Pragma_Lock_Free
=> Lock_Free
: declare
17598 P
: constant Node_Id
:= Parent
(N
);
17604 Check_No_Identifiers
;
17605 Check_At_Most_N_Arguments
(1);
17607 -- Protected definition case
17609 if Nkind
(P
) = N_Protected_Definition
then
17610 Ent
:= Defining_Identifier
(Parent
(P
));
17614 if Arg_Count
= 1 then
17615 Arg
:= Get_Pragma_Arg
(Arg1
);
17616 Val
:= Is_True
(Static_Boolean
(Arg
));
17618 -- No arguments (expression is considered to be True)
17624 -- Check duplicate pragma before we chain the pragma in the Rep
17625 -- Item chain of Ent.
17627 Check_Duplicate_Pragma
(Ent
);
17628 Record_Rep_Item
(Ent
, N
);
17629 Set_Uses_Lock_Free
(Ent
, Val
);
17631 -- Anything else is incorrect placement
17638 --------------------
17639 -- Locking_Policy --
17640 --------------------
17642 -- pragma Locking_Policy (policy_IDENTIFIER);
17644 when Pragma_Locking_Policy
=> declare
17645 subtype LP_Range
is Name_Id
17646 range First_Locking_Policy_Name
.. Last_Locking_Policy_Name
;
17651 Check_Ada_83_Warning
;
17652 Check_Arg_Count
(1);
17653 Check_No_Identifiers
;
17654 Check_Arg_Is_Locking_Policy
(Arg1
);
17655 Check_Valid_Configuration_Pragma
;
17656 LP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
17659 when Name_Ceiling_Locking
=> LP
:= 'C';
17660 when Name_Concurrent_Readers_Locking
=> LP
:= 'R';
17661 when Name_Inheritance_Locking
=> LP
:= 'I';
17664 if Locking_Policy
/= ' '
17665 and then Locking_Policy
/= LP
17667 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
17668 Error_Pragma
("locking policy incompatible with policy#");
17670 -- Set new policy, but always preserve System_Location since we
17671 -- like the error message with the run time name.
17674 Locking_Policy
:= LP
;
17676 if Locking_Policy_Sloc
/= System_Location
then
17677 Locking_Policy_Sloc
:= Loc
;
17682 -------------------
17683 -- Loop_Optimize --
17684 -------------------
17686 -- pragma Loop_Optimize ( OPTIMIZATION_HINT {, OPTIMIZATION_HINT } );
17688 -- OPTIMIZATION_HINT ::=
17689 -- Ivdep | No_Unroll | Unroll | No_Vector | Vector
17691 when Pragma_Loop_Optimize
=> Loop_Optimize
: declare
17696 Check_At_Least_N_Arguments
(1);
17697 Check_No_Identifiers
;
17699 Hint
:= First
(Pragma_Argument_Associations
(N
));
17700 while Present
(Hint
) loop
17701 Check_Arg_Is_One_Of
(Hint
, Name_Ivdep
,
17709 Check_Loop_Pragma_Placement
;
17716 -- pragma Loop_Variant
17717 -- ( LOOP_VARIANT_ITEM {, LOOP_VARIANT_ITEM } );
17719 -- LOOP_VARIANT_ITEM ::= CHANGE_DIRECTION => discrete_EXPRESSION
17721 -- CHANGE_DIRECTION ::= Increases | Decreases
17723 when Pragma_Loop_Variant
=> Loop_Variant
: declare
17728 Check_At_Least_N_Arguments
(1);
17729 Check_Loop_Pragma_Placement
;
17731 -- Process all increasing / decreasing expressions
17733 Variant
:= First
(Pragma_Argument_Associations
(N
));
17734 while Present
(Variant
) loop
17735 if not Nam_In
(Chars
(Variant
), Name_Decreases
,
17738 Error_Pragma_Arg
("wrong change modifier", Variant
);
17741 Preanalyze_Assert_Expression
17742 (Expression
(Variant
), Any_Discrete
);
17748 -----------------------
17749 -- Machine_Attribute --
17750 -----------------------
17752 -- pragma Machine_Attribute (
17753 -- [Entity =>] LOCAL_NAME,
17754 -- [Attribute_Name =>] static_string_EXPRESSION
17755 -- [, [Info =>] static_EXPRESSION] );
17757 when Pragma_Machine_Attribute
=> Machine_Attribute
: declare
17758 Def_Id
: Entity_Id
;
17762 Check_Arg_Order
((Name_Entity
, Name_Attribute_Name
, Name_Info
));
17764 if Arg_Count
= 3 then
17765 Check_Optional_Identifier
(Arg3
, Name_Info
);
17766 Check_Arg_Is_OK_Static_Expression
(Arg3
);
17768 Check_Arg_Count
(2);
17771 Check_Optional_Identifier
(Arg1
, Name_Entity
);
17772 Check_Optional_Identifier
(Arg2
, Name_Attribute_Name
);
17773 Check_Arg_Is_Local_Name
(Arg1
);
17774 Check_Arg_Is_OK_Static_Expression
(Arg2
, Standard_String
);
17775 Def_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
17777 if Is_Access_Type
(Def_Id
) then
17778 Def_Id
:= Designated_Type
(Def_Id
);
17781 if Rep_Item_Too_Early
(Def_Id
, N
) then
17785 Def_Id
:= Underlying_Type
(Def_Id
);
17787 -- The only processing required is to link this item on to the
17788 -- list of rep items for the given entity. This is accomplished
17789 -- by the call to Rep_Item_Too_Late (when no error is detected
17790 -- and False is returned).
17792 if Rep_Item_Too_Late
(Def_Id
, N
) then
17795 Set_Has_Gigi_Rep_Item
(Entity
(Get_Pragma_Arg
(Arg1
)));
17797 end Machine_Attribute
;
17804 -- (MAIN_OPTION [, MAIN_OPTION]);
17807 -- [STACK_SIZE =>] static_integer_EXPRESSION
17808 -- | [TASK_STACK_SIZE_DEFAULT =>] static_integer_EXPRESSION
17809 -- | [TIME_SLICING_ENABLED =>] static_boolean_EXPRESSION
17811 when Pragma_Main
=> Main
: declare
17812 Args
: Args_List
(1 .. 3);
17813 Names
: constant Name_List
(1 .. 3) := (
17815 Name_Task_Stack_Size_Default
,
17816 Name_Time_Slicing_Enabled
);
17822 Gather_Associations
(Names
, Args
);
17824 for J
in 1 .. 2 loop
17825 if Present
(Args
(J
)) then
17826 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17830 if Present
(Args
(3)) then
17831 Check_Arg_Is_OK_Static_Expression
(Args
(3), Standard_Boolean
);
17835 while Present
(Nod
) loop
17836 if Nkind
(Nod
) = N_Pragma
17837 and then Pragma_Name
(Nod
) = Name_Main
17839 Error_Msg_Name_1
:= Pname
;
17840 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17851 -- pragma Main_Storage
17852 -- (MAIN_STORAGE_OPTION [, MAIN_STORAGE_OPTION]);
17854 -- MAIN_STORAGE_OPTION ::=
17855 -- [WORKING_STORAGE =>] static_SIMPLE_EXPRESSION
17856 -- | [TOP_GUARD =>] static_SIMPLE_EXPRESSION
17858 when Pragma_Main_Storage
=> Main_Storage
: declare
17859 Args
: Args_List
(1 .. 2);
17860 Names
: constant Name_List
(1 .. 2) := (
17861 Name_Working_Storage
,
17868 Gather_Associations
(Names
, Args
);
17870 for J
in 1 .. 2 loop
17871 if Present
(Args
(J
)) then
17872 Check_Arg_Is_OK_Static_Expression
(Args
(J
), Any_Integer
);
17876 Check_In_Main_Program
;
17879 while Present
(Nod
) loop
17880 if Nkind
(Nod
) = N_Pragma
17881 and then Pragma_Name
(Nod
) = Name_Main_Storage
17883 Error_Msg_Name_1
:= Pname
;
17884 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
17891 ----------------------
17892 -- Max_Queue_Length --
17893 ----------------------
17895 -- pragma Max_Queue_Length (static_integer_EXPRESSION);
17897 when Pragma_Max_Queue_Length
=> Max_Queue_Length
: declare
17899 Entry_Decl
: Node_Id
;
17900 Entry_Id
: Entity_Id
;
17905 Check_Arg_Count
(1);
17908 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
17910 -- Entry declaration
17912 if Nkind
(Entry_Decl
) = N_Entry_Declaration
then
17914 -- Entry illegally within a task
17916 if Nkind
(Parent
(N
)) = N_Task_Definition
then
17917 Error_Pragma
("pragma % cannot apply to task entries");
17921 Entry_Id
:= Unique_Defining_Entity
(Entry_Decl
);
17923 -- Otherwise the pragma is associated with an illegal construct
17926 Error_Pragma
("pragma % must apply to a protected entry");
17930 -- Mark the pragma as Ghost if the related subprogram is also
17931 -- Ghost. This also ensures that any expansion performed further
17932 -- below will produce Ghost nodes.
17934 Mark_Ghost_Pragma
(N
, Entry_Id
);
17936 -- Analyze the Integer expression
17938 Arg
:= Get_Pragma_Arg
(Arg1
);
17939 Check_Arg_Is_OK_Static_Expression
(Arg
, Any_Integer
);
17941 Val
:= Expr_Value
(Arg
);
17945 ("argument for pragma% must be positive", Arg1
);
17947 elsif not UI_Is_In_Int_Range
(Val
) then
17949 ("argument for pragma% out of range of Integer", Arg1
);
17953 -- Manually substitute the expression value of the pragma argument
17954 -- if it's not an integer literal because this is not taken care
17955 -- of automatically elsewhere.
17957 if Nkind
(Arg
) /= N_Integer_Literal
then
17958 Rewrite
(Arg
, Make_Integer_Literal
(Sloc
(Arg
), Val
));
17961 Record_Rep_Item
(Entry_Id
, N
);
17962 end Max_Queue_Length
;
17968 -- pragma Memory_Size (NUMERIC_LITERAL)
17970 when Pragma_Memory_Size
=>
17973 -- Memory size is simply ignored
17975 Check_No_Identifiers
;
17976 Check_Arg_Count
(1);
17977 Check_Arg_Is_Integer_Literal
(Arg1
);
17985 -- The only correct use of this pragma is on its own in a file, in
17986 -- which case it is specially processed (see Gnat1drv.Check_Bad_Body
17987 -- and Frontend, which use Sinput.L.Source_File_Is_Pragma_No_Body to
17988 -- check for a file containing nothing but a No_Body pragma). If we
17989 -- attempt to process it during normal semantics processing, it means
17990 -- it was misplaced.
17992 when Pragma_No_Body
=>
17996 -----------------------------
17997 -- No_Elaboration_Code_All --
17998 -----------------------------
18000 -- pragma No_Elaboration_Code_All;
18002 when Pragma_No_Elaboration_Code_All
=>
18004 Check_Valid_Library_Unit_Pragma
;
18006 if Nkind
(N
) = N_Null_Statement
then
18010 -- Must appear for a spec or generic spec
18012 if not Nkind_In
(Unit
(Cunit
(Current_Sem_Unit
)),
18013 N_Generic_Package_Declaration
,
18014 N_Generic_Subprogram_Declaration
,
18015 N_Package_Declaration
,
18016 N_Subprogram_Declaration
)
18020 ("pragma% can only occur for package "
18021 & "or subprogram spec"));
18024 -- Set flag in unit table
18026 Set_No_Elab_Code_All
(Current_Sem_Unit
);
18028 -- Set restriction No_Elaboration_Code if this is the main unit
18030 if Current_Sem_Unit
= Main_Unit
then
18031 Set_Restriction
(No_Elaboration_Code
, N
);
18034 -- If we are in the main unit or in an extended main source unit,
18035 -- then we also add it to the configuration restrictions so that
18036 -- it will apply to all units in the extended main source.
18038 if Current_Sem_Unit
= Main_Unit
18039 or else In_Extended_Main_Source_Unit
(N
)
18041 Add_To_Config_Boolean_Restrictions
(No_Elaboration_Code
);
18044 -- If in main extended unit, activate transitive with test
18046 if In_Extended_Main_Source_Unit
(N
) then
18047 Opt
.No_Elab_Code_All_Pragma
:= N
;
18050 --------------------------
18051 -- No_Heap_Finalization --
18052 --------------------------
18054 -- pragma No_Heap_Finalization [ (first_subtype_LOCAL_NAME) ];
18056 when Pragma_No_Heap_Finalization
=> No_Heap_Finalization
: declare
18057 Context
: constant Node_Id
:= Parent
(N
);
18058 Typ_Arg
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
18064 Check_No_Identifiers
;
18066 -- The pragma appears in a configuration file
18068 if No
(Context
) then
18069 Check_Arg_Count
(0);
18070 Check_Valid_Configuration_Pragma
;
18072 -- Detect a duplicate pragma
18074 if Present
(No_Heap_Finalization_Pragma
) then
18077 Prev
=> No_Heap_Finalization_Pragma
);
18081 No_Heap_Finalization_Pragma
:= N
;
18083 -- Otherwise the pragma should be associated with a library-level
18084 -- named access-to-object type.
18087 Check_Arg_Count
(1);
18088 Check_Arg_Is_Local_Name
(Arg1
);
18090 Find_Type
(Typ_Arg
);
18091 Typ
:= Entity
(Typ_Arg
);
18093 -- The type being subjected to the pragma is erroneous
18095 if Typ
= Any_Type
then
18096 Error_Pragma
("cannot find type referenced by pragma %");
18098 -- The pragma is applied to an incomplete or generic formal
18099 -- type way too early.
18101 elsif Rep_Item_Too_Early
(Typ
, N
) then
18105 Typ
:= Underlying_Type
(Typ
);
18108 -- The pragma must apply to an access-to-object type
18110 if Ekind_In
(Typ
, E_Access_Type
, E_General_Access_Type
) then
18113 -- Give a detailed error message on all other access type kinds
18115 elsif Ekind
(Typ
) = E_Access_Protected_Subprogram_Type
then
18117 ("pragma % cannot apply to access protected subprogram "
18120 elsif Ekind
(Typ
) = E_Access_Subprogram_Type
then
18122 ("pragma % cannot apply to access subprogram type");
18124 elsif Is_Anonymous_Access_Type
(Typ
) then
18126 ("pragma % cannot apply to anonymous access type");
18128 -- Give a general error message in case the pragma applies to a
18129 -- non-access type.
18133 ("pragma % must apply to library level access type");
18136 -- At this point the argument denotes an access-to-object type.
18137 -- Ensure that the type is declared at the library level.
18139 if Is_Library_Level_Entity
(Typ
) then
18142 -- Quietly ignore an access-to-object type originally declared
18143 -- at the library level within a generic, but instantiated at
18144 -- a non-library level. As a result the access-to-object type
18145 -- "loses" its No_Heap_Finalization property.
18147 elsif In_Instance
then
18152 ("pragma % must apply to library level access type");
18155 -- Detect a duplicate pragma
18157 if Present
(No_Heap_Finalization_Pragma
) then
18160 Prev
=> No_Heap_Finalization_Pragma
);
18164 Prev
:= Get_Pragma
(Typ
, Pragma_No_Heap_Finalization
);
18166 if Present
(Prev
) then
18174 Record_Rep_Item
(Typ
, N
);
18176 end No_Heap_Finalization
;
18182 -- pragma No_Inline ( NAME {, NAME} );
18184 when Pragma_No_Inline
=>
18186 Process_Inline
(Suppressed
);
18192 -- pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
18194 when Pragma_No_Return
=> No_Return
: declare
18200 Ghost_Error_Posted
: Boolean := False;
18201 -- Flag set when an error concerning the illegal mix of Ghost and
18202 -- non-Ghost subprograms is emitted.
18204 Ghost_Id
: Entity_Id
:= Empty
;
18205 -- The entity of the first Ghost procedure encountered while
18206 -- processing the arguments of the pragma.
18210 Check_At_Least_N_Arguments
(1);
18212 -- Loop through arguments of pragma
18215 while Present
(Arg
) loop
18216 Check_Arg_Is_Local_Name
(Arg
);
18217 Id
:= Get_Pragma_Arg
(Arg
);
18220 if not Is_Entity_Name
(Id
) then
18221 Error_Pragma_Arg
("entity name required", Arg
);
18224 if Etype
(Id
) = Any_Type
then
18228 -- Loop to find matching procedures
18234 and then Scope
(E
) = Current_Scope
18236 if Ekind_In
(E
, E_Generic_Procedure
, E_Procedure
) then
18238 -- Check that the pragma is not applied to a body.
18239 -- First check the specless body case, to give a
18240 -- different error message. These checks do not apply
18241 -- if Relaxed_RM_Semantics, to accommodate other Ada
18242 -- compilers. Disable these checks under -gnatd.J.
18244 if not Debug_Flag_Dot_JJ
then
18245 if Nkind
(Parent
(Declaration_Node
(E
))) =
18247 and then not Relaxed_RM_Semantics
18250 ("pragma% requires separate spec and must come "
18254 -- Now the "specful" body case
18256 if Rep_Item_Too_Late
(E
, N
) then
18263 -- A pragma that applies to a Ghost entity becomes Ghost
18264 -- for the purposes of legality checks and removal of
18265 -- ignored Ghost code.
18267 Mark_Ghost_Pragma
(N
, E
);
18269 -- Capture the entity of the first Ghost procedure being
18270 -- processed for error detection purposes.
18272 if Is_Ghost_Entity
(E
) then
18273 if No
(Ghost_Id
) then
18277 -- Otherwise the subprogram is non-Ghost. It is illegal
18278 -- to mix references to Ghost and non-Ghost entities
18281 elsif Present
(Ghost_Id
)
18282 and then not Ghost_Error_Posted
18284 Ghost_Error_Posted
:= True;
18286 Error_Msg_Name_1
:= Pname
;
18288 ("pragma % cannot mention ghost and non-ghost "
18289 & "procedures", N
);
18291 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
18292 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
18294 Error_Msg_Sloc
:= Sloc
(E
);
18295 Error_Msg_NE
("\& # declared as non-ghost", N
, E
);
18298 -- Set flag on any alias as well
18300 if Is_Overloadable
(E
) and then Present
(Alias
(E
)) then
18301 Set_No_Return
(Alias
(E
));
18307 exit when From_Aspect_Specification
(N
);
18311 -- If entity in not in current scope it may be the enclosing
18312 -- suprogram body to which the aspect applies.
18315 if Entity
(Id
) = Current_Scope
18316 and then From_Aspect_Specification
(N
)
18318 Set_No_Return
(Entity
(Id
));
18320 Error_Pragma_Arg
("no procedure& found for pragma%", Arg
);
18332 -- pragma No_Run_Time;
18334 -- Note: this pragma is retained for backwards compatibility. See
18335 -- body of Rtsfind for full details on its handling.
18337 when Pragma_No_Run_Time
=>
18339 Check_Valid_Configuration_Pragma
;
18340 Check_Arg_Count
(0);
18342 -- Remove backward compatibility if Build_Type is FSF or GPL and
18343 -- generate a warning.
18346 Ignore
: constant Boolean := Build_Type
in FSF
.. GPL
;
18349 Error_Pragma
("pragma% is ignored, has no effect??");
18351 No_Run_Time_Mode
:= True;
18352 Configurable_Run_Time_Mode
:= True;
18354 -- Set Duration to 32 bits if word size is 32
18356 if Ttypes
.System_Word_Size
= 32 then
18357 Duration_32_Bits_On_Target
:= True;
18360 -- Set appropriate restrictions
18362 Set_Restriction
(No_Finalization
, N
);
18363 Set_Restriction
(No_Exception_Handlers
, N
);
18364 Set_Restriction
(Max_Tasks
, N
, 0);
18365 Set_Restriction
(No_Tasking
, N
);
18369 -----------------------
18370 -- No_Tagged_Streams --
18371 -----------------------
18373 -- pragma No_Tagged_Streams [([Entity => ]tagged_type_local_NAME)];
18375 when Pragma_No_Tagged_Streams
=> No_Tagged_Strms
: declare
18381 Check_At_Most_N_Arguments
(1);
18383 -- One argument case
18385 if Arg_Count
= 1 then
18386 Check_Optional_Identifier
(Arg1
, Name_Entity
);
18387 Check_Arg_Is_Local_Name
(Arg1
);
18388 E_Id
:= Get_Pragma_Arg
(Arg1
);
18390 if Etype
(E_Id
) = Any_Type
then
18394 E
:= Entity
(E_Id
);
18396 Check_Duplicate_Pragma
(E
);
18398 if not Is_Tagged_Type
(E
) or else Is_Derived_Type
(E
) then
18400 ("argument for pragma% must be root tagged type", Arg1
);
18403 if Rep_Item_Too_Early
(E
, N
)
18405 Rep_Item_Too_Late
(E
, N
)
18409 Set_No_Tagged_Streams_Pragma
(E
, N
);
18412 -- Zero argument case
18415 Check_Is_In_Decl_Part_Or_Package_Spec
;
18416 No_Tagged_Streams
:= N
;
18418 end No_Tagged_Strms
;
18420 ------------------------
18421 -- No_Strict_Aliasing --
18422 ------------------------
18424 -- pragma No_Strict_Aliasing [([Entity =>] type_LOCAL_NAME)];
18426 when Pragma_No_Strict_Aliasing
=> No_Strict_Aliasing
: declare
18431 Check_At_Most_N_Arguments
(1);
18433 if Arg_Count
= 0 then
18434 Check_Valid_Configuration_Pragma
;
18435 Opt
.No_Strict_Aliasing
:= True;
18438 Check_Optional_Identifier
(Arg2
, Name_Entity
);
18439 Check_Arg_Is_Local_Name
(Arg1
);
18440 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
18442 if E_Id
= Any_Type
then
18444 elsif No
(E_Id
) or else not Is_Access_Type
(E_Id
) then
18445 Error_Pragma_Arg
("pragma% requires access type", Arg1
);
18448 Set_No_Strict_Aliasing
(Implementation_Base_Type
(E_Id
));
18450 end No_Strict_Aliasing
;
18452 -----------------------
18453 -- Normalize_Scalars --
18454 -----------------------
18456 -- pragma Normalize_Scalars;
18458 when Pragma_Normalize_Scalars
=>
18459 Check_Ada_83_Warning
;
18460 Check_Arg_Count
(0);
18461 Check_Valid_Configuration_Pragma
;
18463 -- Normalize_Scalars creates false positives in CodePeer, and
18464 -- incorrect negative results in GNATprove mode, so ignore this
18465 -- pragma in these modes.
18467 if not (CodePeer_Mode
or GNATprove_Mode
) then
18468 Normalize_Scalars
:= True;
18469 Init_Or_Norm_Scalars
:= True;
18476 -- pragma Obsolescent;
18478 -- pragma Obsolescent (
18479 -- [Message =>] static_string_EXPRESSION
18480 -- [,[Version =>] Ada_05]]);
18482 -- pragma Obsolescent (
18483 -- [Entity =>] NAME
18484 -- [,[Message =>] static_string_EXPRESSION
18485 -- [,[Version =>] Ada_05]] );
18487 when Pragma_Obsolescent
=> Obsolescent
: declare
18491 procedure Set_Obsolescent
(E
: Entity_Id
);
18492 -- Given an entity Ent, mark it as obsolescent if appropriate
18494 ---------------------
18495 -- Set_Obsolescent --
18496 ---------------------
18498 procedure Set_Obsolescent
(E
: Entity_Id
) is
18507 -- A pragma that applies to a Ghost entity becomes Ghost for
18508 -- the purposes of legality checks and removal of ignored Ghost
18511 Mark_Ghost_Pragma
(N
, E
);
18513 -- Entity name was given
18515 if Present
(Ename
) then
18517 -- If entity name matches, we are fine. Save entity in
18518 -- pragma argument, for ASIS use.
18520 if Chars
(Ename
) = Chars
(Ent
) then
18521 Set_Entity
(Ename
, Ent
);
18522 Generate_Reference
(Ent
, Ename
);
18524 -- If entity name does not match, only possibility is an
18525 -- enumeration literal from an enumeration type declaration.
18527 elsif Ekind
(Ent
) /= E_Enumeration_Type
then
18529 ("pragma % entity name does not match declaration");
18532 Ent
:= First_Literal
(E
);
18536 ("pragma % entity name does not match any "
18537 & "enumeration literal");
18539 elsif Chars
(Ent
) = Chars
(Ename
) then
18540 Set_Entity
(Ename
, Ent
);
18541 Generate_Reference
(Ent
, Ename
);
18545 Ent
:= Next_Literal
(Ent
);
18551 -- Ent points to entity to be marked
18553 if Arg_Count
>= 1 then
18555 -- Deal with static string argument
18557 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
18558 S
:= Strval
(Get_Pragma_Arg
(Arg1
));
18560 for J
in 1 .. String_Length
(S
) loop
18561 if not In_Character_Range
(Get_String_Char
(S
, J
)) then
18563 ("pragma% argument does not allow wide characters",
18568 Obsolescent_Warnings
.Append
18569 ((Ent
=> Ent
, Msg
=> Strval
(Get_Pragma_Arg
(Arg1
))));
18571 -- Check for Ada_05 parameter
18573 if Arg_Count
/= 1 then
18574 Check_Arg_Count
(2);
18577 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
18580 Check_Arg_Is_Identifier
(Argx
);
18582 if Chars
(Argx
) /= Name_Ada_05
then
18583 Error_Msg_Name_2
:= Name_Ada_05
;
18585 ("only allowed argument for pragma% is %", Argx
);
18588 if Ada_Version_Explicit
< Ada_2005
18589 or else not Warn_On_Ada_2005_Compatibility
18597 -- Set flag if pragma active
18600 Set_Is_Obsolescent
(Ent
);
18604 end Set_Obsolescent
;
18606 -- Start of processing for pragma Obsolescent
18611 Check_At_Most_N_Arguments
(3);
18613 -- See if first argument specifies an entity name
18617 (Chars
(Arg1
) = Name_Entity
18619 Nkind_In
(Get_Pragma_Arg
(Arg1
), N_Character_Literal
,
18621 N_Operator_Symbol
))
18623 Ename
:= Get_Pragma_Arg
(Arg1
);
18625 -- Eliminate first argument, so we can share processing
18629 Arg_Count
:= Arg_Count
- 1;
18631 -- No Entity name argument given
18637 if Arg_Count
>= 1 then
18638 Check_Optional_Identifier
(Arg1
, Name_Message
);
18640 if Arg_Count
= 2 then
18641 Check_Optional_Identifier
(Arg2
, Name_Version
);
18645 -- Get immediately preceding declaration
18648 while Present
(Decl
) and then Nkind
(Decl
) = N_Pragma
loop
18652 -- Cases where we do not follow anything other than another pragma
18656 -- First case: library level compilation unit declaration with
18657 -- the pragma immediately following the declaration.
18659 if Nkind
(Parent
(N
)) = N_Compilation_Unit_Aux
then
18661 (Defining_Entity
(Unit
(Parent
(Parent
(N
)))));
18664 -- Case 2: library unit placement for package
18668 Ent
: constant Entity_Id
:= Find_Lib_Unit_Name
;
18670 if Is_Package_Or_Generic_Package
(Ent
) then
18671 Set_Obsolescent
(Ent
);
18677 -- Cases where we must follow a declaration, including an
18678 -- abstract subprogram declaration, which is not in the
18679 -- other node subtypes.
18682 if Nkind
(Decl
) not in N_Declaration
18683 and then Nkind
(Decl
) not in N_Later_Decl_Item
18684 and then Nkind
(Decl
) not in N_Generic_Declaration
18685 and then Nkind
(Decl
) not in N_Renaming_Declaration
18686 and then Nkind
(Decl
) /= N_Abstract_Subprogram_Declaration
18689 ("pragma% misplaced, "
18690 & "must immediately follow a declaration");
18693 Set_Obsolescent
(Defining_Entity
(Decl
));
18703 -- pragma Optimize (Time | Space | Off);
18705 -- The actual check for optimize is done in Gigi. Note that this
18706 -- pragma does not actually change the optimization setting, it
18707 -- simply checks that it is consistent with the pragma.
18709 when Pragma_Optimize
=>
18710 Check_No_Identifiers
;
18711 Check_Arg_Count
(1);
18712 Check_Arg_Is_One_Of
(Arg1
, Name_Time
, Name_Space
, Name_Off
);
18714 ------------------------
18715 -- Optimize_Alignment --
18716 ------------------------
18718 -- pragma Optimize_Alignment (Time | Space | Off);
18720 when Pragma_Optimize_Alignment
=> Optimize_Alignment
: begin
18722 Check_No_Identifiers
;
18723 Check_Arg_Count
(1);
18724 Check_Valid_Configuration_Pragma
;
18727 Nam
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(Arg1
));
18730 when Name_Off
=> Opt
.Optimize_Alignment
:= 'O';
18731 when Name_Space
=> Opt
.Optimize_Alignment
:= 'S';
18732 when Name_Time
=> Opt
.Optimize_Alignment
:= 'T';
18735 Error_Pragma_Arg
("invalid argument for pragma%", Arg1
);
18739 -- Set indication that mode is set locally. If we are in fact in a
18740 -- configuration pragma file, this setting is harmless since the
18741 -- switch will get reset anyway at the start of each unit.
18743 Optimize_Alignment_Local
:= True;
18744 end Optimize_Alignment
;
18750 -- pragma Ordered (first_enumeration_subtype_LOCAL_NAME);
18752 when Pragma_Ordered
=> Ordered
: declare
18753 Assoc
: constant Node_Id
:= Arg1
;
18759 Check_No_Identifiers
;
18760 Check_Arg_Count
(1);
18761 Check_Arg_Is_Local_Name
(Arg1
);
18763 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18764 Find_Type
(Type_Id
);
18765 Typ
:= Entity
(Type_Id
);
18767 if Typ
= Any_Type
then
18770 Typ
:= Underlying_Type
(Typ
);
18773 if not Is_Enumeration_Type
(Typ
) then
18774 Error_Pragma
("pragma% must specify enumeration type");
18777 Check_First_Subtype
(Arg1
);
18778 Set_Has_Pragma_Ordered
(Base_Type
(Typ
));
18781 -------------------
18782 -- Overflow_Mode --
18783 -------------------
18785 -- pragma Overflow_Mode
18786 -- ([General => ] MODE [, [Assertions => ] MODE]);
18788 -- MODE := STRICT | MINIMIZED | ELIMINATED
18790 -- Note: ELIMINATED is allowed only if Long_Long_Integer'Size is 64
18791 -- since System.Bignums makes this assumption. This is true of nearly
18792 -- all (all?) targets.
18794 when Pragma_Overflow_Mode
=> Overflow_Mode
: declare
18795 function Get_Overflow_Mode
18797 Arg
: Node_Id
) return Overflow_Mode_Type
;
18798 -- Function to process one pragma argument, Arg. If an identifier
18799 -- is present, it must be Name. Mode type is returned if a valid
18800 -- argument exists, otherwise an error is signalled.
18802 -----------------------
18803 -- Get_Overflow_Mode --
18804 -----------------------
18806 function Get_Overflow_Mode
18808 Arg
: Node_Id
) return Overflow_Mode_Type
18810 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg
);
18813 Check_Optional_Identifier
(Arg
, Name
);
18814 Check_Arg_Is_Identifier
(Argx
);
18816 if Chars
(Argx
) = Name_Strict
then
18819 elsif Chars
(Argx
) = Name_Minimized
then
18822 elsif Chars
(Argx
) = Name_Eliminated
then
18823 if Ttypes
.Standard_Long_Long_Integer_Size
/= 64 then
18825 ("Eliminated not implemented on this target", Argx
);
18831 Error_Pragma_Arg
("invalid argument for pragma%", Argx
);
18833 end Get_Overflow_Mode
;
18835 -- Start of processing for Overflow_Mode
18839 Check_At_Least_N_Arguments
(1);
18840 Check_At_Most_N_Arguments
(2);
18842 -- Process first argument
18844 Scope_Suppress
.Overflow_Mode_General
:=
18845 Get_Overflow_Mode
(Name_General
, Arg1
);
18847 -- Case of only one argument
18849 if Arg_Count
= 1 then
18850 Scope_Suppress
.Overflow_Mode_Assertions
:=
18851 Scope_Suppress
.Overflow_Mode_General
;
18853 -- Case of two arguments present
18856 Scope_Suppress
.Overflow_Mode_Assertions
:=
18857 Get_Overflow_Mode
(Name_Assertions
, Arg2
);
18861 --------------------------
18862 -- Overriding Renamings --
18863 --------------------------
18865 -- pragma Overriding_Renamings;
18867 when Pragma_Overriding_Renamings
=>
18869 Check_Arg_Count
(0);
18870 Check_Valid_Configuration_Pragma
;
18871 Overriding_Renamings
:= True;
18877 -- pragma Pack (first_subtype_LOCAL_NAME);
18879 when Pragma_Pack
=> Pack
: declare
18880 Assoc
: constant Node_Id
:= Arg1
;
18882 Ignore
: Boolean := False;
18887 Check_No_Identifiers
;
18888 Check_Arg_Count
(1);
18889 Check_Arg_Is_Local_Name
(Arg1
);
18890 Type_Id
:= Get_Pragma_Arg
(Assoc
);
18892 if not Is_Entity_Name
(Type_Id
)
18893 or else not Is_Type
(Entity
(Type_Id
))
18896 ("argument for pragma% must be type or subtype", Arg1
);
18899 Find_Type
(Type_Id
);
18900 Typ
:= Entity
(Type_Id
);
18903 or else Rep_Item_Too_Early
(Typ
, N
)
18907 Typ
:= Underlying_Type
(Typ
);
18910 -- A pragma that applies to a Ghost entity becomes Ghost for the
18911 -- purposes of legality checks and removal of ignored Ghost code.
18913 Mark_Ghost_Pragma
(N
, Typ
);
18915 if not Is_Array_Type
(Typ
) and then not Is_Record_Type
(Typ
) then
18916 Error_Pragma
("pragma% must specify array or record type");
18919 Check_First_Subtype
(Arg1
);
18920 Check_Duplicate_Pragma
(Typ
);
18924 if Is_Array_Type
(Typ
) then
18925 Ctyp
:= Component_Type
(Typ
);
18927 -- Ignore pack that does nothing
18929 if Known_Static_Esize
(Ctyp
)
18930 and then Known_Static_RM_Size
(Ctyp
)
18931 and then Esize
(Ctyp
) = RM_Size
(Ctyp
)
18932 and then Addressable
(Esize
(Ctyp
))
18937 -- Process OK pragma Pack. Note that if there is a separate
18938 -- component clause present, the Pack will be cancelled. This
18939 -- processing is in Freeze.
18941 if not Rep_Item_Too_Late
(Typ
, N
) then
18943 -- In CodePeer mode, we do not need complex front-end
18944 -- expansions related to pragma Pack, so disable handling
18947 if CodePeer_Mode
then
18950 -- Normal case where we do the pack action
18954 Set_Is_Packed
(Base_Type
(Typ
));
18955 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18958 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18962 -- For record types, the pack is always effective
18964 else pragma Assert
(Is_Record_Type
(Typ
));
18965 if not Rep_Item_Too_Late
(Typ
, N
) then
18966 Set_Is_Packed
(Base_Type
(Typ
));
18967 Set_Has_Pragma_Pack
(Base_Type
(Typ
));
18968 Set_Has_Non_Standard_Rep
(Base_Type
(Typ
));
18979 -- There is nothing to do here, since we did all the processing for
18980 -- this pragma in Par.Prag (so that it works properly even in syntax
18983 when Pragma_Page
=>
18990 -- pragma Part_Of (ABSTRACT_STATE);
18992 -- ABSTRACT_STATE ::= NAME
18994 when Pragma_Part_Of
=> Part_Of
: declare
18995 procedure Propagate_Part_Of
18996 (Pack_Id
: Entity_Id
;
18997 State_Id
: Entity_Id
;
18998 Instance
: Node_Id
);
18999 -- Propagate the Part_Of indicator to all abstract states and
19000 -- objects declared in the visible state space of a package
19001 -- denoted by Pack_Id. State_Id is the encapsulating state.
19002 -- Instance is the package instantiation node.
19004 -----------------------
19005 -- Propagate_Part_Of --
19006 -----------------------
19008 procedure Propagate_Part_Of
19009 (Pack_Id
: Entity_Id
;
19010 State_Id
: Entity_Id
;
19011 Instance
: Node_Id
)
19013 Has_Item
: Boolean := False;
19014 -- Flag set when the visible state space contains at least one
19015 -- abstract state or variable.
19017 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
);
19018 -- Propagate the Part_Of indicator to all abstract states and
19019 -- objects declared in the visible state space of a package
19020 -- denoted by Pack_Id.
19022 -----------------------
19023 -- Propagate_Part_Of --
19024 -----------------------
19026 procedure Propagate_Part_Of
(Pack_Id
: Entity_Id
) is
19027 Constits
: Elist_Id
;
19028 Item_Id
: Entity_Id
;
19031 -- Traverse the entity chain of the package and set relevant
19032 -- attributes of abstract states and objects declared in the
19033 -- visible state space of the package.
19035 Item_Id
:= First_Entity
(Pack_Id
);
19036 while Present
(Item_Id
)
19037 and then not In_Private_Part
(Item_Id
)
19039 -- Do not consider internally generated items
19041 if not Comes_From_Source
(Item_Id
) then
19044 -- The Part_Of indicator turns an abstract state or an
19045 -- object into a constituent of the encapsulating state.
19047 elsif Ekind_In
(Item_Id
, E_Abstract_State
,
19052 Constits
:= Part_Of_Constituents
(State_Id
);
19054 if No
(Constits
) then
19055 Constits
:= New_Elmt_List
;
19056 Set_Part_Of_Constituents
(State_Id
, Constits
);
19059 Append_Elmt
(Item_Id
, Constits
);
19060 Set_Encapsulating_State
(Item_Id
, State_Id
);
19062 -- Recursively handle nested packages and instantiations
19064 elsif Ekind
(Item_Id
) = E_Package
then
19065 Propagate_Part_Of
(Item_Id
);
19068 Next_Entity
(Item_Id
);
19070 end Propagate_Part_Of
;
19072 -- Start of processing for Propagate_Part_Of
19075 Propagate_Part_Of
(Pack_Id
);
19077 -- Detect a package instantiation that is subject to a Part_Of
19078 -- indicator, but has no visible state.
19080 if not Has_Item
then
19082 ("package instantiation & has Part_Of indicator but "
19083 & "lacks visible state", Instance
, Pack_Id
);
19085 end Propagate_Part_Of
;
19089 Constits
: Elist_Id
;
19091 Encap_Id
: Entity_Id
;
19092 Item_Id
: Entity_Id
;
19096 -- Start of processing for Part_Of
19100 Check_No_Identifiers
;
19101 Check_Arg_Count
(1);
19103 Stmt
:= Find_Related_Context
(N
, Do_Checks
=> True);
19105 -- Object declaration
19107 if Nkind
(Stmt
) = N_Object_Declaration
then
19110 -- Package instantiation
19112 elsif Nkind
(Stmt
) = N_Package_Instantiation
then
19115 -- Single concurrent type declaration
19117 elsif Is_Single_Concurrent_Type_Declaration
(Stmt
) then
19120 -- Otherwise the pragma is associated with an illegal construct
19127 -- Extract the entity of the related object declaration or package
19128 -- instantiation. In the case of the instantiation, use the entity
19129 -- of the instance spec.
19131 if Nkind
(Stmt
) = N_Package_Instantiation
then
19132 Stmt
:= Instance_Spec
(Stmt
);
19135 Item_Id
:= Defining_Entity
(Stmt
);
19137 -- A pragma that applies to a Ghost entity becomes Ghost for the
19138 -- purposes of legality checks and removal of ignored Ghost code.
19140 Mark_Ghost_Pragma
(N
, Item_Id
);
19142 -- Chain the pragma on the contract for further processing by
19143 -- Analyze_Part_Of_In_Decl_Part or for completeness.
19145 Add_Contract_Item
(N
, Item_Id
);
19147 -- A variable may act as constituent of a single concurrent type
19148 -- which in turn could be declared after the variable. Due to this
19149 -- discrepancy, the full analysis of indicator Part_Of is delayed
19150 -- until the end of the enclosing declarative region (see routine
19151 -- Analyze_Part_Of_In_Decl_Part).
19153 if Ekind
(Item_Id
) = E_Variable
then
19156 -- Otherwise indicator Part_Of applies to a constant or a package
19160 Encap
:= Get_Pragma_Arg
(Arg1
);
19162 -- Detect any discrepancies between the placement of the
19163 -- constant or package instantiation with respect to state
19164 -- space and the encapsulating state.
19168 Item_Id
=> Item_Id
,
19170 Encap_Id
=> Encap_Id
,
19174 pragma Assert
(Present
(Encap_Id
));
19176 if Ekind
(Item_Id
) = E_Constant
then
19177 Constits
:= Part_Of_Constituents
(Encap_Id
);
19179 if No
(Constits
) then
19180 Constits
:= New_Elmt_List
;
19181 Set_Part_Of_Constituents
(Encap_Id
, Constits
);
19184 Append_Elmt
(Item_Id
, Constits
);
19185 Set_Encapsulating_State
(Item_Id
, Encap_Id
);
19187 -- Propagate the Part_Of indicator to the visible state
19188 -- space of the package instantiation.
19192 (Pack_Id
=> Item_Id
,
19193 State_Id
=> Encap_Id
,
19200 ----------------------------------
19201 -- Partition_Elaboration_Policy --
19202 ----------------------------------
19204 -- pragma Partition_Elaboration_Policy (policy_IDENTIFIER);
19206 when Pragma_Partition_Elaboration_Policy
=> PEP
: declare
19207 subtype PEP_Range
is Name_Id
19208 range First_Partition_Elaboration_Policy_Name
19209 .. Last_Partition_Elaboration_Policy_Name
;
19210 PEP_Val
: PEP_Range
;
19215 Check_Arg_Count
(1);
19216 Check_No_Identifiers
;
19217 Check_Arg_Is_Partition_Elaboration_Policy
(Arg1
);
19218 Check_Valid_Configuration_Pragma
;
19219 PEP_Val
:= Chars
(Get_Pragma_Arg
(Arg1
));
19222 when Name_Concurrent
=> PEP
:= 'C';
19223 when Name_Sequential
=> PEP
:= 'S';
19226 if Partition_Elaboration_Policy
/= ' '
19227 and then Partition_Elaboration_Policy
/= PEP
19229 Error_Msg_Sloc
:= Partition_Elaboration_Policy_Sloc
;
19231 ("partition elaboration policy incompatible with policy#");
19233 -- Set new policy, but always preserve System_Location since we
19234 -- like the error message with the run time name.
19237 Partition_Elaboration_Policy
:= PEP
;
19239 if Partition_Elaboration_Policy_Sloc
/= System_Location
then
19240 Partition_Elaboration_Policy_Sloc
:= Loc
;
19249 -- pragma Passive [(PASSIVE_FORM)];
19251 -- PASSIVE_FORM ::= Semaphore | No
19253 when Pragma_Passive
=>
19256 if Nkind
(Parent
(N
)) /= N_Task_Definition
then
19257 Error_Pragma
("pragma% must be within task definition");
19260 if Arg_Count
/= 0 then
19261 Check_Arg_Count
(1);
19262 Check_Arg_Is_One_Of
(Arg1
, Name_Semaphore
, Name_No
);
19265 ----------------------------------
19266 -- Preelaborable_Initialization --
19267 ----------------------------------
19269 -- pragma Preelaborable_Initialization (DIRECT_NAME);
19271 when Pragma_Preelaborable_Initialization
=> Preelab_Init
: declare
19276 Check_Arg_Count
(1);
19277 Check_No_Identifiers
;
19278 Check_Arg_Is_Identifier
(Arg1
);
19279 Check_Arg_Is_Local_Name
(Arg1
);
19280 Check_First_Subtype
(Arg1
);
19281 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19283 -- A pragma that applies to a Ghost entity becomes Ghost for the
19284 -- purposes of legality checks and removal of ignored Ghost code.
19286 Mark_Ghost_Pragma
(N
, Ent
);
19288 -- The pragma may come from an aspect on a private declaration,
19289 -- even if the freeze point at which this is analyzed in the
19290 -- private part after the full view.
19292 if Has_Private_Declaration
(Ent
)
19293 and then From_Aspect_Specification
(N
)
19297 -- Check appropriate type argument
19299 elsif Is_Private_Type
(Ent
)
19300 or else Is_Protected_Type
(Ent
)
19301 or else (Is_Generic_Type
(Ent
) and then Is_Derived_Type
(Ent
))
19303 -- AI05-0028: The pragma applies to all composite types. Note
19304 -- that we apply this binding interpretation to earlier versions
19305 -- of Ada, so there is no Ada 2012 guard. Seems a reasonable
19306 -- choice since there are other compilers that do the same.
19308 or else Is_Composite_Type
(Ent
)
19314 ("pragma % can only be applied to private, formal derived, "
19315 & "protected, or composite type", Arg1
);
19318 -- Give an error if the pragma is applied to a protected type that
19319 -- does not qualify (due to having entries, or due to components
19320 -- that do not qualify).
19322 if Is_Protected_Type
(Ent
)
19323 and then not Has_Preelaborable_Initialization
(Ent
)
19326 ("protected type & does not have preelaborable "
19327 & "initialization", Ent
);
19329 -- Otherwise mark the type as definitely having preelaborable
19333 Set_Known_To_Have_Preelab_Init
(Ent
);
19336 if Has_Pragma_Preelab_Init
(Ent
)
19337 and then Warn_On_Redundant_Constructs
19339 Error_Pragma
("?r?duplicate pragma%!");
19341 Set_Has_Pragma_Preelab_Init
(Ent
);
19345 --------------------
19346 -- Persistent_BSS --
19347 --------------------
19349 -- pragma Persistent_BSS [(object_NAME)];
19351 when Pragma_Persistent_BSS
=> Persistent_BSS
: declare
19358 Check_At_Most_N_Arguments
(1);
19360 -- Case of application to specific object (one argument)
19362 if Arg_Count
= 1 then
19363 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
19365 if not Is_Entity_Name
(Get_Pragma_Arg
(Arg1
))
19367 Ekind_In
(Entity
(Get_Pragma_Arg
(Arg1
)), E_Variable
,
19370 Error_Pragma_Arg
("pragma% only applies to objects", Arg1
);
19373 Ent
:= Entity
(Get_Pragma_Arg
(Arg1
));
19375 -- A pragma that applies to a Ghost entity becomes Ghost for
19376 -- the purposes of legality checks and removal of ignored Ghost
19379 Mark_Ghost_Pragma
(N
, Ent
);
19381 -- Check for duplication before inserting in list of
19382 -- representation items.
19384 Check_Duplicate_Pragma
(Ent
);
19386 if Rep_Item_Too_Late
(Ent
, N
) then
19390 Decl
:= Parent
(Ent
);
19392 if Present
(Expression
(Decl
)) then
19394 ("object for pragma% cannot have initialization", Arg1
);
19397 if not Is_Potentially_Persistent_Type
(Etype
(Ent
)) then
19399 ("object type for pragma% is not potentially persistent",
19404 Make_Linker_Section_Pragma
19405 (Ent
, Sloc
(N
), ".persistent.bss");
19406 Insert_After
(N
, Prag
);
19409 -- Case of use as configuration pragma with no arguments
19412 Check_Valid_Configuration_Pragma
;
19413 Persistent_BSS_Mode
:= True;
19415 end Persistent_BSS
;
19417 --------------------
19418 -- Rename_Pragma --
19419 --------------------
19421 -- pragma Rename_Pragma (
19422 -- [New_Name =>] IDENTIFIER,
19423 -- [Renamed =>] pragma_IDENTIFIER);
19425 when Pragma_Rename_Pragma
=> Rename_Pragma
: declare
19426 New_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19427 Old_Name
: constant Node_Id
:= Get_Pragma_Arg
(Arg2
);
19431 Check_Valid_Configuration_Pragma
;
19432 Check_Arg_Count
(2);
19433 Check_Optional_Identifier
(Arg1
, Name_New_Name
);
19434 Check_Optional_Identifier
(Arg2
, Name_Renamed
);
19436 if Nkind
(New_Name
) /= N_Identifier
then
19437 Error_Pragma_Arg
("identifier expected", Arg1
);
19440 if Nkind
(Old_Name
) /= N_Identifier
then
19441 Error_Pragma_Arg
("identifier expected", Arg2
);
19444 -- The New_Name arg should not be an existing pragma (but we allow
19445 -- it; it's just a warning). The Old_Name arg must be an existing
19448 if Is_Pragma_Name
(Chars
(New_Name
)) then
19449 Error_Pragma_Arg
("??pragma is already defined", Arg1
);
19452 if not Is_Pragma_Name
(Chars
(Old_Name
)) then
19453 Error_Pragma_Arg
("existing pragma name expected", Arg1
);
19456 Map_Pragma_Name
(From
=> Chars
(New_Name
), To
=> Chars
(Old_Name
));
19463 -- pragma Polling (ON | OFF);
19465 when Pragma_Polling
=>
19467 Check_Arg_Count
(1);
19468 Check_No_Identifiers
;
19469 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
19470 Polling_Required
:= (Chars
(Get_Pragma_Arg
(Arg1
)) = Name_On
);
19472 -----------------------------------
19473 -- Post/Post_Class/Postcondition --
19474 -----------------------------------
19476 -- pragma Post (Boolean_EXPRESSION);
19477 -- pragma Post_Class (Boolean_EXPRESSION);
19478 -- pragma Postcondition ([Check =>] Boolean_EXPRESSION
19479 -- [,[Message =>] String_EXPRESSION]);
19481 -- Characteristics:
19483 -- * Analysis - The annotation undergoes initial checks to verify
19484 -- the legal placement and context. Secondary checks preanalyze the
19487 -- Analyze_Pre_Post_Condition_In_Decl_Part
19489 -- * Expansion - The annotation is expanded during the expansion of
19490 -- the related subprogram [body] contract as performed in:
19492 -- Expand_Subprogram_Contract
19494 -- * Template - The annotation utilizes the generic template of the
19495 -- related subprogram [body] when it is:
19497 -- aspect on subprogram declaration
19498 -- aspect on stand alone subprogram body
19499 -- pragma on stand alone subprogram body
19501 -- The annotation must prepare its own template when it is:
19503 -- pragma on subprogram declaration
19505 -- * Globals - Capture of global references must occur after full
19508 -- * Instance - The annotation is instantiated automatically when
19509 -- the related generic subprogram [body] is instantiated except for
19510 -- the "pragma on subprogram declaration" case. In that scenario
19511 -- the annotation must instantiate itself.
19514 | Pragma_Post_Class
19515 | Pragma_Postcondition
19517 Analyze_Pre_Post_Condition
;
19519 --------------------------------
19520 -- Pre/Pre_Class/Precondition --
19521 --------------------------------
19523 -- pragma Pre (Boolean_EXPRESSION);
19524 -- pragma Pre_Class (Boolean_EXPRESSION);
19525 -- pragma Precondition ([Check =>] Boolean_EXPRESSION
19526 -- [,[Message =>] String_EXPRESSION]);
19528 -- Characteristics:
19530 -- * Analysis - The annotation undergoes initial checks to verify
19531 -- the legal placement and context. Secondary checks preanalyze the
19534 -- Analyze_Pre_Post_Condition_In_Decl_Part
19536 -- * Expansion - The annotation is expanded during the expansion of
19537 -- the related subprogram [body] contract as performed in:
19539 -- Expand_Subprogram_Contract
19541 -- * Template - The annotation utilizes the generic template of the
19542 -- related subprogram [body] when it is:
19544 -- aspect on subprogram declaration
19545 -- aspect on stand alone subprogram body
19546 -- pragma on stand alone subprogram body
19548 -- The annotation must prepare its own template when it is:
19550 -- pragma on subprogram declaration
19552 -- * Globals - Capture of global references must occur after full
19555 -- * Instance - The annotation is instantiated automatically when
19556 -- the related generic subprogram [body] is instantiated except for
19557 -- the "pragma on subprogram declaration" case. In that scenario
19558 -- the annotation must instantiate itself.
19562 | Pragma_Precondition
19564 Analyze_Pre_Post_Condition
;
19570 -- pragma Predicate
19571 -- ([Entity =>] type_LOCAL_NAME,
19572 -- [Check =>] boolean_EXPRESSION);
19574 when Pragma_Predicate
=> Predicate
: declare
19581 Check_Arg_Count
(2);
19582 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19583 Check_Optional_Identifier
(Arg2
, Name_Check
);
19585 Check_Arg_Is_Local_Name
(Arg1
);
19587 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19588 Find_Type
(Type_Id
);
19589 Typ
:= Entity
(Type_Id
);
19591 if Typ
= Any_Type
then
19595 -- A pragma that applies to a Ghost entity becomes Ghost for the
19596 -- purposes of legality checks and removal of ignored Ghost code.
19598 Mark_Ghost_Pragma
(N
, Typ
);
19600 -- The remaining processing is simply to link the pragma on to
19601 -- the rep item chain, for processing when the type is frozen.
19602 -- This is accomplished by a call to Rep_Item_Too_Late. We also
19603 -- mark the type as having predicates.
19605 -- If the current policy for predicate checking is Ignore mark the
19606 -- subtype accordingly. In the case of predicates we consider them
19607 -- enabled unless Ignore is specified (either directly or with a
19608 -- general Assertion_Policy pragma) to preserve existing warnings.
19610 Set_Has_Predicates
(Typ
);
19611 Set_Predicates_Ignored
(Typ
,
19612 Present
(Check_Policy_List
)
19614 Policy_In_Effect
(Name_Dynamic_Predicate
) = Name_Ignore
);
19615 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19618 -----------------------
19619 -- Predicate_Failure --
19620 -----------------------
19622 -- pragma Predicate_Failure
19623 -- ([Entity =>] type_LOCAL_NAME,
19624 -- [Message =>] string_EXPRESSION);
19626 when Pragma_Predicate_Failure
=> Predicate_Failure
: declare
19633 Check_Arg_Count
(2);
19634 Check_Optional_Identifier
(Arg1
, Name_Entity
);
19635 Check_Optional_Identifier
(Arg2
, Name_Message
);
19637 Check_Arg_Is_Local_Name
(Arg1
);
19639 Type_Id
:= Get_Pragma_Arg
(Arg1
);
19640 Find_Type
(Type_Id
);
19641 Typ
:= Entity
(Type_Id
);
19643 if Typ
= Any_Type
then
19647 -- A pragma that applies to a Ghost entity becomes Ghost for the
19648 -- purposes of legality checks and removal of ignored Ghost code.
19650 Mark_Ghost_Pragma
(N
, Typ
);
19652 -- The remaining processing is simply to link the pragma on to
19653 -- the rep item chain, for processing when the type is frozen.
19654 -- This is accomplished by a call to Rep_Item_Too_Late.
19656 Discard
:= Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True);
19657 end Predicate_Failure
;
19663 -- pragma Preelaborate [(library_unit_NAME)];
19665 -- Set the flag Is_Preelaborated of program unit name entity
19667 when Pragma_Preelaborate
=> Preelaborate
: declare
19668 Pa
: constant Node_Id
:= Parent
(N
);
19669 Pk
: constant Node_Kind
:= Nkind
(Pa
);
19673 Check_Ada_83_Warning
;
19674 Check_Valid_Library_Unit_Pragma
;
19676 if Nkind
(N
) = N_Null_Statement
then
19680 Ent
:= Find_Lib_Unit_Name
;
19682 -- A pragma that applies to a Ghost entity becomes Ghost for the
19683 -- purposes of legality checks and removal of ignored Ghost code.
19685 Mark_Ghost_Pragma
(N
, Ent
);
19686 Check_Duplicate_Pragma
(Ent
);
19688 -- This filters out pragmas inside generic parents that show up
19689 -- inside instantiations. Pragmas that come from aspects in the
19690 -- unit are not ignored.
19692 if Present
(Ent
) then
19693 if Pk
= N_Package_Specification
19694 and then Present
(Generic_Parent
(Pa
))
19695 and then not From_Aspect_Specification
(N
)
19700 if not Debug_Flag_U
then
19701 Set_Is_Preelaborated
(Ent
);
19702 Set_Suppress_Elaboration_Warnings
(Ent
);
19708 -------------------------------
19709 -- Prefix_Exception_Messages --
19710 -------------------------------
19712 -- pragma Prefix_Exception_Messages;
19714 when Pragma_Prefix_Exception_Messages
=>
19716 Check_Valid_Configuration_Pragma
;
19717 Check_Arg_Count
(0);
19718 Prefix_Exception_Messages
:= True;
19724 -- pragma Priority (EXPRESSION);
19726 when Pragma_Priority
=> Priority
: declare
19727 P
: constant Node_Id
:= Parent
(N
);
19732 Check_No_Identifiers
;
19733 Check_Arg_Count
(1);
19737 if Nkind
(P
) = N_Subprogram_Body
then
19738 Check_In_Main_Program
;
19740 Ent
:= Defining_Unit_Name
(Specification
(P
));
19742 if Nkind
(Ent
) = N_Defining_Program_Unit_Name
then
19743 Ent
:= Defining_Identifier
(Ent
);
19746 Arg
:= Get_Pragma_Arg
(Arg1
);
19747 Analyze_And_Resolve
(Arg
, Standard_Integer
);
19751 if not Is_OK_Static_Expression
(Arg
) then
19752 Flag_Non_Static_Expr
19753 ("main subprogram priority is not static!", Arg
);
19756 -- If constraint error, then we already signalled an error
19758 elsif Raises_Constraint_Error
(Arg
) then
19761 -- Otherwise check in range except if Relaxed_RM_Semantics
19762 -- where we ignore the value if out of range.
19765 if not Relaxed_RM_Semantics
19766 and then not Is_In_Range
(Arg
, RTE
(RE_Priority
))
19769 ("main subprogram priority is out of range", Arg1
);
19772 (Current_Sem_Unit
, UI_To_Int
(Expr_Value
(Arg
)));
19776 -- Load an arbitrary entity from System.Tasking.Stages or
19777 -- System.Tasking.Restricted.Stages (depending on the
19778 -- supported profile) to make sure that one of these packages
19779 -- is implicitly with'ed, since we need to have the tasking
19780 -- run time active for the pragma Priority to have any effect.
19781 -- Previously we with'ed the package System.Tasking, but this
19782 -- package does not trigger the required initialization of the
19783 -- run-time library.
19786 Discard
: Entity_Id
;
19787 pragma Warnings
(Off
, Discard
);
19789 if Restricted_Profile
then
19790 Discard
:= RTE
(RE_Activate_Restricted_Tasks
);
19792 Discard
:= RTE
(RE_Activate_Tasks
);
19796 -- Task or Protected, must be of type Integer
19798 elsif Nkind_In
(P
, N_Protected_Definition
, N_Task_Definition
) then
19799 Arg
:= Get_Pragma_Arg
(Arg1
);
19800 Ent
:= Defining_Identifier
(Parent
(P
));
19802 -- The expression must be analyzed in the special manner
19803 -- described in "Handling of Default and Per-Object
19804 -- Expressions" in sem.ads.
19806 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Any_Priority
));
19808 if not Is_OK_Static_Expression
(Arg
) then
19809 Check_Restriction
(Static_Priorities
, Arg
);
19812 -- Anything else is incorrect
19818 -- Check duplicate pragma before we chain the pragma in the Rep
19819 -- Item chain of Ent.
19821 Check_Duplicate_Pragma
(Ent
);
19822 Record_Rep_Item
(Ent
, N
);
19825 -----------------------------------
19826 -- Priority_Specific_Dispatching --
19827 -----------------------------------
19829 -- pragma Priority_Specific_Dispatching (
19830 -- policy_IDENTIFIER,
19831 -- first_priority_EXPRESSION,
19832 -- last_priority_EXPRESSION);
19834 when Pragma_Priority_Specific_Dispatching
=>
19835 Priority_Specific_Dispatching
: declare
19836 Prio_Id
: constant Entity_Id
:= RTE
(RE_Any_Priority
);
19837 -- This is the entity System.Any_Priority;
19840 Lower_Bound
: Node_Id
;
19841 Upper_Bound
: Node_Id
;
19847 Check_Arg_Count
(3);
19848 Check_No_Identifiers
;
19849 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
19850 Check_Valid_Configuration_Pragma
;
19851 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
19852 DP
:= Fold_Upper
(Name_Buffer
(1));
19854 Lower_Bound
:= Get_Pragma_Arg
(Arg2
);
19855 Check_Arg_Is_OK_Static_Expression
(Lower_Bound
, Standard_Integer
);
19856 Lower_Val
:= Expr_Value
(Lower_Bound
);
19858 Upper_Bound
:= Get_Pragma_Arg
(Arg3
);
19859 Check_Arg_Is_OK_Static_Expression
(Upper_Bound
, Standard_Integer
);
19860 Upper_Val
:= Expr_Value
(Upper_Bound
);
19862 -- It is not allowed to use Task_Dispatching_Policy and
19863 -- Priority_Specific_Dispatching in the same partition.
19865 if Task_Dispatching_Policy
/= ' ' then
19866 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19868 ("pragma% incompatible with Task_Dispatching_Policy#");
19870 -- Check lower bound in range
19872 elsif Lower_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19874 Lower_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19877 ("first_priority is out of range", Arg2
);
19879 -- Check upper bound in range
19881 elsif Upper_Val
< Expr_Value
(Type_Low_Bound
(Prio_Id
))
19883 Upper_Val
> Expr_Value
(Type_High_Bound
(Prio_Id
))
19886 ("last_priority is out of range", Arg3
);
19888 -- Check that the priority range is valid
19890 elsif Lower_Val
> Upper_Val
then
19892 ("last_priority_expression must be greater than or equal to "
19893 & "first_priority_expression");
19895 -- Store the new policy, but always preserve System_Location since
19896 -- we like the error message with the run-time name.
19899 -- Check overlapping in the priority ranges specified in other
19900 -- Priority_Specific_Dispatching pragmas within the same
19901 -- partition. We can only check those we know about.
19904 Specific_Dispatching
.First
.. Specific_Dispatching
.Last
19906 if Specific_Dispatching
.Table
(J
).First_Priority
in
19907 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19908 or else Specific_Dispatching
.Table
(J
).Last_Priority
in
19909 UI_To_Int
(Lower_Val
) .. UI_To_Int
(Upper_Val
)
19912 Specific_Dispatching
.Table
(J
).Pragma_Loc
;
19914 ("priority range overlaps with "
19915 & "Priority_Specific_Dispatching#");
19919 -- The use of Priority_Specific_Dispatching is incompatible
19920 -- with Task_Dispatching_Policy.
19922 if Task_Dispatching_Policy
/= ' ' then
19923 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
19925 ("Priority_Specific_Dispatching incompatible "
19926 & "with Task_Dispatching_Policy#");
19929 -- The use of Priority_Specific_Dispatching forces ceiling
19932 if Locking_Policy
/= ' ' and then Locking_Policy
/= 'C' then
19933 Error_Msg_Sloc
:= Locking_Policy_Sloc
;
19935 ("Priority_Specific_Dispatching incompatible "
19936 & "with Locking_Policy#");
19938 -- Set the Ceiling_Locking policy, but preserve System_Location
19939 -- since we like the error message with the run time name.
19942 Locking_Policy
:= 'C';
19944 if Locking_Policy_Sloc
/= System_Location
then
19945 Locking_Policy_Sloc
:= Loc
;
19949 -- Add entry in the table
19951 Specific_Dispatching
.Append
19952 ((Dispatching_Policy
=> DP
,
19953 First_Priority
=> UI_To_Int
(Lower_Val
),
19954 Last_Priority
=> UI_To_Int
(Upper_Val
),
19955 Pragma_Loc
=> Loc
));
19957 end Priority_Specific_Dispatching
;
19963 -- pragma Profile (profile_IDENTIFIER);
19965 -- profile_IDENTIFIER => Restricted | Ravenscar | Rational
19967 when Pragma_Profile
=>
19969 Check_Arg_Count
(1);
19970 Check_Valid_Configuration_Pragma
;
19971 Check_No_Identifiers
;
19974 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
19977 if Chars
(Argx
) = Name_Ravenscar
then
19978 Set_Ravenscar_Profile
(Ravenscar
, N
);
19980 elsif Chars
(Argx
) = Name_Gnat_Extended_Ravenscar
then
19981 Set_Ravenscar_Profile
(GNAT_Extended_Ravenscar
, N
);
19983 elsif Chars
(Argx
) = Name_Gnat_Ravenscar_EDF
then
19984 Set_Ravenscar_Profile
(GNAT_Ravenscar_EDF
, N
);
19986 elsif Chars
(Argx
) = Name_Restricted
then
19987 Set_Profile_Restrictions
19989 N
, Warn
=> Treat_Restrictions_As_Warnings
);
19991 elsif Chars
(Argx
) = Name_Rational
then
19992 Set_Rational_Profile
;
19994 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
19995 Set_Profile_Restrictions
19996 (No_Implementation_Extensions
,
19997 N
, Warn
=> Treat_Restrictions_As_Warnings
);
20000 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20004 ----------------------
20005 -- Profile_Warnings --
20006 ----------------------
20008 -- pragma Profile_Warnings (profile_IDENTIFIER);
20010 -- profile_IDENTIFIER => Restricted | Ravenscar
20012 when Pragma_Profile_Warnings
=>
20014 Check_Arg_Count
(1);
20015 Check_Valid_Configuration_Pragma
;
20016 Check_No_Identifiers
;
20019 Argx
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
20022 if Chars
(Argx
) = Name_Ravenscar
then
20023 Set_Profile_Restrictions
(Ravenscar
, N
, Warn
=> True);
20025 elsif Chars
(Argx
) = Name_Restricted
then
20026 Set_Profile_Restrictions
(Restricted
, N
, Warn
=> True);
20028 elsif Chars
(Argx
) = Name_No_Implementation_Extensions
then
20029 Set_Profile_Restrictions
20030 (No_Implementation_Extensions
, N
, Warn
=> True);
20033 Error_Pragma_Arg
("& is not a valid profile", Argx
);
20037 --------------------------
20038 -- Propagate_Exceptions --
20039 --------------------------
20041 -- pragma Propagate_Exceptions;
20043 -- Note: this pragma is obsolete and has no effect
20045 when Pragma_Propagate_Exceptions
=>
20047 Check_Arg_Count
(0);
20049 if Warn_On_Obsolescent_Feature
then
20051 ("'G'N'A'T pragma Propagate'_Exceptions is now obsolete " &
20052 "and has no effect?j?", N
);
20055 -----------------------------
20056 -- Provide_Shift_Operators --
20057 -----------------------------
20059 -- pragma Provide_Shift_Operators (integer_subtype_LOCAL_NAME);
20061 when Pragma_Provide_Shift_Operators
=>
20062 Provide_Shift_Operators
: declare
20065 procedure Declare_Shift_Operator
(Nam
: Name_Id
);
20066 -- Insert declaration and pragma Instrinsic for named shift op
20068 ----------------------------
20069 -- Declare_Shift_Operator --
20070 ----------------------------
20072 procedure Declare_Shift_Operator
(Nam
: Name_Id
) is
20078 Make_Subprogram_Declaration
(Loc
,
20079 Make_Function_Specification
(Loc
,
20080 Defining_Unit_Name
=>
20081 Make_Defining_Identifier
(Loc
, Chars
=> Nam
),
20083 Result_Definition
=>
20084 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
)),
20086 Parameter_Specifications
=> New_List
(
20087 Make_Parameter_Specification
(Loc
,
20088 Defining_Identifier
=>
20089 Make_Defining_Identifier
(Loc
, Name_Value
),
20091 Make_Identifier
(Loc
, Chars
=> Chars
(Ent
))),
20093 Make_Parameter_Specification
(Loc
,
20094 Defining_Identifier
=>
20095 Make_Defining_Identifier
(Loc
, Name_Amount
),
20097 New_Occurrence_Of
(Standard_Natural
, Loc
)))));
20101 Chars
=> Name_Import
,
20102 Pragma_Argument_Associations
=> New_List
(
20103 Make_Pragma_Argument_Association
(Loc
,
20104 Expression
=> Make_Identifier
(Loc
, Name_Intrinsic
)),
20105 Make_Pragma_Argument_Association
(Loc
,
20106 Expression
=> Make_Identifier
(Loc
, Nam
))));
20108 Insert_After
(N
, Import
);
20109 Insert_After
(N
, Func
);
20110 end Declare_Shift_Operator
;
20112 -- Start of processing for Provide_Shift_Operators
20116 Check_Arg_Count
(1);
20117 Check_Arg_Is_Local_Name
(Arg1
);
20119 Arg1
:= Get_Pragma_Arg
(Arg1
);
20121 -- We must have an entity name
20123 if not Is_Entity_Name
(Arg1
) then
20125 ("pragma % must apply to integer first subtype", Arg1
);
20128 -- If no Entity, means there was a prior error so ignore
20130 if Present
(Entity
(Arg1
)) then
20131 Ent
:= Entity
(Arg1
);
20133 -- Apply error checks
20135 if not Is_First_Subtype
(Ent
) then
20137 ("cannot apply pragma %",
20138 "\& is not a first subtype",
20141 elsif not Is_Integer_Type
(Ent
) then
20143 ("cannot apply pragma %",
20144 "\& is not an integer type",
20147 elsif Has_Shift_Operator
(Ent
) then
20149 ("cannot apply pragma %",
20150 "\& already has declared shift operators",
20153 elsif Is_Frozen
(Ent
) then
20155 ("pragma % appears too late",
20156 "\& is already frozen",
20160 -- Now declare the operators. We do this during analysis rather
20161 -- than expansion, since we want the operators available if we
20162 -- are operating in -gnatc or ASIS mode.
20164 Declare_Shift_Operator
(Name_Rotate_Left
);
20165 Declare_Shift_Operator
(Name_Rotate_Right
);
20166 Declare_Shift_Operator
(Name_Shift_Left
);
20167 Declare_Shift_Operator
(Name_Shift_Right
);
20168 Declare_Shift_Operator
(Name_Shift_Right_Arithmetic
);
20170 end Provide_Shift_Operators
;
20176 -- pragma Psect_Object (
20177 -- [Internal =>] LOCAL_NAME,
20178 -- [, [External =>] EXTERNAL_SYMBOL]
20179 -- [, [Size =>] EXTERNAL_SYMBOL]);
20181 when Pragma_Common_Object
20182 | Pragma_Psect_Object
20184 Psect_Object
: declare
20185 Args
: Args_List
(1 .. 3);
20186 Names
: constant Name_List
(1 .. 3) := (
20191 Internal
: Node_Id
renames Args
(1);
20192 External
: Node_Id
renames Args
(2);
20193 Size
: Node_Id
renames Args
(3);
20195 Def_Id
: Entity_Id
;
20197 procedure Check_Arg
(Arg
: Node_Id
);
20198 -- Checks that argument is either a string literal or an
20199 -- identifier, and posts error message if not.
20205 procedure Check_Arg
(Arg
: Node_Id
) is
20207 if not Nkind_In
(Original_Node
(Arg
),
20212 ("inappropriate argument for pragma %", Arg
);
20216 -- Start of processing for Common_Object/Psect_Object
20220 Gather_Associations
(Names
, Args
);
20221 Process_Extended_Import_Export_Internal_Arg
(Internal
);
20223 Def_Id
:= Entity
(Internal
);
20225 if not Ekind_In
(Def_Id
, E_Constant
, E_Variable
) then
20227 ("pragma% must designate an object", Internal
);
20230 Check_Arg
(Internal
);
20232 if Is_Imported
(Def_Id
) or else Is_Exported
(Def_Id
) then
20234 ("cannot use pragma% for imported/exported object",
20238 if Is_Concurrent_Type
(Etype
(Internal
)) then
20240 ("cannot specify pragma % for task/protected object",
20244 if Has_Rep_Pragma
(Def_Id
, Name_Common_Object
)
20246 Has_Rep_Pragma
(Def_Id
, Name_Psect_Object
)
20248 Error_Msg_N
("??duplicate Common/Psect_Object pragma", N
);
20251 if Ekind
(Def_Id
) = E_Constant
then
20253 ("cannot specify pragma % for a constant", Internal
);
20256 if Is_Record_Type
(Etype
(Internal
)) then
20262 Ent
:= First_Entity
(Etype
(Internal
));
20263 while Present
(Ent
) loop
20264 Decl
:= Declaration_Node
(Ent
);
20266 if Ekind
(Ent
) = E_Component
20267 and then Nkind
(Decl
) = N_Component_Declaration
20268 and then Present
(Expression
(Decl
))
20269 and then Warn_On_Export_Import
20272 ("?x?object for pragma % has defaults", Internal
);
20282 if Present
(Size
) then
20286 if Present
(External
) then
20287 Check_Arg_Is_External_Name
(External
);
20290 -- If all error tests pass, link pragma on to the rep item chain
20292 Record_Rep_Item
(Def_Id
, N
);
20299 -- pragma Pure [(library_unit_NAME)];
20301 when Pragma_Pure
=> Pure
: declare
20305 Check_Ada_83_Warning
;
20307 -- If the pragma comes from a subprogram instantiation, nothing to
20308 -- check, this can happen at any level of nesting.
20310 if Is_Wrapper_Package
(Current_Scope
) then
20313 Check_Valid_Library_Unit_Pragma
;
20316 if Nkind
(N
) = N_Null_Statement
then
20320 Ent
:= Find_Lib_Unit_Name
;
20322 -- A pragma that applies to a Ghost entity becomes Ghost for the
20323 -- purposes of legality checks and removal of ignored Ghost code.
20325 Mark_Ghost_Pragma
(N
, Ent
);
20327 if not Debug_Flag_U
then
20329 Set_Has_Pragma_Pure
(Ent
);
20330 Set_Suppress_Elaboration_Warnings
(Ent
);
20334 -------------------
20335 -- Pure_Function --
20336 -------------------
20338 -- pragma Pure_Function ([Entity =>] function_LOCAL_NAME);
20340 when Pragma_Pure_Function
=> Pure_Function
: declare
20341 Def_Id
: Entity_Id
;
20344 Effective
: Boolean := False;
20348 Check_Arg_Count
(1);
20349 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20350 Check_Arg_Is_Local_Name
(Arg1
);
20351 E_Id
:= Get_Pragma_Arg
(Arg1
);
20353 if Error_Posted
(E_Id
) then
20357 -- Loop through homonyms (overloadings) of referenced entity
20359 E
:= Entity
(E_Id
);
20361 -- A pragma that applies to a Ghost entity becomes Ghost for the
20362 -- purposes of legality checks and removal of ignored Ghost code.
20364 Mark_Ghost_Pragma
(N
, E
);
20366 if Present
(E
) then
20368 Def_Id
:= Get_Base_Subprogram
(E
);
20370 if not Ekind_In
(Def_Id
, E_Function
,
20371 E_Generic_Function
,
20375 ("pragma% requires a function name", Arg1
);
20378 Set_Is_Pure
(Def_Id
);
20380 if not Has_Pragma_Pure_Function
(Def_Id
) then
20381 Set_Has_Pragma_Pure_Function
(Def_Id
);
20385 exit when From_Aspect_Specification
(N
);
20387 exit when No
(E
) or else Scope
(E
) /= Current_Scope
;
20391 and then Warn_On_Redundant_Constructs
20394 ("pragma Pure_Function on& is redundant?r?",
20400 --------------------
20401 -- Queuing_Policy --
20402 --------------------
20404 -- pragma Queuing_Policy (policy_IDENTIFIER);
20406 when Pragma_Queuing_Policy
=> declare
20410 Check_Ada_83_Warning
;
20411 Check_Arg_Count
(1);
20412 Check_No_Identifiers
;
20413 Check_Arg_Is_Queuing_Policy
(Arg1
);
20414 Check_Valid_Configuration_Pragma
;
20415 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
20416 QP
:= Fold_Upper
(Name_Buffer
(1));
20418 if Queuing_Policy
/= ' '
20419 and then Queuing_Policy
/= QP
20421 Error_Msg_Sloc
:= Queuing_Policy_Sloc
;
20422 Error_Pragma
("queuing policy incompatible with policy#");
20424 -- Set new policy, but always preserve System_Location since we
20425 -- like the error message with the run time name.
20428 Queuing_Policy
:= QP
;
20430 if Queuing_Policy_Sloc
/= System_Location
then
20431 Queuing_Policy_Sloc
:= Loc
;
20440 -- pragma Rational, for compatibility with foreign compiler
20442 when Pragma_Rational
=>
20443 Set_Rational_Profile
;
20445 ---------------------
20446 -- Refined_Depends --
20447 ---------------------
20449 -- pragma Refined_Depends (DEPENDENCY_RELATION);
20451 -- DEPENDENCY_RELATION ::=
20453 -- | (DEPENDENCY_CLAUSE {, DEPENDENCY_CLAUSE})
20455 -- DEPENDENCY_CLAUSE ::=
20456 -- OUTPUT_LIST =>[+] INPUT_LIST
20457 -- | NULL_DEPENDENCY_CLAUSE
20459 -- NULL_DEPENDENCY_CLAUSE ::= null => INPUT_LIST
20461 -- OUTPUT_LIST ::= OUTPUT | (OUTPUT {, OUTPUT})
20463 -- INPUT_LIST ::= null | INPUT | (INPUT {, INPUT})
20465 -- OUTPUT ::= NAME | FUNCTION_RESULT
20468 -- where FUNCTION_RESULT is a function Result attribute_reference
20470 -- Characteristics:
20472 -- * Analysis - The annotation undergoes initial checks to verify
20473 -- the legal placement and context. Secondary checks fully analyze
20474 -- the dependency clauses/global list in:
20476 -- Analyze_Refined_Depends_In_Decl_Part
20478 -- * Expansion - None.
20480 -- * Template - The annotation utilizes the generic template of the
20481 -- related subprogram body.
20483 -- * Globals - Capture of global references must occur after full
20486 -- * Instance - The annotation is instantiated automatically when
20487 -- the related generic subprogram body is instantiated.
20489 when Pragma_Refined_Depends
=> Refined_Depends
: declare
20490 Body_Id
: Entity_Id
;
20492 Spec_Id
: Entity_Id
;
20495 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20499 -- Chain the pragma on the contract for further processing by
20500 -- Analyze_Refined_Depends_In_Decl_Part.
20502 Add_Contract_Item
(N
, Body_Id
);
20504 -- The legality checks of pragmas Refined_Depends and
20505 -- Refined_Global are affected by the SPARK mode in effect and
20506 -- the volatility of the context. In addition these two pragmas
20507 -- are subject to an inherent order:
20509 -- 1) Refined_Global
20510 -- 2) Refined_Depends
20512 -- Analyze all these pragmas in the order outlined above
20514 Analyze_If_Present
(Pragma_SPARK_Mode
);
20515 Analyze_If_Present
(Pragma_Volatile_Function
);
20516 Analyze_If_Present
(Pragma_Refined_Global
);
20517 Analyze_Refined_Depends_In_Decl_Part
(N
);
20519 end Refined_Depends
;
20521 --------------------
20522 -- Refined_Global --
20523 --------------------
20525 -- pragma Refined_Global (GLOBAL_SPECIFICATION);
20527 -- GLOBAL_SPECIFICATION ::=
20530 -- | (MODED_GLOBAL_LIST {, MODED_GLOBAL_LIST})
20532 -- MODED_GLOBAL_LIST ::= MODE_SELECTOR => GLOBAL_LIST
20534 -- MODE_SELECTOR ::= In_Out | Input | Output | Proof_In
20535 -- GLOBAL_LIST ::= GLOBAL_ITEM | (GLOBAL_ITEM {, GLOBAL_ITEM})
20536 -- GLOBAL_ITEM ::= NAME
20538 -- Characteristics:
20540 -- * Analysis - The annotation undergoes initial checks to verify
20541 -- the legal placement and context. Secondary checks fully analyze
20542 -- the dependency clauses/global list in:
20544 -- Analyze_Refined_Global_In_Decl_Part
20546 -- * Expansion - None.
20548 -- * Template - The annotation utilizes the generic template of the
20549 -- related subprogram body.
20551 -- * Globals - Capture of global references must occur after full
20554 -- * Instance - The annotation is instantiated automatically when
20555 -- the related generic subprogram body is instantiated.
20557 when Pragma_Refined_Global
=> Refined_Global
: declare
20558 Body_Id
: Entity_Id
;
20560 Spec_Id
: Entity_Id
;
20563 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20567 -- Chain the pragma on the contract for further processing by
20568 -- Analyze_Refined_Global_In_Decl_Part.
20570 Add_Contract_Item
(N
, Body_Id
);
20572 -- The legality checks of pragmas Refined_Depends and
20573 -- Refined_Global are affected by the SPARK mode in effect and
20574 -- the volatility of the context. In addition these two pragmas
20575 -- are subject to an inherent order:
20577 -- 1) Refined_Global
20578 -- 2) Refined_Depends
20580 -- Analyze all these pragmas in the order outlined above
20582 Analyze_If_Present
(Pragma_SPARK_Mode
);
20583 Analyze_If_Present
(Pragma_Volatile_Function
);
20584 Analyze_Refined_Global_In_Decl_Part
(N
);
20585 Analyze_If_Present
(Pragma_Refined_Depends
);
20587 end Refined_Global
;
20593 -- pragma Refined_Post (boolean_EXPRESSION);
20595 -- Characteristics:
20597 -- * Analysis - The annotation is fully analyzed immediately upon
20598 -- elaboration as it cannot forward reference entities.
20600 -- * Expansion - The annotation is expanded during the expansion of
20601 -- the related subprogram body contract as performed in:
20603 -- Expand_Subprogram_Contract
20605 -- * Template - The annotation utilizes the generic template of the
20606 -- related subprogram body.
20608 -- * Globals - Capture of global references must occur after full
20611 -- * Instance - The annotation is instantiated automatically when
20612 -- the related generic subprogram body is instantiated.
20614 when Pragma_Refined_Post
=> Refined_Post
: declare
20615 Body_Id
: Entity_Id
;
20617 Spec_Id
: Entity_Id
;
20620 Analyze_Refined_Depends_Global_Post
(Spec_Id
, Body_Id
, Legal
);
20622 -- Fully analyze the pragma when it appears inside a subprogram
20623 -- body because it cannot benefit from forward references.
20627 -- Chain the pragma on the contract for completeness
20629 Add_Contract_Item
(N
, Body_Id
);
20631 -- The legality checks of pragma Refined_Post are affected by
20632 -- the SPARK mode in effect and the volatility of the context.
20633 -- Analyze all pragmas in a specific order.
20635 Analyze_If_Present
(Pragma_SPARK_Mode
);
20636 Analyze_If_Present
(Pragma_Volatile_Function
);
20637 Analyze_Pre_Post_Condition_In_Decl_Part
(N
);
20639 -- Currently it is not possible to inline pre/postconditions on
20640 -- a subprogram subject to pragma Inline_Always.
20642 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
20646 -------------------
20647 -- Refined_State --
20648 -------------------
20650 -- pragma Refined_State (REFINEMENT_LIST);
20652 -- REFINEMENT_LIST ::=
20653 -- (REFINEMENT_CLAUSE {, REFINEMENT_CLAUSE})
20655 -- REFINEMENT_CLAUSE ::= state_NAME => CONSTITUENT_LIST
20657 -- CONSTITUENT_LIST ::=
20660 -- | (CONSTITUENT {, CONSTITUENT})
20662 -- CONSTITUENT ::= object_NAME | state_NAME
20664 -- Characteristics:
20666 -- * Analysis - The annotation undergoes initial checks to verify
20667 -- the legal placement and context. Secondary checks preanalyze the
20668 -- refinement clauses in:
20670 -- Analyze_Refined_State_In_Decl_Part
20672 -- * Expansion - None.
20674 -- * Template - The annotation utilizes the template of the related
20677 -- * Globals - Capture of global references must occur after full
20680 -- * Instance - The annotation is instantiated automatically when
20681 -- the related generic package body is instantiated.
20683 when Pragma_Refined_State
=> Refined_State
: declare
20684 Pack_Decl
: Node_Id
;
20685 Spec_Id
: Entity_Id
;
20689 Check_No_Identifiers
;
20690 Check_Arg_Count
(1);
20692 Pack_Decl
:= Find_Related_Package_Or_Body
(N
, Do_Checks
=> True);
20694 -- Ensure the proper placement of the pragma. Refined states must
20695 -- be associated with a package body.
20697 if Nkind
(Pack_Decl
) = N_Package_Body
then
20700 -- Otherwise the pragma is associated with an illegal construct
20707 Spec_Id
:= Corresponding_Spec
(Pack_Decl
);
20709 -- A pragma that applies to a Ghost entity becomes Ghost for the
20710 -- purposes of legality checks and removal of ignored Ghost code.
20712 Mark_Ghost_Pragma
(N
, Spec_Id
);
20714 -- Chain the pragma on the contract for further processing by
20715 -- Analyze_Refined_State_In_Decl_Part.
20717 Add_Contract_Item
(N
, Defining_Entity
(Pack_Decl
));
20719 -- The legality checks of pragma Refined_State are affected by the
20720 -- SPARK mode in effect. Analyze all pragmas in a specific order.
20722 Analyze_If_Present
(Pragma_SPARK_Mode
);
20724 -- State refinement is allowed only when the corresponding package
20725 -- declaration has non-null pragma Abstract_State. Refinement not
20726 -- enforced when SPARK checks are suppressed (SPARK RM 7.2.2(3)).
20728 if SPARK_Mode
/= Off
20730 (No
(Abstract_States
(Spec_Id
))
20731 or else Has_Null_Abstract_State
(Spec_Id
))
20734 ("useless refinement, package & does not define abstract "
20735 & "states", N
, Spec_Id
);
20740 -----------------------
20741 -- Relative_Deadline --
20742 -----------------------
20744 -- pragma Relative_Deadline (time_span_EXPRESSION);
20746 when Pragma_Relative_Deadline
=> Relative_Deadline
: declare
20747 P
: constant Node_Id
:= Parent
(N
);
20752 Check_No_Identifiers
;
20753 Check_Arg_Count
(1);
20755 Arg
:= Get_Pragma_Arg
(Arg1
);
20757 -- The expression must be analyzed in the special manner described
20758 -- in "Handling of Default and Per-Object Expressions" in sem.ads.
20760 Preanalyze_Spec_Expression
(Arg
, RTE
(RE_Time_Span
));
20764 if Nkind
(P
) = N_Subprogram_Body
then
20765 Check_In_Main_Program
;
20767 -- Only Task and subprogram cases allowed
20769 elsif Nkind
(P
) /= N_Task_Definition
then
20773 -- Check duplicate pragma before we set the corresponding flag
20775 if Has_Relative_Deadline_Pragma
(P
) then
20776 Error_Pragma
("duplicate pragma% not allowed");
20779 -- Set Has_Relative_Deadline_Pragma only for tasks. Note that
20780 -- Relative_Deadline pragma node cannot be inserted in the Rep
20781 -- Item chain of Ent since it is rewritten by the expander as a
20782 -- procedure call statement that will break the chain.
20784 Set_Has_Relative_Deadline_Pragma
(P
);
20785 end Relative_Deadline
;
20787 ------------------------
20788 -- Remote_Access_Type --
20789 ------------------------
20791 -- pragma Remote_Access_Type ([Entity =>] formal_type_LOCAL_NAME);
20793 when Pragma_Remote_Access_Type
=> Remote_Access_Type
: declare
20798 Check_Arg_Count
(1);
20799 Check_Optional_Identifier
(Arg1
, Name_Entity
);
20800 Check_Arg_Is_Local_Name
(Arg1
);
20802 E
:= Entity
(Get_Pragma_Arg
(Arg1
));
20804 -- A pragma that applies to a Ghost entity becomes Ghost for the
20805 -- purposes of legality checks and removal of ignored Ghost code.
20807 Mark_Ghost_Pragma
(N
, E
);
20809 if Nkind
(Parent
(E
)) = N_Formal_Type_Declaration
20810 and then Ekind
(E
) = E_General_Access_Type
20811 and then Is_Class_Wide_Type
(Directly_Designated_Type
(E
))
20812 and then Scope
(Root_Type
(Directly_Designated_Type
(E
)))
20814 and then Is_Valid_Remote_Object_Type
20815 (Root_Type
(Directly_Designated_Type
(E
)))
20817 Set_Is_Remote_Types
(E
);
20821 ("pragma% applies only to formal access-to-class-wide types",
20824 end Remote_Access_Type
;
20826 ---------------------------
20827 -- Remote_Call_Interface --
20828 ---------------------------
20830 -- pragma Remote_Call_Interface [(library_unit_NAME)];
20832 when Pragma_Remote_Call_Interface
=> Remote_Call_Interface
: declare
20833 Cunit_Node
: Node_Id
;
20834 Cunit_Ent
: Entity_Id
;
20838 Check_Ada_83_Warning
;
20839 Check_Valid_Library_Unit_Pragma
;
20841 if Nkind
(N
) = N_Null_Statement
then
20845 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20846 K
:= Nkind
(Unit
(Cunit_Node
));
20847 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20849 -- A pragma that applies to a Ghost entity becomes Ghost for the
20850 -- purposes of legality checks and removal of ignored Ghost code.
20852 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20854 if K
= N_Package_Declaration
20855 or else K
= N_Generic_Package_Declaration
20856 or else K
= N_Subprogram_Declaration
20857 or else K
= N_Generic_Subprogram_Declaration
20858 or else (K
= N_Subprogram_Body
20859 and then Acts_As_Spec
(Unit
(Cunit_Node
)))
20864 "pragma% must apply to package or subprogram declaration");
20867 Set_Is_Remote_Call_Interface
(Cunit_Ent
);
20868 end Remote_Call_Interface
;
20874 -- pragma Remote_Types [(library_unit_NAME)];
20876 when Pragma_Remote_Types
=> Remote_Types
: declare
20877 Cunit_Node
: Node_Id
;
20878 Cunit_Ent
: Entity_Id
;
20881 Check_Ada_83_Warning
;
20882 Check_Valid_Library_Unit_Pragma
;
20884 if Nkind
(N
) = N_Null_Statement
then
20888 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
20889 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
20891 -- A pragma that applies to a Ghost entity becomes Ghost for the
20892 -- purposes of legality checks and removal of ignored Ghost code.
20894 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
20896 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
20897 N_Generic_Package_Declaration
)
20900 ("pragma% can only apply to a package declaration");
20903 Set_Is_Remote_Types
(Cunit_Ent
);
20910 -- pragma Ravenscar;
20912 when Pragma_Ravenscar
=>
20914 Check_Arg_Count
(0);
20915 Check_Valid_Configuration_Pragma
;
20916 Set_Ravenscar_Profile
(Ravenscar
, N
);
20918 if Warn_On_Obsolescent_Feature
then
20920 ("pragma Ravenscar is an obsolescent feature?j?", N
);
20922 ("|use pragma Profile (Ravenscar) instead?j?", N
);
20925 -------------------------
20926 -- Restricted_Run_Time --
20927 -------------------------
20929 -- pragma Restricted_Run_Time;
20931 when Pragma_Restricted_Run_Time
=>
20933 Check_Arg_Count
(0);
20934 Check_Valid_Configuration_Pragma
;
20935 Set_Profile_Restrictions
20936 (Restricted
, N
, Warn
=> Treat_Restrictions_As_Warnings
);
20938 if Warn_On_Obsolescent_Feature
then
20940 ("pragma Restricted_Run_Time is an obsolescent feature?j?",
20943 ("|use pragma Profile (Restricted) instead?j?", N
);
20950 -- pragma Restrictions (RESTRICTION {, RESTRICTION});
20953 -- restriction_IDENTIFIER
20954 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20956 when Pragma_Restrictions
=>
20957 Process_Restrictions_Or_Restriction_Warnings
20958 (Warn
=> Treat_Restrictions_As_Warnings
);
20960 --------------------------
20961 -- Restriction_Warnings --
20962 --------------------------
20964 -- pragma Restriction_Warnings (RESTRICTION {, RESTRICTION});
20967 -- restriction_IDENTIFIER
20968 -- | restriction_parameter_IDENTIFIER => EXPRESSION
20970 when Pragma_Restriction_Warnings
=>
20972 Process_Restrictions_Or_Restriction_Warnings
(Warn
=> True);
20978 -- pragma Reviewable;
20980 when Pragma_Reviewable
=>
20981 Check_Ada_83_Warning
;
20982 Check_Arg_Count
(0);
20984 -- Call dummy debugging function rv. This is done to assist front
20985 -- end debugging. By placing a Reviewable pragma in the source
20986 -- program, a breakpoint on rv catches this place in the source,
20987 -- allowing convenient stepping to the point of interest.
20991 --------------------------
20992 -- Secondary_Stack_Size --
20993 --------------------------
20995 -- pragma Secondary_Stack_Size (EXPRESSION);
20997 when Pragma_Secondary_Stack_Size
=> Secondary_Stack_Size
: declare
20998 P
: constant Node_Id
:= Parent
(N
);
21004 Check_No_Identifiers
;
21005 Check_Arg_Count
(1);
21007 if Nkind
(P
) = N_Task_Definition
then
21008 Arg
:= Get_Pragma_Arg
(Arg1
);
21009 Ent
:= Defining_Identifier
(Parent
(P
));
21011 -- The expression must be analyzed in the special manner
21012 -- described in "Handling of Default Expressions" in sem.ads.
21014 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
21016 -- The pragma cannot appear if the No_Secondary_Stack
21017 -- restriction is in effect.
21019 Check_Restriction
(No_Secondary_Stack
, Arg
);
21021 -- Anything else is incorrect
21027 -- Check duplicate pragma before we chain the pragma in the Rep
21028 -- Item chain of Ent.
21030 Check_Duplicate_Pragma
(Ent
);
21031 Record_Rep_Item
(Ent
, N
);
21032 end Secondary_Stack_Size
;
21034 --------------------------
21035 -- Short_Circuit_And_Or --
21036 --------------------------
21038 -- pragma Short_Circuit_And_Or;
21040 when Pragma_Short_Circuit_And_Or
=>
21042 Check_Arg_Count
(0);
21043 Check_Valid_Configuration_Pragma
;
21044 Short_Circuit_And_Or
:= True;
21046 -------------------
21047 -- Share_Generic --
21048 -------------------
21050 -- pragma Share_Generic (GNAME {, GNAME});
21052 -- GNAME ::= generic_unit_NAME | generic_instance_NAME
21054 when Pragma_Share_Generic
=>
21056 Process_Generic_List
;
21062 -- pragma Shared (LOCAL_NAME);
21064 when Pragma_Shared
=>
21066 Process_Atomic_Independent_Shared_Volatile
;
21068 --------------------
21069 -- Shared_Passive --
21070 --------------------
21072 -- pragma Shared_Passive [(library_unit_NAME)];
21074 -- Set the flag Is_Shared_Passive of program unit name entity
21076 when Pragma_Shared_Passive
=> Shared_Passive
: declare
21077 Cunit_Node
: Node_Id
;
21078 Cunit_Ent
: Entity_Id
;
21081 Check_Ada_83_Warning
;
21082 Check_Valid_Library_Unit_Pragma
;
21084 if Nkind
(N
) = N_Null_Statement
then
21088 Cunit_Node
:= Cunit
(Current_Sem_Unit
);
21089 Cunit_Ent
:= Cunit_Entity
(Current_Sem_Unit
);
21091 -- A pragma that applies to a Ghost entity becomes Ghost for the
21092 -- purposes of legality checks and removal of ignored Ghost code.
21094 Mark_Ghost_Pragma
(N
, Cunit_Ent
);
21096 if not Nkind_In
(Unit
(Cunit_Node
), N_Package_Declaration
,
21097 N_Generic_Package_Declaration
)
21100 ("pragma% can only apply to a package declaration");
21103 Set_Is_Shared_Passive
(Cunit_Ent
);
21104 end Shared_Passive
;
21106 -----------------------
21107 -- Short_Descriptors --
21108 -----------------------
21110 -- pragma Short_Descriptors;
21112 -- Recognize and validate, but otherwise ignore
21114 when Pragma_Short_Descriptors
=>
21116 Check_Arg_Count
(0);
21117 Check_Valid_Configuration_Pragma
;
21119 ------------------------------
21120 -- Simple_Storage_Pool_Type --
21121 ------------------------------
21123 -- pragma Simple_Storage_Pool_Type (type_LOCAL_NAME);
21125 when Pragma_Simple_Storage_Pool_Type
=>
21126 Simple_Storage_Pool_Type
: declare
21132 Check_Arg_Count
(1);
21133 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
21135 Type_Id
:= Get_Pragma_Arg
(Arg1
);
21136 Find_Type
(Type_Id
);
21137 Typ
:= Entity
(Type_Id
);
21139 if Typ
= Any_Type
then
21143 -- A pragma that applies to a Ghost entity becomes Ghost for the
21144 -- purposes of legality checks and removal of ignored Ghost code.
21146 Mark_Ghost_Pragma
(N
, Typ
);
21148 -- We require the pragma to apply to a type declared in a package
21149 -- declaration, but not (immediately) within a package body.
21151 if Ekind
(Current_Scope
) /= E_Package
21152 or else In_Package_Body
(Current_Scope
)
21155 ("pragma% can only apply to type declared immediately "
21156 & "within a package declaration");
21159 -- A simple storage pool type must be an immutably limited record
21160 -- or private type. If the pragma is given for a private type,
21161 -- the full type is similarly restricted (which is checked later
21162 -- in Freeze_Entity).
21164 if Is_Record_Type
(Typ
)
21165 and then not Is_Limited_View
(Typ
)
21168 ("pragma% can only apply to explicitly limited record type");
21170 elsif Is_Private_Type
(Typ
) and then not Is_Limited_Type
(Typ
) then
21172 ("pragma% can only apply to a private type that is limited");
21174 elsif not Is_Record_Type
(Typ
)
21175 and then not Is_Private_Type
(Typ
)
21178 ("pragma% can only apply to limited record or private type");
21181 Record_Rep_Item
(Typ
, N
);
21182 end Simple_Storage_Pool_Type
;
21184 ----------------------
21185 -- Source_File_Name --
21186 ----------------------
21188 -- There are five forms for this pragma:
21190 -- pragma Source_File_Name (
21191 -- [UNIT_NAME =>] unit_NAME,
21192 -- BODY_FILE_NAME => STRING_LITERAL
21193 -- [, [INDEX =>] INTEGER_LITERAL]);
21195 -- pragma Source_File_Name (
21196 -- [UNIT_NAME =>] unit_NAME,
21197 -- SPEC_FILE_NAME => STRING_LITERAL
21198 -- [, [INDEX =>] INTEGER_LITERAL]);
21200 -- pragma Source_File_Name (
21201 -- BODY_FILE_NAME => STRING_LITERAL
21202 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21203 -- [, CASING => CASING_SPEC]);
21205 -- pragma Source_File_Name (
21206 -- SPEC_FILE_NAME => STRING_LITERAL
21207 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21208 -- [, CASING => CASING_SPEC]);
21210 -- pragma Source_File_Name (
21211 -- SUBUNIT_FILE_NAME => STRING_LITERAL
21212 -- [, DOT_REPLACEMENT => STRING_LITERAL]
21213 -- [, CASING => CASING_SPEC]);
21215 -- CASING_SPEC ::= Uppercase | Lowercase | Mixedcase
21217 -- Pragma Source_File_Name_Project (SFNP) is equivalent to pragma
21218 -- Source_File_Name (SFN), however their usage is exclusive: SFN can
21219 -- only be used when no project file is used, while SFNP can only be
21220 -- used when a project file is used.
21222 -- No processing here. Processing was completed during parsing, since
21223 -- we need to have file names set as early as possible. Units are
21224 -- loaded well before semantic processing starts.
21226 -- The only processing we defer to this point is the check for
21227 -- correct placement.
21229 when Pragma_Source_File_Name
=>
21231 Check_Valid_Configuration_Pragma
;
21233 ------------------------------
21234 -- Source_File_Name_Project --
21235 ------------------------------
21237 -- See Source_File_Name for syntax
21239 -- No processing here. Processing was completed during parsing, since
21240 -- we need to have file names set as early as possible. Units are
21241 -- loaded well before semantic processing starts.
21243 -- The only processing we defer to this point is the check for
21244 -- correct placement.
21246 when Pragma_Source_File_Name_Project
=>
21248 Check_Valid_Configuration_Pragma
;
21250 -- Check that a pragma Source_File_Name_Project is used only in a
21251 -- configuration pragmas file.
21253 -- Pragmas Source_File_Name_Project should only be generated by
21254 -- the Project Manager in configuration pragmas files.
21256 -- This is really an ugly test. It seems to depend on some
21257 -- accidental and undocumented property. At the very least it
21258 -- needs to be documented, but it would be better to have a
21259 -- clean way of testing if we are in a configuration file???
21261 if Present
(Parent
(N
)) then
21263 ("pragma% can only appear in a configuration pragmas file");
21266 ----------------------
21267 -- Source_Reference --
21268 ----------------------
21270 -- pragma Source_Reference (INTEGER_LITERAL [, STRING_LITERAL]);
21272 -- Nothing to do, all processing completed in Par.Prag, since we need
21273 -- the information for possible parser messages that are output.
21275 when Pragma_Source_Reference
=>
21282 -- pragma SPARK_Mode [(On | Off)];
21284 when Pragma_SPARK_Mode
=> Do_SPARK_Mode
: declare
21285 Mode_Id
: SPARK_Mode_Type
;
21287 procedure Check_Pragma_Conformance
21288 (Context_Pragma
: Node_Id
;
21289 Entity
: Entity_Id
;
21290 Entity_Pragma
: Node_Id
);
21291 -- Subsidiary to routines Process_xxx. Verify the SPARK_Mode
21292 -- conformance of pragma N depending the following scenarios:
21294 -- If pragma Context_Pragma is not Empty, verify that pragma N is
21295 -- compatible with the pragma Context_Pragma that was inherited
21296 -- from the context:
21297 -- * If the mode of Context_Pragma is ON, then the new mode can
21299 -- * If the mode of Context_Pragma is OFF, then the only allowed
21300 -- new mode is also OFF. Emit error if this is not the case.
21302 -- If Entity is not Empty, verify that pragma N is compatible with
21303 -- pragma Entity_Pragma that belongs to Entity.
21304 -- * If Entity_Pragma is Empty, always issue an error as this
21305 -- corresponds to the case where a previous section of Entity
21306 -- has no SPARK_Mode set.
21307 -- * If the mode of Entity_Pragma is ON, then the new mode can
21309 -- * If the mode of Entity_Pragma is OFF, then the only allowed
21310 -- new mode is also OFF. Emit error if this is not the case.
21312 procedure Check_Library_Level_Entity
(E
: Entity_Id
);
21313 -- Subsidiary to routines Process_xxx. Verify that the related
21314 -- entity E subject to pragma SPARK_Mode is library-level.
21316 procedure Process_Body
(Decl
: Node_Id
);
21317 -- Verify the legality of pragma SPARK_Mode when it appears as the
21318 -- top of the body declarations of entry, package, protected unit,
21319 -- subprogram or task unit body denoted by Decl.
21321 procedure Process_Overloadable
(Decl
: Node_Id
);
21322 -- Verify the legality of pragma SPARK_Mode when it applies to an
21323 -- entry or [generic] subprogram declaration denoted by Decl.
21325 procedure Process_Private_Part
(Decl
: Node_Id
);
21326 -- Verify the legality of pragma SPARK_Mode when it appears at the
21327 -- top of the private declarations of a package spec, protected or
21328 -- task unit declaration denoted by Decl.
21330 procedure Process_Statement_Part
(Decl
: Node_Id
);
21331 -- Verify the legality of pragma SPARK_Mode when it appears at the
21332 -- top of the statement sequence of a package body denoted by node
21335 procedure Process_Visible_Part
(Decl
: Node_Id
);
21336 -- Verify the legality of pragma SPARK_Mode when it appears at the
21337 -- top of the visible declarations of a package spec, protected or
21338 -- task unit declaration denoted by Decl. The routine is also used
21339 -- on protected or task units declared without a definition.
21341 procedure Set_SPARK_Context
;
21342 -- Subsidiary to routines Process_xxx. Set the global variables
21343 -- which represent the mode of the context from pragma N. Ensure
21344 -- that Dynamic_Elaboration_Checks are off if the new mode is On.
21346 ------------------------------
21347 -- Check_Pragma_Conformance --
21348 ------------------------------
21350 procedure Check_Pragma_Conformance
21351 (Context_Pragma
: Node_Id
;
21352 Entity
: Entity_Id
;
21353 Entity_Pragma
: Node_Id
)
21355 Err_Id
: Entity_Id
;
21359 -- The current pragma may appear without an argument. If this
21360 -- is the case, associate all error messages with the pragma
21363 if Present
(Arg1
) then
21369 -- The mode of the current pragma is compared against that of
21370 -- an enclosing context.
21372 if Present
(Context_Pragma
) then
21373 pragma Assert
(Nkind
(Context_Pragma
) = N_Pragma
);
21375 -- Issue an error if the new mode is less restrictive than
21376 -- that of the context.
21378 if Get_SPARK_Mode_From_Annotation
(Context_Pragma
) = Off
21379 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21382 ("cannot change SPARK_Mode from Off to On", Err_N
);
21383 Error_Msg_Sloc
:= Sloc
(SPARK_Mode_Pragma
);
21384 Error_Msg_N
("\SPARK_Mode was set to Off#", Err_N
);
21389 -- The mode of the current pragma is compared against that of
21390 -- an initial package, protected type, subprogram or task type
21393 if Present
(Entity
) then
21395 -- A simple protected or task type is transformed into an
21396 -- anonymous type whose name cannot be used to issue error
21397 -- messages. Recover the original entity of the type.
21399 if Ekind_In
(Entity
, E_Protected_Type
, E_Task_Type
) then
21402 (Original_Node
(Unit_Declaration_Node
(Entity
)));
21407 -- Both the initial declaration and the completion carry
21408 -- SPARK_Mode pragmas.
21410 if Present
(Entity_Pragma
) then
21411 pragma Assert
(Nkind
(Entity_Pragma
) = N_Pragma
);
21413 -- Issue an error if the new mode is less restrictive
21414 -- than that of the initial declaration.
21416 if Get_SPARK_Mode_From_Annotation
(Entity_Pragma
) = Off
21417 and then Get_SPARK_Mode_From_Annotation
(N
) = On
21419 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21420 Error_Msg_Sloc
:= Sloc
(Entity_Pragma
);
21422 ("\value Off was set for SPARK_Mode on&#",
21427 -- Otherwise the initial declaration lacks a SPARK_Mode
21428 -- pragma in which case the current pragma is illegal as
21429 -- it cannot "complete".
21432 Error_Msg_N
("incorrect use of SPARK_Mode", Err_N
);
21433 Error_Msg_Sloc
:= Sloc
(Err_Id
);
21435 ("\no value was set for SPARK_Mode on&#",
21440 end Check_Pragma_Conformance
;
21442 --------------------------------
21443 -- Check_Library_Level_Entity --
21444 --------------------------------
21446 procedure Check_Library_Level_Entity
(E
: Entity_Id
) is
21447 procedure Add_Entity_To_Name_Buffer
;
21448 -- Add the E_Kind of entity E to the name buffer
21450 -------------------------------
21451 -- Add_Entity_To_Name_Buffer --
21452 -------------------------------
21454 procedure Add_Entity_To_Name_Buffer
is
21456 if Ekind_In
(E
, E_Entry
, E_Entry_Family
) then
21457 Add_Str_To_Name_Buffer
("entry");
21459 elsif Ekind_In
(E
, E_Generic_Package
,
21463 Add_Str_To_Name_Buffer
("package");
21465 elsif Ekind_In
(E
, E_Protected_Body
, E_Protected_Type
) then
21466 Add_Str_To_Name_Buffer
("protected type");
21468 elsif Ekind_In
(E
, E_Function
,
21469 E_Generic_Function
,
21470 E_Generic_Procedure
,
21474 Add_Str_To_Name_Buffer
("subprogram");
21477 pragma Assert
(Ekind_In
(E
, E_Task_Body
, E_Task_Type
));
21478 Add_Str_To_Name_Buffer
("task type");
21480 end Add_Entity_To_Name_Buffer
;
21484 Msg_1
: constant String := "incorrect placement of pragma%";
21487 -- Start of processing for Check_Library_Level_Entity
21490 if not Is_Library_Level_Entity
(E
) then
21491 Error_Msg_Name_1
:= Pname
;
21492 Error_Msg_N
(Fix_Error
(Msg_1
), N
);
21495 Add_Str_To_Name_Buffer
("\& is not a library-level ");
21496 Add_Entity_To_Name_Buffer
;
21498 Msg_2
:= Name_Find
;
21499 Error_Msg_NE
(Get_Name_String
(Msg_2
), N
, E
);
21503 end Check_Library_Level_Entity
;
21509 procedure Process_Body
(Decl
: Node_Id
) is
21510 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21511 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Decl
);
21514 -- Ignore pragma when applied to the special body created for
21515 -- inlining, recognized by its internal name _Parent.
21517 if Chars
(Body_Id
) = Name_uParent
then
21521 Check_Library_Level_Entity
(Body_Id
);
21523 -- For entry bodies, verify the legality against:
21524 -- * The mode of the context
21525 -- * The mode of the spec (if any)
21527 if Nkind_In
(Decl
, N_Entry_Body
, N_Subprogram_Body
) then
21529 -- A stand alone subprogram body
21531 if Body_Id
= Spec_Id
then
21532 Check_Pragma_Conformance
21533 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21535 Entity_Pragma
=> Empty
);
21537 -- An entry or subprogram body that completes a previous
21541 Check_Pragma_Conformance
21542 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21544 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21548 Set_SPARK_Pragma
(Body_Id
, N
);
21549 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21551 -- For package bodies, verify the legality against:
21552 -- * The mode of the context
21553 -- * The mode of the private part
21555 -- This case is separated from protected and task bodies
21556 -- because the statement part of the package body inherits
21557 -- the mode of the body declarations.
21559 elsif Nkind
(Decl
) = N_Package_Body
then
21560 Check_Pragma_Conformance
21561 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21563 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21566 Set_SPARK_Pragma
(Body_Id
, N
);
21567 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21568 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21569 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, True);
21571 -- For protected and task bodies, verify the legality against:
21572 -- * The mode of the context
21573 -- * The mode of the private part
21577 (Nkind_In
(Decl
, N_Protected_Body
, N_Task_Body
));
21579 Check_Pragma_Conformance
21580 (Context_Pragma
=> SPARK_Pragma
(Body_Id
),
21582 Entity_Pragma
=> SPARK_Aux_Pragma
(Spec_Id
));
21585 Set_SPARK_Pragma
(Body_Id
, N
);
21586 Set_SPARK_Pragma_Inherited
(Body_Id
, False);
21590 --------------------------
21591 -- Process_Overloadable --
21592 --------------------------
21594 procedure Process_Overloadable
(Decl
: Node_Id
) is
21595 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21596 Spec_Typ
: constant Entity_Id
:= Etype
(Spec_Id
);
21599 Check_Library_Level_Entity
(Spec_Id
);
21601 -- Verify the legality against:
21602 -- * The mode of the context
21604 Check_Pragma_Conformance
21605 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21607 Entity_Pragma
=> Empty
);
21609 Set_SPARK_Pragma
(Spec_Id
, N
);
21610 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21612 -- When the pragma applies to the anonymous object created for
21613 -- a single task type, decorate the type as well. This scenario
21614 -- arises when the single task type lacks a task definition,
21615 -- therefore there is no issue with respect to a potential
21616 -- pragma SPARK_Mode in the private part.
21618 -- task type Anon_Task_Typ;
21619 -- Obj : Anon_Task_Typ;
21620 -- pragma SPARK_Mode ...;
21622 if Is_Single_Task_Object
(Spec_Id
) then
21623 Set_SPARK_Pragma
(Spec_Typ
, N
);
21624 Set_SPARK_Pragma_Inherited
(Spec_Typ
, False);
21625 Set_SPARK_Aux_Pragma
(Spec_Typ
, N
);
21626 Set_SPARK_Aux_Pragma_Inherited
(Spec_Typ
, True);
21628 end Process_Overloadable
;
21630 --------------------------
21631 -- Process_Private_Part --
21632 --------------------------
21634 procedure Process_Private_Part
(Decl
: Node_Id
) is
21635 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21638 Check_Library_Level_Entity
(Spec_Id
);
21640 -- Verify the legality against:
21641 -- * The mode of the visible declarations
21643 Check_Pragma_Conformance
21644 (Context_Pragma
=> Empty
,
21646 Entity_Pragma
=> SPARK_Pragma
(Spec_Id
));
21649 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21650 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, False);
21651 end Process_Private_Part
;
21653 ----------------------------
21654 -- Process_Statement_Part --
21655 ----------------------------
21657 procedure Process_Statement_Part
(Decl
: Node_Id
) is
21658 Body_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21661 Check_Library_Level_Entity
(Body_Id
);
21663 -- Verify the legality against:
21664 -- * The mode of the body declarations
21666 Check_Pragma_Conformance
21667 (Context_Pragma
=> Empty
,
21669 Entity_Pragma
=> SPARK_Pragma
(Body_Id
));
21672 Set_SPARK_Aux_Pragma
(Body_Id
, N
);
21673 Set_SPARK_Aux_Pragma_Inherited
(Body_Id
, False);
21674 end Process_Statement_Part
;
21676 --------------------------
21677 -- Process_Visible_Part --
21678 --------------------------
21680 procedure Process_Visible_Part
(Decl
: Node_Id
) is
21681 Spec_Id
: constant Entity_Id
:= Defining_Entity
(Decl
);
21682 Obj_Id
: Entity_Id
;
21685 Check_Library_Level_Entity
(Spec_Id
);
21687 -- Verify the legality against:
21688 -- * The mode of the context
21690 Check_Pragma_Conformance
21691 (Context_Pragma
=> SPARK_Pragma
(Spec_Id
),
21693 Entity_Pragma
=> Empty
);
21695 -- A task unit declared without a definition does not set the
21696 -- SPARK_Mode of the context because the task does not have any
21697 -- entries that could inherit the mode.
21699 if not Nkind_In
(Decl
, N_Single_Task_Declaration
,
21700 N_Task_Type_Declaration
)
21705 Set_SPARK_Pragma
(Spec_Id
, N
);
21706 Set_SPARK_Pragma_Inherited
(Spec_Id
, False);
21707 Set_SPARK_Aux_Pragma
(Spec_Id
, N
);
21708 Set_SPARK_Aux_Pragma_Inherited
(Spec_Id
, True);
21710 -- When the pragma applies to a single protected or task type,
21711 -- decorate the corresponding anonymous object as well.
21713 -- protected Anon_Prot_Typ is
21714 -- pragma SPARK_Mode ...;
21716 -- end Anon_Prot_Typ;
21718 -- Obj : Anon_Prot_Typ;
21720 if Is_Single_Concurrent_Type
(Spec_Id
) then
21721 Obj_Id
:= Anonymous_Object
(Spec_Id
);
21723 Set_SPARK_Pragma
(Obj_Id
, N
);
21724 Set_SPARK_Pragma_Inherited
(Obj_Id
, False);
21726 end Process_Visible_Part
;
21728 -----------------------
21729 -- Set_SPARK_Context --
21730 -----------------------
21732 procedure Set_SPARK_Context
is
21734 SPARK_Mode
:= Mode_Id
;
21735 SPARK_Mode_Pragma
:= N
;
21736 end Set_SPARK_Context
;
21744 -- Start of processing for Do_SPARK_Mode
21747 -- When a SPARK_Mode pragma appears inside an instantiation whose
21748 -- enclosing context has SPARK_Mode set to "off", the pragma has
21749 -- no semantic effect.
21751 if Ignore_SPARK_Mode_Pragmas_In_Instance
then
21752 Rewrite
(N
, Make_Null_Statement
(Loc
));
21758 Check_No_Identifiers
;
21759 Check_At_Most_N_Arguments
(1);
21761 -- Check the legality of the mode (no argument = ON)
21763 if Arg_Count
= 1 then
21764 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
21765 Mode
:= Chars
(Get_Pragma_Arg
(Arg1
));
21770 Mode_Id
:= Get_SPARK_Mode_Type
(Mode
);
21771 Context
:= Parent
(N
);
21773 -- The pragma appears in a configuration file
21775 if No
(Context
) then
21776 Check_Valid_Configuration_Pragma
;
21778 if Present
(SPARK_Mode_Pragma
) then
21781 Prev
=> SPARK_Mode_Pragma
);
21787 -- The pragma acts as a configuration pragma in a compilation unit
21789 -- pragma SPARK_Mode ...;
21790 -- package Pack is ...;
21792 elsif Nkind
(Context
) = N_Compilation_Unit
21793 and then List_Containing
(N
) = Context_Items
(Context
)
21795 Check_Valid_Configuration_Pragma
;
21798 -- Otherwise the placement of the pragma within the tree dictates
21799 -- its associated construct. Inspect the declarative list where
21800 -- the pragma resides to find a potential construct.
21804 while Present
(Stmt
) loop
21806 -- Skip prior pragmas, but check for duplicates. Note that
21807 -- this also takes care of pragmas generated for aspects.
21809 if Nkind
(Stmt
) = N_Pragma
then
21810 if Pragma_Name
(Stmt
) = Pname
then
21817 -- The pragma applies to an expression function that has
21818 -- already been rewritten into a subprogram declaration.
21820 -- function Expr_Func return ... is (...);
21821 -- pragma SPARK_Mode ...;
21823 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
21824 and then Nkind
(Original_Node
(Stmt
)) =
21825 N_Expression_Function
21827 Process_Overloadable
(Stmt
);
21830 -- The pragma applies to the anonymous object created for a
21831 -- single concurrent type.
21833 -- protected type Anon_Prot_Typ ...;
21834 -- Obj : Anon_Prot_Typ;
21835 -- pragma SPARK_Mode ...;
21837 elsif Nkind
(Stmt
) = N_Object_Declaration
21838 and then Is_Single_Concurrent_Object
21839 (Defining_Entity
(Stmt
))
21841 Process_Overloadable
(Stmt
);
21844 -- Skip internally generated code
21846 elsif not Comes_From_Source
(Stmt
) then
21849 -- The pragma applies to an entry or [generic] subprogram
21853 -- pragma SPARK_Mode ...;
21856 -- procedure Proc ...;
21857 -- pragma SPARK_Mode ...;
21859 elsif Nkind_In
(Stmt
, N_Generic_Subprogram_Declaration
,
21860 N_Subprogram_Declaration
)
21861 or else (Nkind
(Stmt
) = N_Entry_Declaration
21862 and then Is_Protected_Type
21863 (Scope
(Defining_Entity
(Stmt
))))
21865 Process_Overloadable
(Stmt
);
21868 -- Otherwise the pragma does not apply to a legal construct
21869 -- or it does not appear at the top of a declarative or a
21870 -- statement list. Issue an error and stop the analysis.
21880 -- The pragma applies to a package or a subprogram that acts as
21881 -- a compilation unit.
21883 -- procedure Proc ...;
21884 -- pragma SPARK_Mode ...;
21886 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
21887 Context
:= Unit
(Parent
(Context
));
21890 -- The pragma appears at the top of entry, package, protected
21891 -- unit, subprogram or task unit body declarations.
21893 -- entry Ent when ... is
21894 -- pragma SPARK_Mode ...;
21896 -- package body Pack is
21897 -- pragma SPARK_Mode ...;
21899 -- procedure Proc ... is
21900 -- pragma SPARK_Mode;
21902 -- protected body Prot is
21903 -- pragma SPARK_Mode ...;
21905 if Nkind_In
(Context
, N_Entry_Body
,
21911 Process_Body
(Context
);
21913 -- The pragma appears at the top of the visible or private
21914 -- declaration of a package spec, protected or task unit.
21917 -- pragma SPARK_Mode ...;
21919 -- pragma SPARK_Mode ...;
21921 -- protected [type] Prot is
21922 -- pragma SPARK_Mode ...;
21924 -- pragma SPARK_Mode ...;
21926 elsif Nkind_In
(Context
, N_Package_Specification
,
21927 N_Protected_Definition
,
21930 if List_Containing
(N
) = Visible_Declarations
(Context
) then
21931 Process_Visible_Part
(Parent
(Context
));
21933 Process_Private_Part
(Parent
(Context
));
21936 -- The pragma appears at the top of package body statements
21938 -- package body Pack is
21940 -- pragma SPARK_Mode;
21942 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
21943 and then Nkind
(Parent
(Context
)) = N_Package_Body
21945 Process_Statement_Part
(Parent
(Context
));
21947 -- The pragma appeared as an aspect of a [generic] subprogram
21948 -- declaration that acts as a compilation unit.
21951 -- procedure Proc ...;
21952 -- pragma SPARK_Mode ...;
21954 elsif Nkind_In
(Context
, N_Generic_Subprogram_Declaration
,
21955 N_Subprogram_Declaration
)
21957 Process_Overloadable
(Context
);
21959 -- The pragma does not apply to a legal construct, issue error
21967 --------------------------------
21968 -- Static_Elaboration_Desired --
21969 --------------------------------
21971 -- pragma Static_Elaboration_Desired (DIRECT_NAME);
21973 when Pragma_Static_Elaboration_Desired
=>
21975 Check_At_Most_N_Arguments
(1);
21977 if Is_Compilation_Unit
(Current_Scope
)
21978 and then Ekind
(Current_Scope
) = E_Package
21980 Set_Static_Elaboration_Desired
(Current_Scope
, True);
21982 Error_Pragma
("pragma% must apply to a library-level package");
21989 -- pragma Storage_Size (EXPRESSION);
21991 when Pragma_Storage_Size
=> Storage_Size
: declare
21992 P
: constant Node_Id
:= Parent
(N
);
21996 Check_No_Identifiers
;
21997 Check_Arg_Count
(1);
21999 -- The expression must be analyzed in the special manner described
22000 -- in "Handling of Default Expressions" in sem.ads.
22002 Arg
:= Get_Pragma_Arg
(Arg1
);
22003 Preanalyze_Spec_Expression
(Arg
, Any_Integer
);
22005 if not Is_OK_Static_Expression
(Arg
) then
22006 Check_Restriction
(Static_Storage_Size
, Arg
);
22009 if Nkind
(P
) /= N_Task_Definition
then
22014 if Has_Storage_Size_Pragma
(P
) then
22015 Error_Pragma
("duplicate pragma% not allowed");
22017 Set_Has_Storage_Size_Pragma
(P
, True);
22020 Record_Rep_Item
(Defining_Identifier
(Parent
(P
)), N
);
22028 -- pragma Storage_Unit (NUMERIC_LITERAL);
22030 -- Only permitted argument is System'Storage_Unit value
22032 when Pragma_Storage_Unit
=>
22033 Check_No_Identifiers
;
22034 Check_Arg_Count
(1);
22035 Check_Arg_Is_Integer_Literal
(Arg1
);
22037 if Intval
(Get_Pragma_Arg
(Arg1
)) /=
22038 UI_From_Int
(Ttypes
.System_Storage_Unit
)
22040 Error_Msg_Uint_1
:= UI_From_Int
(Ttypes
.System_Storage_Unit
);
22042 ("the only allowed argument for pragma% is ^", Arg1
);
22045 --------------------
22046 -- Stream_Convert --
22047 --------------------
22049 -- pragma Stream_Convert (
22050 -- [Entity =>] type_LOCAL_NAME,
22051 -- [Read =>] function_NAME,
22052 -- [Write =>] function NAME);
22054 when Pragma_Stream_Convert
=> Stream_Convert
: declare
22055 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
);
22056 -- Check that the given argument is the name of a local function
22057 -- of one argument that is not overloaded earlier in the current
22058 -- local scope. A check is also made that the argument is a
22059 -- function with one parameter.
22061 --------------------------------------
22062 -- Check_OK_Stream_Convert_Function --
22063 --------------------------------------
22065 procedure Check_OK_Stream_Convert_Function
(Arg
: Node_Id
) is
22069 Check_Arg_Is_Local_Name
(Arg
);
22070 Ent
:= Entity
(Get_Pragma_Arg
(Arg
));
22072 if Has_Homonym
(Ent
) then
22074 ("argument for pragma% may not be overloaded", Arg
);
22077 if Ekind
(Ent
) /= E_Function
22078 or else No
(First_Formal
(Ent
))
22079 or else Present
(Next_Formal
(First_Formal
(Ent
)))
22082 ("argument for pragma% must be function of one argument",
22085 end Check_OK_Stream_Convert_Function
;
22087 -- Start of processing for Stream_Convert
22091 Check_Arg_Order
((Name_Entity
, Name_Read
, Name_Write
));
22092 Check_Arg_Count
(3);
22093 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22094 Check_Optional_Identifier
(Arg2
, Name_Read
);
22095 Check_Optional_Identifier
(Arg3
, Name_Write
);
22096 Check_Arg_Is_Local_Name
(Arg1
);
22097 Check_OK_Stream_Convert_Function
(Arg2
);
22098 Check_OK_Stream_Convert_Function
(Arg3
);
22101 Typ
: constant Entity_Id
:=
22102 Underlying_Type
(Entity
(Get_Pragma_Arg
(Arg1
)));
22103 Read
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg2
));
22104 Write
: constant Entity_Id
:= Entity
(Get_Pragma_Arg
(Arg3
));
22107 Check_First_Subtype
(Arg1
);
22109 -- Check for too early or too late. Note that we don't enforce
22110 -- the rule about primitive operations in this case, since, as
22111 -- is the case for explicit stream attributes themselves, these
22112 -- restrictions are not appropriate. Note that the chaining of
22113 -- the pragma by Rep_Item_Too_Late is actually the critical
22114 -- processing done for this pragma.
22116 if Rep_Item_Too_Early
(Typ
, N
)
22118 Rep_Item_Too_Late
(Typ
, N
, FOnly
=> True)
22123 -- Return if previous error
22125 if Etype
(Typ
) = Any_Type
22127 Etype
(Read
) = Any_Type
22129 Etype
(Write
) = Any_Type
22136 if Underlying_Type
(Etype
(Read
)) /= Typ
then
22138 ("incorrect return type for function&", Arg2
);
22141 if Underlying_Type
(Etype
(First_Formal
(Write
))) /= Typ
then
22143 ("incorrect parameter type for function&", Arg3
);
22146 if Underlying_Type
(Etype
(First_Formal
(Read
))) /=
22147 Underlying_Type
(Etype
(Write
))
22150 ("result type of & does not match Read parameter type",
22154 end Stream_Convert
;
22160 -- pragma Style_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
22162 -- This is processed by the parser since some of the style checks
22163 -- take place during source scanning and parsing. This means that
22164 -- we don't need to issue error messages here.
22166 when Pragma_Style_Checks
=> Style_Checks
: declare
22167 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
22173 Check_No_Identifiers
;
22175 -- Two argument form
22177 if Arg_Count
= 2 then
22178 Check_Arg_Is_One_Of
(Arg1
, Name_On
, Name_Off
);
22185 E_Id
:= Get_Pragma_Arg
(Arg2
);
22188 if not Is_Entity_Name
(E_Id
) then
22190 ("second argument of pragma% must be entity name",
22194 E
:= Entity
(E_Id
);
22196 if not Ignore_Style_Checks_Pragmas
then
22201 Set_Suppress_Style_Checks
22202 (E
, Chars
(Get_Pragma_Arg
(Arg1
)) = Name_Off
);
22203 exit when No
(Homonym
(E
));
22210 -- One argument form
22213 Check_Arg_Count
(1);
22215 if Nkind
(A
) = N_String_Literal
then
22219 Slen
: constant Natural := Natural (String_Length
(S
));
22220 Options
: String (1 .. Slen
);
22226 C
:= Get_String_Char
(S
, Pos
(J
));
22227 exit when not In_Character_Range
(C
);
22228 Options
(J
) := Get_Character
(C
);
22230 -- If at end of string, set options. As per discussion
22231 -- above, no need to check for errors, since we issued
22232 -- them in the parser.
22235 if not Ignore_Style_Checks_Pragmas
then
22236 Set_Style_Check_Options
(Options
);
22246 elsif Nkind
(A
) = N_Identifier
then
22247 if Chars
(A
) = Name_All_Checks
then
22248 if not Ignore_Style_Checks_Pragmas
then
22250 Set_GNAT_Style_Check_Options
;
22252 Set_Default_Style_Check_Options
;
22256 elsif Chars
(A
) = Name_On
then
22257 if not Ignore_Style_Checks_Pragmas
then
22258 Style_Check
:= True;
22261 elsif Chars
(A
) = Name_Off
then
22262 if not Ignore_Style_Checks_Pragmas
then
22263 Style_Check
:= False;
22274 -- pragma Subtitle ([Subtitle =>] STRING_LITERAL);
22276 when Pragma_Subtitle
=>
22278 Check_Arg_Count
(1);
22279 Check_Optional_Identifier
(Arg1
, Name_Subtitle
);
22280 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22287 -- pragma Suppress (IDENTIFIER [, [On =>] NAME]);
22289 when Pragma_Suppress
=>
22290 Process_Suppress_Unsuppress
(Suppress_Case
=> True);
22296 -- pragma Suppress_All;
22298 -- The only check made here is that the pragma has no arguments.
22299 -- There are no placement rules, and the processing required (setting
22300 -- the Has_Pragma_Suppress_All flag in the compilation unit node was
22301 -- taken care of by the parser). Process_Compilation_Unit_Pragmas
22302 -- then creates and inserts a pragma Suppress (All_Checks).
22304 when Pragma_Suppress_All
=>
22306 Check_Arg_Count
(0);
22308 -------------------------
22309 -- Suppress_Debug_Info --
22310 -------------------------
22312 -- pragma Suppress_Debug_Info ([Entity =>] LOCAL_NAME);
22314 when Pragma_Suppress_Debug_Info
=> Suppress_Debug_Info
: declare
22315 Nam_Id
: Entity_Id
;
22319 Check_Arg_Count
(1);
22320 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22321 Check_Arg_Is_Local_Name
(Arg1
);
22323 Nam_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
22325 -- A pragma that applies to a Ghost entity becomes Ghost for the
22326 -- purposes of legality checks and removal of ignored Ghost code.
22328 Mark_Ghost_Pragma
(N
, Nam_Id
);
22329 Set_Debug_Info_Off
(Nam_Id
);
22330 end Suppress_Debug_Info
;
22332 ----------------------------------
22333 -- Suppress_Exception_Locations --
22334 ----------------------------------
22336 -- pragma Suppress_Exception_Locations;
22338 when Pragma_Suppress_Exception_Locations
=>
22340 Check_Arg_Count
(0);
22341 Check_Valid_Configuration_Pragma
;
22342 Exception_Locations_Suppressed
:= True;
22344 -----------------------------
22345 -- Suppress_Initialization --
22346 -----------------------------
22348 -- pragma Suppress_Initialization ([Entity =>] type_Name);
22350 when Pragma_Suppress_Initialization
=> Suppress_Init
: declare
22356 Check_Arg_Count
(1);
22357 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22358 Check_Arg_Is_Local_Name
(Arg1
);
22360 E_Id
:= Get_Pragma_Arg
(Arg1
);
22362 if Etype
(E_Id
) = Any_Type
then
22366 E
:= Entity
(E_Id
);
22368 -- A pragma that applies to a Ghost entity becomes Ghost for the
22369 -- purposes of legality checks and removal of ignored Ghost code.
22371 Mark_Ghost_Pragma
(N
, E
);
22373 if not Is_Type
(E
) and then Ekind
(E
) /= E_Variable
then
22375 ("pragma% requires variable, type or subtype", Arg1
);
22378 if Rep_Item_Too_Early
(E
, N
)
22380 Rep_Item_Too_Late
(E
, N
, FOnly
=> True)
22385 -- For incomplete/private type, set flag on full view
22387 if Is_Incomplete_Or_Private_Type
(E
) then
22388 if No
(Full_View
(Base_Type
(E
))) then
22390 ("argument of pragma% cannot be an incomplete type", Arg1
);
22392 Set_Suppress_Initialization
(Full_View
(Base_Type
(E
)));
22395 -- For first subtype, set flag on base type
22397 elsif Is_First_Subtype
(E
) then
22398 Set_Suppress_Initialization
(Base_Type
(E
));
22400 -- For other than first subtype, set flag on subtype or variable
22403 Set_Suppress_Initialization
(E
);
22411 -- pragma System_Name (DIRECT_NAME);
22413 -- Syntax check: one argument, which must be the identifier GNAT or
22414 -- the identifier GCC, no other identifiers are acceptable.
22416 when Pragma_System_Name
=>
22418 Check_No_Identifiers
;
22419 Check_Arg_Count
(1);
22420 Check_Arg_Is_One_Of
(Arg1
, Name_Gcc
, Name_Gnat
);
22422 -----------------------------
22423 -- Task_Dispatching_Policy --
22424 -----------------------------
22426 -- pragma Task_Dispatching_Policy (policy_IDENTIFIER);
22428 when Pragma_Task_Dispatching_Policy
=> declare
22432 Check_Ada_83_Warning
;
22433 Check_Arg_Count
(1);
22434 Check_No_Identifiers
;
22435 Check_Arg_Is_Task_Dispatching_Policy
(Arg1
);
22436 Check_Valid_Configuration_Pragma
;
22437 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
22438 DP
:= Fold_Upper
(Name_Buffer
(1));
22440 if Task_Dispatching_Policy
/= ' '
22441 and then Task_Dispatching_Policy
/= DP
22443 Error_Msg_Sloc
:= Task_Dispatching_Policy_Sloc
;
22445 ("task dispatching policy incompatible with policy#");
22447 -- Set new policy, but always preserve System_Location since we
22448 -- like the error message with the run time name.
22451 Task_Dispatching_Policy
:= DP
;
22453 if Task_Dispatching_Policy_Sloc
/= System_Location
then
22454 Task_Dispatching_Policy_Sloc
:= Loc
;
22463 -- pragma Task_Info (EXPRESSION);
22465 when Pragma_Task_Info
=> Task_Info
: declare
22466 P
: constant Node_Id
:= Parent
(N
);
22472 if Warn_On_Obsolescent_Feature
then
22474 ("'G'N'A'T pragma Task_Info is now obsolete, use 'C'P'U "
22475 & "instead?j?", N
);
22478 if Nkind
(P
) /= N_Task_Definition
then
22479 Error_Pragma
("pragma% must appear in task definition");
22482 Check_No_Identifiers
;
22483 Check_Arg_Count
(1);
22485 Analyze_And_Resolve
22486 (Get_Pragma_Arg
(Arg1
), RTE
(RE_Task_Info_Type
));
22488 if Etype
(Get_Pragma_Arg
(Arg1
)) = Any_Type
then
22492 Ent
:= Defining_Identifier
(Parent
(P
));
22494 -- Check duplicate pragma before we chain the pragma in the Rep
22495 -- Item chain of Ent.
22498 (Ent
, Name_Task_Info
, Check_Parents
=> False)
22500 Error_Pragma
("duplicate pragma% not allowed");
22503 Record_Rep_Item
(Ent
, N
);
22510 -- pragma Task_Name (string_EXPRESSION);
22512 when Pragma_Task_Name
=> Task_Name
: declare
22513 P
: constant Node_Id
:= Parent
(N
);
22518 Check_No_Identifiers
;
22519 Check_Arg_Count
(1);
22521 Arg
:= Get_Pragma_Arg
(Arg1
);
22523 -- The expression is used in the call to Create_Task, and must be
22524 -- expanded there, not in the context of the current spec. It must
22525 -- however be analyzed to capture global references, in case it
22526 -- appears in a generic context.
22528 Preanalyze_And_Resolve
(Arg
, Standard_String
);
22530 if Nkind
(P
) /= N_Task_Definition
then
22534 Ent
:= Defining_Identifier
(Parent
(P
));
22536 -- Check duplicate pragma before we chain the pragma in the Rep
22537 -- Item chain of Ent.
22540 (Ent
, Name_Task_Name
, Check_Parents
=> False)
22542 Error_Pragma
("duplicate pragma% not allowed");
22545 Record_Rep_Item
(Ent
, N
);
22552 -- pragma Task_Storage (
22553 -- [Task_Type =>] LOCAL_NAME,
22554 -- [Top_Guard =>] static_integer_EXPRESSION);
22556 when Pragma_Task_Storage
=> Task_Storage
: declare
22557 Args
: Args_List
(1 .. 2);
22558 Names
: constant Name_List
(1 .. 2) := (
22562 Task_Type
: Node_Id
renames Args
(1);
22563 Top_Guard
: Node_Id
renames Args
(2);
22569 Gather_Associations
(Names
, Args
);
22571 if No
(Task_Type
) then
22573 ("missing task_type argument for pragma%");
22576 Check_Arg_Is_Local_Name
(Task_Type
);
22578 Ent
:= Entity
(Task_Type
);
22580 if not Is_Task_Type
(Ent
) then
22582 ("argument for pragma% must be task type", Task_Type
);
22585 if No
(Top_Guard
) then
22587 ("pragma% takes two arguments", Task_Type
);
22589 Check_Arg_Is_OK_Static_Expression
(Top_Guard
, Any_Integer
);
22592 Check_First_Subtype
(Task_Type
);
22594 if Rep_Item_Too_Late
(Ent
, N
) then
22603 -- pragma Test_Case
22604 -- ([Name =>] Static_String_EXPRESSION
22605 -- ,[Mode =>] MODE_TYPE
22606 -- [, Requires => Boolean_EXPRESSION]
22607 -- [, Ensures => Boolean_EXPRESSION]);
22609 -- MODE_TYPE ::= Nominal | Robustness
22611 -- Characteristics:
22613 -- * Analysis - The annotation undergoes initial checks to verify
22614 -- the legal placement and context. Secondary checks preanalyze the
22617 -- Analyze_Test_Case_In_Decl_Part
22619 -- * Expansion - None.
22621 -- * Template - The annotation utilizes the generic template of the
22622 -- related subprogram when it is:
22624 -- aspect on subprogram declaration
22626 -- The annotation must prepare its own template when it is:
22628 -- pragma on subprogram declaration
22630 -- * Globals - Capture of global references must occur after full
22633 -- * Instance - The annotation is instantiated automatically when
22634 -- the related generic subprogram is instantiated except for the
22635 -- "pragma on subprogram declaration" case. In that scenario the
22636 -- annotation must instantiate itself.
22638 when Pragma_Test_Case
=> Test_Case
: declare
22639 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
);
22640 -- Ensure that the contract of subprogram Subp_Id does not contain
22641 -- another Test_Case pragma with the same Name as the current one.
22643 -------------------------
22644 -- Check_Distinct_Name --
22645 -------------------------
22647 procedure Check_Distinct_Name
(Subp_Id
: Entity_Id
) is
22648 Items
: constant Node_Id
:= Contract
(Subp_Id
);
22649 Name
: constant String_Id
:= Get_Name_From_CTC_Pragma
(N
);
22653 -- Inspect all Test_Case pragma of the related subprogram
22654 -- looking for one with a duplicate "Name" argument.
22656 if Present
(Items
) then
22657 Prag
:= Contract_Test_Cases
(Items
);
22658 while Present
(Prag
) loop
22659 if Pragma_Name
(Prag
) = Name_Test_Case
22661 and then String_Equal
22662 (Name
, Get_Name_From_CTC_Pragma
(Prag
))
22664 Error_Msg_Sloc
:= Sloc
(Prag
);
22665 Error_Pragma
("name for pragma % is already used #");
22668 Prag
:= Next_Pragma
(Prag
);
22671 end Check_Distinct_Name
;
22675 Pack_Decl
: constant Node_Id
:= Unit
(Cunit
(Current_Sem_Unit
));
22678 Subp_Decl
: Node_Id
;
22679 Subp_Id
: Entity_Id
;
22681 -- Start of processing for Test_Case
22685 Check_At_Least_N_Arguments
(2);
22686 Check_At_Most_N_Arguments
(4);
22688 ((Name_Name
, Name_Mode
, Name_Requires
, Name_Ensures
));
22692 Check_Optional_Identifier
(Arg1
, Name_Name
);
22693 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_String
);
22697 Check_Optional_Identifier
(Arg2
, Name_Mode
);
22698 Check_Arg_Is_One_Of
(Arg2
, Name_Nominal
, Name_Robustness
);
22700 -- Arguments "Requires" and "Ensures"
22702 if Present
(Arg3
) then
22703 if Present
(Arg4
) then
22704 Check_Identifier
(Arg3
, Name_Requires
);
22705 Check_Identifier
(Arg4
, Name_Ensures
);
22707 Check_Identifier_Is_One_Of
22708 (Arg3
, Name_Requires
, Name_Ensures
);
22712 -- Pragma Test_Case must be associated with a subprogram declared
22713 -- in a library-level package. First determine whether the current
22714 -- compilation unit is a legal context.
22716 if Nkind_In
(Pack_Decl
, N_Package_Declaration
,
22717 N_Generic_Package_Declaration
)
22721 -- Otherwise the placement is illegal
22725 ("pragma % must be specified within a package declaration");
22729 Subp_Decl
:= Find_Related_Declaration_Or_Body
(N
);
22731 -- Find the enclosing context
22733 Context
:= Parent
(Subp_Decl
);
22735 if Present
(Context
) then
22736 Context
:= Parent
(Context
);
22739 -- Verify the placement of the pragma
22741 if Nkind
(Subp_Decl
) = N_Abstract_Subprogram_Declaration
then
22743 ("pragma % cannot be applied to abstract subprogram");
22746 elsif Nkind
(Subp_Decl
) = N_Entry_Declaration
then
22747 Error_Pragma
("pragma % cannot be applied to entry");
22750 -- The context is a [generic] subprogram declared at the top level
22751 -- of the [generic] package unit.
22753 elsif Nkind_In
(Subp_Decl
, N_Generic_Subprogram_Declaration
,
22754 N_Subprogram_Declaration
)
22755 and then Present
(Context
)
22756 and then Nkind_In
(Context
, N_Generic_Package_Declaration
,
22757 N_Package_Declaration
)
22761 -- Otherwise the placement is illegal
22765 ("pragma % must be applied to a library-level subprogram "
22770 Subp_Id
:= Defining_Entity
(Subp_Decl
);
22772 -- A pragma that applies to a Ghost entity becomes Ghost for the
22773 -- purposes of legality checks and removal of ignored Ghost code.
22775 Mark_Ghost_Pragma
(N
, Subp_Id
);
22777 -- Chain the pragma on the contract for further processing by
22778 -- Analyze_Test_Case_In_Decl_Part.
22780 Add_Contract_Item
(N
, Subp_Id
);
22782 -- Preanalyze the original aspect argument "Name" for ASIS or for
22783 -- a generic subprogram to properly capture global references.
22785 if ASIS_Mode
or else Is_Generic_Subprogram
(Subp_Id
) then
22786 Asp_Arg
:= Test_Case_Arg
(N
, Name_Name
, From_Aspect
=> True);
22788 if Present
(Asp_Arg
) then
22790 -- The argument appears with an identifier in association
22793 if Nkind
(Asp_Arg
) = N_Component_Association
then
22794 Asp_Arg
:= Expression
(Asp_Arg
);
22797 Check_Expr_Is_OK_Static_Expression
22798 (Asp_Arg
, Standard_String
);
22802 -- Ensure that the all Test_Case pragmas of the related subprogram
22803 -- have distinct names.
22805 Check_Distinct_Name
(Subp_Id
);
22807 -- Fully analyze the pragma when it appears inside an entry
22808 -- or subprogram body because it cannot benefit from forward
22811 if Nkind_In
(Subp_Decl
, N_Entry_Body
,
22813 N_Subprogram_Body_Stub
)
22815 -- The legality checks of pragma Test_Case are affected by the
22816 -- SPARK mode in effect and the volatility of the context.
22817 -- Analyze all pragmas in a specific order.
22819 Analyze_If_Present
(Pragma_SPARK_Mode
);
22820 Analyze_If_Present
(Pragma_Volatile_Function
);
22821 Analyze_Test_Case_In_Decl_Part
(N
);
22825 --------------------------
22826 -- Thread_Local_Storage --
22827 --------------------------
22829 -- pragma Thread_Local_Storage ([Entity =>] LOCAL_NAME);
22831 when Pragma_Thread_Local_Storage
=> Thread_Local_Storage
: declare
22837 Check_Arg_Count
(1);
22838 Check_Optional_Identifier
(Arg1
, Name_Entity
);
22839 Check_Arg_Is_Library_Level_Local_Name
(Arg1
);
22841 Id
:= Get_Pragma_Arg
(Arg1
);
22844 if not Is_Entity_Name
(Id
)
22845 or else Ekind
(Entity
(Id
)) /= E_Variable
22847 Error_Pragma_Arg
("local variable name required", Arg1
);
22852 -- A pragma that applies to a Ghost entity becomes Ghost for the
22853 -- purposes of legality checks and removal of ignored Ghost code.
22855 Mark_Ghost_Pragma
(N
, E
);
22857 if Rep_Item_Too_Early
(E
, N
)
22859 Rep_Item_Too_Late
(E
, N
)
22864 Set_Has_Pragma_Thread_Local_Storage
(E
);
22865 Set_Has_Gigi_Rep_Item
(E
);
22866 end Thread_Local_Storage
;
22872 -- pragma Time_Slice (static_duration_EXPRESSION);
22874 when Pragma_Time_Slice
=> Time_Slice
: declare
22880 Check_Arg_Count
(1);
22881 Check_No_Identifiers
;
22882 Check_In_Main_Program
;
22883 Check_Arg_Is_OK_Static_Expression
(Arg1
, Standard_Duration
);
22885 if not Error_Posted
(Arg1
) then
22887 while Present
(Nod
) loop
22888 if Nkind
(Nod
) = N_Pragma
22889 and then Pragma_Name
(Nod
) = Name_Time_Slice
22891 Error_Msg_Name_1
:= Pname
;
22892 Error_Msg_N
("duplicate pragma% not permitted", Nod
);
22899 -- Process only if in main unit
22901 if Get_Source_Unit
(Loc
) = Main_Unit
then
22902 Opt
.Time_Slice_Set
:= True;
22903 Val
:= Expr_Value_R
(Get_Pragma_Arg
(Arg1
));
22905 if Val
<= Ureal_0
then
22906 Opt
.Time_Slice_Value
:= 0;
22908 elsif Val
> UR_From_Uint
(UI_From_Int
(1000)) then
22909 Opt
.Time_Slice_Value
:= 1_000_000_000
;
22912 Opt
.Time_Slice_Value
:=
22913 UI_To_Int
(UR_To_Uint
(Val
* UI_From_Int
(1_000_000
)));
22922 -- pragma Title (TITLING_OPTION [, TITLING OPTION]);
22924 -- TITLING_OPTION ::=
22925 -- [Title =>] STRING_LITERAL
22926 -- | [Subtitle =>] STRING_LITERAL
22928 when Pragma_Title
=> Title
: declare
22929 Args
: Args_List
(1 .. 2);
22930 Names
: constant Name_List
(1 .. 2) := (
22936 Gather_Associations
(Names
, Args
);
22939 for J
in 1 .. 2 loop
22940 if Present
(Args
(J
)) then
22941 Check_Arg_Is_OK_Static_Expression
22942 (Args
(J
), Standard_String
);
22947 ----------------------------
22948 -- Type_Invariant[_Class] --
22949 ----------------------------
22951 -- pragma Type_Invariant[_Class]
22952 -- ([Entity =>] type_LOCAL_NAME,
22953 -- [Check =>] EXPRESSION);
22955 when Pragma_Type_Invariant
22956 | Pragma_Type_Invariant_Class
22958 Type_Invariant
: declare
22959 I_Pragma
: Node_Id
;
22962 Check_Arg_Count
(2);
22964 -- Rewrite Type_Invariant[_Class] pragma as an Invariant pragma,
22965 -- setting Class_Present for the Type_Invariant_Class case.
22967 Set_Class_Present
(N
, Prag_Id
= Pragma_Type_Invariant_Class
);
22968 I_Pragma
:= New_Copy
(N
);
22969 Set_Pragma_Identifier
22970 (I_Pragma
, Make_Identifier
(Loc
, Name_Invariant
));
22971 Rewrite
(N
, I_Pragma
);
22972 Set_Analyzed
(N
, False);
22974 end Type_Invariant
;
22976 ---------------------
22977 -- Unchecked_Union --
22978 ---------------------
22980 -- pragma Unchecked_Union (first_subtype_LOCAL_NAME)
22982 when Pragma_Unchecked_Union
=> Unchecked_Union
: declare
22983 Assoc
: constant Node_Id
:= Arg1
;
22984 Type_Id
: constant Node_Id
:= Get_Pragma_Arg
(Assoc
);
22994 Check_No_Identifiers
;
22995 Check_Arg_Count
(1);
22996 Check_Arg_Is_Local_Name
(Arg1
);
22998 Find_Type
(Type_Id
);
23000 Typ
:= Entity
(Type_Id
);
23002 -- A pragma that applies to a Ghost entity becomes Ghost for the
23003 -- purposes of legality checks and removal of ignored Ghost code.
23005 Mark_Ghost_Pragma
(N
, Typ
);
23008 or else Rep_Item_Too_Early
(Typ
, N
)
23012 Typ
:= Underlying_Type
(Typ
);
23015 if Rep_Item_Too_Late
(Typ
, N
) then
23019 Check_First_Subtype
(Arg1
);
23021 -- Note remaining cases are references to a type in the current
23022 -- declarative part. If we find an error, we post the error on
23023 -- the relevant type declaration at an appropriate point.
23025 if not Is_Record_Type
(Typ
) then
23026 Error_Msg_N
("unchecked union must be record type", Typ
);
23029 elsif Is_Tagged_Type
(Typ
) then
23030 Error_Msg_N
("unchecked union must not be tagged", Typ
);
23033 elsif not Has_Discriminants
(Typ
) then
23035 ("unchecked union must have one discriminant", Typ
);
23038 -- Note: in previous versions of GNAT we used to check for limited
23039 -- types and give an error, but in fact the standard does allow
23040 -- Unchecked_Union on limited types, so this check was removed.
23042 -- Similarly, GNAT used to require that all discriminants have
23043 -- default values, but this is not mandated by the RM.
23045 -- Proceed with basic error checks completed
23048 Tdef
:= Type_Definition
(Declaration_Node
(Typ
));
23049 Clist
:= Component_List
(Tdef
);
23051 -- Check presence of component list and variant part
23053 if No
(Clist
) or else No
(Variant_Part
(Clist
)) then
23055 ("unchecked union must have variant part", Tdef
);
23059 -- Check components
23061 Comp
:= First
(Component_Items
(Clist
));
23062 while Present
(Comp
) loop
23063 Check_Component
(Comp
, Typ
);
23067 -- Check variant part
23069 Vpart
:= Variant_Part
(Clist
);
23071 Variant
:= First
(Variants
(Vpart
));
23072 while Present
(Variant
) loop
23073 Check_Variant
(Variant
, Typ
);
23078 Set_Is_Unchecked_Union
(Typ
);
23079 Set_Convention
(Typ
, Convention_C
);
23080 Set_Has_Unchecked_Union
(Base_Type
(Typ
));
23081 Set_Is_Unchecked_Union
(Base_Type
(Typ
));
23082 end Unchecked_Union
;
23084 ----------------------------
23085 -- Unevaluated_Use_Of_Old --
23086 ----------------------------
23088 -- pragma Unevaluated_Use_Of_Old (Error | Warn | Allow);
23090 when Pragma_Unevaluated_Use_Of_Old
=>
23092 Check_Arg_Count
(1);
23093 Check_No_Identifiers
;
23094 Check_Arg_Is_One_Of
(Arg1
, Name_Error
, Name_Warn
, Name_Allow
);
23096 -- Suppress/Unsuppress can appear as a configuration pragma, or in
23097 -- a declarative part or a package spec.
23099 if not Is_Configuration_Pragma
then
23100 Check_Is_In_Decl_Part_Or_Package_Spec
;
23103 -- Store proper setting of Uneval_Old
23105 Get_Name_String
(Chars
(Get_Pragma_Arg
(Arg1
)));
23106 Uneval_Old
:= Fold_Upper
(Name_Buffer
(1));
23108 ------------------------
23109 -- Unimplemented_Unit --
23110 ------------------------
23112 -- pragma Unimplemented_Unit;
23114 -- Note: this only gives an error if we are generating code, or if
23115 -- we are in a generic library unit (where the pragma appears in the
23116 -- body, not in the spec).
23118 when Pragma_Unimplemented_Unit
=> Unimplemented_Unit
: declare
23119 Cunitent
: constant Entity_Id
:=
23120 Cunit_Entity
(Get_Source_Unit
(Loc
));
23121 Ent_Kind
: constant Entity_Kind
:= Ekind
(Cunitent
);
23125 Check_Arg_Count
(0);
23127 if Operating_Mode
= Generate_Code
23128 or else Ent_Kind
= E_Generic_Function
23129 or else Ent_Kind
= E_Generic_Procedure
23130 or else Ent_Kind
= E_Generic_Package
23132 Get_Name_String
(Chars
(Cunitent
));
23133 Set_Casing
(Mixed_Case
);
23134 Write_Str
(Name_Buffer
(1 .. Name_Len
));
23135 Write_Str
(" is not supported in this configuration");
23137 raise Unrecoverable_Error
;
23139 end Unimplemented_Unit
;
23141 ------------------------
23142 -- Universal_Aliasing --
23143 ------------------------
23145 -- pragma Universal_Aliasing [([Entity =>] type_LOCAL_NAME)];
23147 when Pragma_Universal_Aliasing
=> Universal_Alias
: declare
23152 Check_Arg_Count
(1);
23153 Check_Optional_Identifier
(Arg2
, Name_Entity
);
23154 Check_Arg_Is_Local_Name
(Arg1
);
23155 E_Id
:= Entity
(Get_Pragma_Arg
(Arg1
));
23157 if E_Id
= Any_Type
then
23159 elsif No
(E_Id
) or else not Is_Type
(E_Id
) then
23160 Error_Pragma_Arg
("pragma% requires type", Arg1
);
23163 -- A pragma that applies to a Ghost entity becomes Ghost for the
23164 -- purposes of legality checks and removal of ignored Ghost code.
23166 Mark_Ghost_Pragma
(N
, E_Id
);
23167 Set_Universal_Aliasing
(Implementation_Base_Type
(E_Id
));
23168 Record_Rep_Item
(E_Id
, N
);
23169 end Universal_Alias
;
23171 --------------------
23172 -- Universal_Data --
23173 --------------------
23175 -- pragma Universal_Data [(library_unit_NAME)];
23177 when Pragma_Universal_Data
=>
23179 Error_Pragma
("??pragma% ignored (applies only to AAMP)");
23185 -- pragma Unmodified (LOCAL_NAME {, LOCAL_NAME});
23187 when Pragma_Unmodified
=>
23188 Analyze_Unmodified_Or_Unused
;
23194 -- pragma Unreferenced (LOCAL_NAME {, LOCAL_NAME});
23196 -- or when used in a context clause:
23198 -- pragma Unreferenced (library_unit_NAME {, library_unit_NAME}
23200 when Pragma_Unreferenced
=>
23201 Analyze_Unreferenced_Or_Unused
;
23203 --------------------------
23204 -- Unreferenced_Objects --
23205 --------------------------
23207 -- pragma Unreferenced_Objects (LOCAL_NAME {, LOCAL_NAME});
23209 when Pragma_Unreferenced_Objects
=> Unreferenced_Objects
: declare
23211 Arg_Expr
: Node_Id
;
23212 Arg_Id
: Entity_Id
;
23214 Ghost_Error_Posted
: Boolean := False;
23215 -- Flag set when an error concerning the illegal mix of Ghost and
23216 -- non-Ghost types is emitted.
23218 Ghost_Id
: Entity_Id
:= Empty
;
23219 -- The entity of the first Ghost type encountered while processing
23220 -- the arguments of the pragma.
23224 Check_At_Least_N_Arguments
(1);
23227 while Present
(Arg
) loop
23228 Check_No_Identifier
(Arg
);
23229 Check_Arg_Is_Local_Name
(Arg
);
23230 Arg_Expr
:= Get_Pragma_Arg
(Arg
);
23232 if Is_Entity_Name
(Arg_Expr
) then
23233 Arg_Id
:= Entity
(Arg_Expr
);
23235 if Is_Type
(Arg_Id
) then
23236 Set_Has_Pragma_Unreferenced_Objects
(Arg_Id
);
23238 -- A pragma that applies to a Ghost entity becomes Ghost
23239 -- for the purposes of legality checks and removal of
23240 -- ignored Ghost code.
23242 Mark_Ghost_Pragma
(N
, Arg_Id
);
23244 -- Capture the entity of the first Ghost type being
23245 -- processed for error detection purposes.
23247 if Is_Ghost_Entity
(Arg_Id
) then
23248 if No
(Ghost_Id
) then
23249 Ghost_Id
:= Arg_Id
;
23252 -- Otherwise the type is non-Ghost. It is illegal to mix
23253 -- references to Ghost and non-Ghost entities
23256 elsif Present
(Ghost_Id
)
23257 and then not Ghost_Error_Posted
23259 Ghost_Error_Posted
:= True;
23261 Error_Msg_Name_1
:= Pname
;
23263 ("pragma % cannot mention ghost and non-ghost types",
23266 Error_Msg_Sloc
:= Sloc
(Ghost_Id
);
23267 Error_Msg_NE
("\& # declared as ghost", N
, Ghost_Id
);
23269 Error_Msg_Sloc
:= Sloc
(Arg_Id
);
23270 Error_Msg_NE
("\& # declared as non-ghost", N
, Arg_Id
);
23274 ("argument for pragma% must be type or subtype", Arg
);
23278 ("argument for pragma% must be type or subtype", Arg
);
23283 end Unreferenced_Objects
;
23285 ------------------------------
23286 -- Unreserve_All_Interrupts --
23287 ------------------------------
23289 -- pragma Unreserve_All_Interrupts;
23291 when Pragma_Unreserve_All_Interrupts
=>
23293 Check_Arg_Count
(0);
23295 if In_Extended_Main_Code_Unit
(Main_Unit_Entity
) then
23296 Unreserve_All_Interrupts
:= True;
23303 -- pragma Unsuppress (IDENTIFIER [, [On =>] NAME]);
23305 when Pragma_Unsuppress
=>
23307 Process_Suppress_Unsuppress
(Suppress_Case
=> False);
23313 -- pragma Unused (LOCAL_NAME {, LOCAL_NAME});
23315 when Pragma_Unused
=>
23316 Analyze_Unmodified_Or_Unused
(Is_Unused
=> True);
23317 Analyze_Unreferenced_Or_Unused
(Is_Unused
=> True);
23319 -------------------
23320 -- Use_VADS_Size --
23321 -------------------
23323 -- pragma Use_VADS_Size;
23325 when Pragma_Use_VADS_Size
=>
23327 Check_Arg_Count
(0);
23328 Check_Valid_Configuration_Pragma
;
23329 Use_VADS_Size
:= True;
23331 ---------------------
23332 -- Validity_Checks --
23333 ---------------------
23335 -- pragma Validity_Checks (On | Off | ALL_CHECKS | STRING_LITERAL);
23337 when Pragma_Validity_Checks
=> Validity_Checks
: declare
23338 A
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
23344 Check_Arg_Count
(1);
23345 Check_No_Identifiers
;
23347 -- Pragma always active unless in CodePeer or GNATprove modes,
23348 -- which use a fixed configuration of validity checks.
23350 if not (CodePeer_Mode
or GNATprove_Mode
) then
23351 if Nkind
(A
) = N_String_Literal
then
23355 Slen
: constant Natural := Natural (String_Length
(S
));
23356 Options
: String (1 .. Slen
);
23360 -- Couldn't we use a for loop here over Options'Range???
23364 C
:= Get_String_Char
(S
, Pos
(J
));
23366 -- This is a weird test, it skips setting validity
23367 -- checks entirely if any element of S is out of
23368 -- range of Character, what is that about ???
23370 exit when not In_Character_Range
(C
);
23371 Options
(J
) := Get_Character
(C
);
23374 Set_Validity_Check_Options
(Options
);
23382 elsif Nkind
(A
) = N_Identifier
then
23383 if Chars
(A
) = Name_All_Checks
then
23384 Set_Validity_Check_Options
("a");
23385 elsif Chars
(A
) = Name_On
then
23386 Validity_Checks_On
:= True;
23387 elsif Chars
(A
) = Name_Off
then
23388 Validity_Checks_On
:= False;
23392 end Validity_Checks
;
23398 -- pragma Volatile (LOCAL_NAME);
23400 when Pragma_Volatile
=>
23401 Process_Atomic_Independent_Shared_Volatile
;
23403 -------------------------
23404 -- Volatile_Components --
23405 -------------------------
23407 -- pragma Volatile_Components (array_LOCAL_NAME);
23409 -- Volatile is handled by the same circuit as Atomic_Components
23411 --------------------------
23412 -- Volatile_Full_Access --
23413 --------------------------
23415 -- pragma Volatile_Full_Access (LOCAL_NAME);
23417 when Pragma_Volatile_Full_Access
=>
23419 Process_Atomic_Independent_Shared_Volatile
;
23421 -----------------------
23422 -- Volatile_Function --
23423 -----------------------
23425 -- pragma Volatile_Function [ (boolean_EXPRESSION) ];
23427 when Pragma_Volatile_Function
=> Volatile_Function
: declare
23428 Over_Id
: Entity_Id
;
23429 Spec_Id
: Entity_Id
;
23430 Subp_Decl
: Node_Id
;
23434 Check_No_Identifiers
;
23435 Check_At_Most_N_Arguments
(1);
23438 Find_Related_Declaration_Or_Body
(N
, Do_Checks
=> True);
23440 -- Generic subprogram
23442 if Nkind
(Subp_Decl
) = N_Generic_Subprogram_Declaration
then
23445 -- Body acts as spec
23447 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body
23448 and then No
(Corresponding_Spec
(Subp_Decl
))
23452 -- Body stub acts as spec
23454 elsif Nkind
(Subp_Decl
) = N_Subprogram_Body_Stub
23455 and then No
(Corresponding_Spec_Of_Stub
(Subp_Decl
))
23461 elsif Nkind
(Subp_Decl
) = N_Subprogram_Declaration
then
23469 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
23471 if not Ekind_In
(Spec_Id
, E_Function
, E_Generic_Function
) then
23476 -- A pragma that applies to a Ghost entity becomes Ghost for the
23477 -- purposes of legality checks and removal of ignored Ghost code.
23479 Mark_Ghost_Pragma
(N
, Spec_Id
);
23481 -- Chain the pragma on the contract for completeness
23483 Add_Contract_Item
(N
, Spec_Id
);
23485 -- The legality checks of pragma Volatile_Function are affected by
23486 -- the SPARK mode in effect. Analyze all pragmas in a specific
23489 Analyze_If_Present
(Pragma_SPARK_Mode
);
23491 -- A volatile function cannot override a non-volatile function
23492 -- (SPARK RM 7.1.2(15)). Overriding checks are usually performed
23493 -- in New_Overloaded_Entity, however at that point the pragma has
23494 -- not been processed yet.
23496 Over_Id
:= Overridden_Operation
(Spec_Id
);
23498 if Present
(Over_Id
)
23499 and then not Is_Volatile_Function
(Over_Id
)
23502 ("incompatible volatile function values in effect", Spec_Id
);
23504 Error_Msg_Sloc
:= Sloc
(Over_Id
);
23506 ("\& declared # with Volatile_Function value False",
23509 Error_Msg_Sloc
:= Sloc
(Spec_Id
);
23511 ("\overridden # with Volatile_Function value True",
23515 -- Analyze the Boolean expression (if any)
23517 if Present
(Arg1
) then
23518 Check_Static_Boolean_Expression
(Get_Pragma_Arg
(Arg1
));
23520 end Volatile_Function
;
23522 ----------------------
23523 -- Warning_As_Error --
23524 ----------------------
23526 -- pragma Warning_As_Error (static_string_EXPRESSION);
23528 when Pragma_Warning_As_Error
=>
23530 Check_Arg_Count
(1);
23531 Check_No_Identifiers
;
23532 Check_Valid_Configuration_Pragma
;
23534 if not Is_Static_String_Expression
(Arg1
) then
23536 ("argument of pragma% must be static string expression",
23539 -- OK static string expression
23542 Acquire_Warning_Match_String
(Arg1
);
23543 Warnings_As_Errors_Count
:= Warnings_As_Errors_Count
+ 1;
23544 Warnings_As_Errors
(Warnings_As_Errors_Count
) :=
23545 new String'(Name_Buffer (1 .. Name_Len));
23552 -- pragma Warnings ([TOOL_NAME,] DETAILS [, REASON]);
23554 -- DETAILS ::= On | Off
23555 -- DETAILS ::= On | Off, local_NAME
23556 -- DETAILS ::= static_string_EXPRESSION
23557 -- DETAILS ::= On | Off, static_string_EXPRESSION
23559 -- TOOL_NAME ::= GNAT | GNATProve
23561 -- REASON ::= Reason => STRING_LITERAL {& STRING_LITERAL}
23563 -- Note: If the first argument matches an allowed tool name, it is
23564 -- always considered to be a tool name, even if there is a string
23565 -- variable of that name.
23567 -- Note if the second argument of DETAILS is a local_NAME then the
23568 -- second form is always understood. If the intention is to use
23569 -- the fourth form, then you can write NAME & "" to force the
23570 -- intepretation as a static_string_EXPRESSION.
23572 when Pragma_Warnings => Warnings : declare
23573 Reason : String_Id;
23577 Check_At_Least_N_Arguments (1);
23579 -- See if last argument is labeled Reason. If so, make sure we
23580 -- have a string literal or a concatenation of string literals,
23581 -- and acquire the REASON string. Then remove the REASON argument
23582 -- by decreasing Num_Args by one; Remaining processing looks only
23583 -- at first Num_Args arguments).
23586 Last_Arg : constant Node_Id :=
23587 Last (Pragma_Argument_Associations (N));
23590 if Nkind (Last_Arg) = N_Pragma_Argument_Association
23591 and then Chars (Last_Arg) = Name_Reason
23594 Get_Reason_String (Get_Pragma_Arg (Last_Arg));
23595 Reason := End_String;
23596 Arg_Count := Arg_Count - 1;
23598 -- Not allowed in compiler units (bootstrap issues)
23600 Check_Compiler_Unit ("Reason for pragma Warnings", N);
23602 -- No REASON string, set null string as reason
23605 Reason := Null_String_Id;
23609 -- Now proceed with REASON taken care of and eliminated
23611 Check_No_Identifiers;
23613 -- If debug flag -gnatd.i is set, pragma is ignored
23615 if Debug_Flag_Dot_I then
23619 -- Process various forms of the pragma
23622 Argx : constant Node_Id := Get_Pragma_Arg (Arg1);
23623 Shifted_Args : List_Id;
23626 -- See if first argument is a tool name, currently either
23627 -- GNAT or GNATprove. If so, either ignore the pragma if the
23628 -- tool used does not match, or continue as if no tool name
23629 -- was given otherwise, by shifting the arguments.
23631 if Nkind (Argx) = N_Identifier
23632 and then Nam_In (Chars (Argx), Name_Gnat, Name_Gnatprove)
23634 if Chars (Argx) = Name_Gnat then
23635 if CodePeer_Mode or GNATprove_Mode or ASIS_Mode then
23636 Rewrite (N, Make_Null_Statement (Loc));
23641 elsif Chars (Argx) = Name_Gnatprove then
23642 if not GNATprove_Mode then
23643 Rewrite (N, Make_Null_Statement (Loc));
23649 raise Program_Error;
23652 -- At this point, the pragma Warnings applies to the tool,
23653 -- so continue with shifted arguments.
23655 Arg_Count := Arg_Count - 1;
23657 if Arg_Count = 1 then
23658 Shifted_Args := New_List (New_Copy (Arg2));
23659 elsif Arg_Count = 2 then
23660 Shifted_Args := New_List (New_Copy (Arg2),
23662 elsif Arg_Count = 3 then
23663 Shifted_Args := New_List (New_Copy (Arg2),
23667 raise Program_Error;
23672 Chars => Name_Warnings,
23673 Pragma_Argument_Associations => Shifted_Args));
23678 -- One argument case
23680 if Arg_Count = 1 then
23682 -- On/Off one argument case was processed by parser
23684 if Nkind (Argx) = N_Identifier
23685 and then Nam_In (Chars (Argx), Name_On, Name_Off)
23689 -- One argument case must be ON/OFF or static string expr
23691 elsif not Is_Static_String_Expression (Arg1) then
23693 ("argument of pragma% must be On/Off or static string "
23694 & "expression", Arg1);
23696 -- One argument string expression case
23700 Lit : constant Node_Id := Expr_Value_S (Argx);
23701 Str : constant String_Id := Strval (Lit);
23702 Len : constant Nat := String_Length (Str);
23710 while J <= Len loop
23711 C := Get_String_Char (Str, J);
23712 OK := In_Character_Range (C);
23715 Chr := Get_Character (C);
23717 -- Dash case: only -Wxxx is accepted
23724 C := Get_String_Char (Str, J);
23725 Chr := Get_Character (C);
23726 exit when Chr = 'W
';
23731 elsif J < Len and then Chr = '.' then
23733 C := Get_String_Char (Str, J);
23734 Chr := Get_Character (C);
23736 if not Set_Dot_Warning_Switch (Chr) then
23738 ("invalid warning switch character "
23739 & '.' & Chr, Arg1);
23745 OK := Set_Warning_Switch (Chr);
23751 ("invalid warning switch character " & Chr,
23760 -- Two or more arguments (must be two)
23763 Check_Arg_Is_One_Of (Arg1, Name_On, Name_Off);
23764 Check_Arg_Count (2);
23772 E_Id := Get_Pragma_Arg (Arg2);
23775 -- In the expansion of an inlined body, a reference to
23776 -- the formal may be wrapped in a conversion if the
23777 -- actual is a conversion. Retrieve the real entity name.
23779 if (In_Instance_Body or In_Inlined_Body)
23780 and then Nkind (E_Id) = N_Unchecked_Type_Conversion
23782 E_Id := Expression (E_Id);
23785 -- Entity name case
23787 if Is_Entity_Name (E_Id) then
23788 E := Entity (E_Id);
23795 (E, (Chars (Get_Pragma_Arg (Arg1)) =
23798 -- For OFF case, make entry in warnings off
23799 -- pragma table for later processing. But we do
23800 -- not do that within an instance, since these
23801 -- warnings are about what is needed in the
23802 -- template, not an instance of it.
23804 if Chars (Get_Pragma_Arg (Arg1)) = Name_Off
23805 and then Warn_On_Warnings_Off
23806 and then not In_Instance
23808 Warnings_Off_Pragmas.Append ((N, E, Reason));
23811 if Is_Enumeration_Type (E) then
23815 Lit := First_Literal (E);
23816 while Present (Lit) loop
23817 Set_Warnings_Off (Lit);
23818 Next_Literal (Lit);
23823 exit when No (Homonym (E));
23828 -- Error if not entity or static string expression case
23830 elsif not Is_Static_String_Expression (Arg2) then
23832 ("second argument of pragma% must be entity name "
23833 & "or static string expression", Arg2);
23835 -- Static string expression case
23838 Acquire_Warning_Match_String (Arg2);
23840 -- Note on configuration pragma case: If this is a
23841 -- configuration pragma, then for an OFF pragma, we
23842 -- just set Config True in the call, which is all
23843 -- that needs to be done. For the case of ON, this
23844 -- is normally an error, unless it is canceling the
23845 -- effect of a previous OFF pragma in the same file.
23846 -- In any other case, an error will be signalled (ON
23847 -- with no matching OFF).
23849 -- Note: We set Used if we are inside a generic to
23850 -- disable the test that the non-config case actually
23851 -- cancels a warning. That's because we can't be sure
23852 -- there isn't an instantiation in some other unit
23853 -- where a warning is suppressed.
23855 -- We could do a little better here by checking if the
23856 -- generic unit we are inside is public, but for now
23857 -- we don't bother with that refinement.
23859 if Chars (Argx) = Name_Off then
23860 Set_Specific_Warning_Off
23861 (Loc, Name_Buffer (1 .. Name_Len), Reason,
23862 Config => Is_Configuration_Pragma,
23863 Used => Inside_A_Generic or else In_Instance);
23865 elsif Chars (Argx) = Name_On then
23866 Set_Specific_Warning_On
23867 (Loc, Name_Buffer (1 .. Name_Len), Err);
23871 ("??pragma Warnings On with no matching "
23872 & "Warnings Off", Loc);
23881 -------------------
23882 -- Weak_External --
23883 -------------------
23885 -- pragma Weak_External ([Entity =>] LOCAL_NAME);
23887 when Pragma_Weak_External => Weak_External : declare
23892 Check_Arg_Count (1);
23893 Check_Optional_Identifier (Arg1, Name_Entity);
23894 Check_Arg_Is_Library_Level_Local_Name (Arg1);
23895 Ent := Entity (Get_Pragma_Arg (Arg1));
23897 if Rep_Item_Too_Early (Ent, N) then
23900 Ent := Underlying_Type (Ent);
23903 -- The only processing required is to link this item on to the
23904 -- list of rep items for the given entity. This is accomplished
23905 -- by the call to Rep_Item_Too_Late (when no error is detected
23906 -- and False is returned).
23908 if Rep_Item_Too_Late (Ent, N) then
23911 Set_Has_Gigi_Rep_Item (Ent);
23915 -----------------------------
23916 -- Wide_Character_Encoding --
23917 -----------------------------
23919 -- pragma Wide_Character_Encoding (IDENTIFIER);
23921 when Pragma_Wide_Character_Encoding =>
23924 -- Nothing to do, handled in parser. Note that we do not enforce
23925 -- configuration pragma placement, this pragma can appear at any
23926 -- place in the source, allowing mixed encodings within a single
23931 --------------------
23932 -- Unknown_Pragma --
23933 --------------------
23935 -- Should be impossible, since the case of an unknown pragma is
23936 -- separately processed before the case statement is entered.
23938 when Unknown_Pragma =>
23939 raise Program_Error;
23942 -- AI05-0144: detect dangerous order dependence. Disabled for now,
23943 -- until AI is formally approved.
23945 -- Check_Order_Dependence;
23948 when Pragma_Exit => null;
23949 end Analyze_Pragma;
23951 ---------------------------------------------
23952 -- Analyze_Pre_Post_Condition_In_Decl_Part --
23953 ---------------------------------------------
23955 -- WARNING: This routine manages Ghost regions. Return statements must be
23956 -- replaced by gotos which jump to the end of the routine and restore the
23959 procedure Analyze_Pre_Post_Condition_In_Decl_Part
23961 Freeze_Id : Entity_Id := Empty)
23963 Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N);
23964 Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl);
23966 Disp_Typ : Entity_Id;
23967 -- The dispatching type of the subprogram subject to the pre- or
23970 function Check_References (Nod : Node_Id) return Traverse_Result;
23971 -- Check that expression Nod does not mention non-primitives of the
23972 -- type, global objects of the type, or other illegalities described
23973 -- and implied by AI12-0113.
23975 ----------------------
23976 -- Check_References --
23977 ----------------------
23979 function Check_References (Nod : Node_Id) return Traverse_Result is
23981 if Nkind (Nod) = N_Function_Call
23982 and then Is_Entity_Name (Name (Nod))
23985 Func : constant Entity_Id := Entity (Name (Nod));
23989 -- An operation of the type must be a primitive
23991 if No (Find_Dispatching_Type (Func)) then
23992 Form := First_Formal (Func);
23993 while Present (Form) loop
23994 if Etype (Form) = Disp_Typ then
23996 ("operation in class-wide condition must be "
23997 & "primitive of &", Nod, Disp_Typ);
24000 Next_Formal (Form);
24003 -- A return object of the type is illegal as well
24005 if Etype (Func) = Disp_Typ
24006 or else Etype (Func) = Class_Wide_Type (Disp_Typ)
24009 ("operation in class-wide condition must be primitive "
24010 & "of &", Nod, Disp_Typ);
24013 -- Otherwise we have a call to an overridden primitive, and we
24014 -- will create a common class-wide clone for the body of
24015 -- original operation and its eventual inherited versions. If
24016 -- the original operation dispatches on result it is never
24017 -- inherited and there is no need for a clone. There is not
24018 -- need for a clone either in GNATprove mode, as cases that
24019 -- would require it are rejected (when an inherited primitive
24020 -- calls an overridden operation in a class-wide contract), and
24021 -- the clone would make proof impossible in some cases.
24023 elsif not Is_Abstract_Subprogram (Spec_Id)
24024 and then No (Class_Wide_Clone (Spec_Id))
24025 and then not Has_Controlling_Result (Spec_Id)
24026 and then not GNATprove_Mode
24028 Build_Class_Wide_Clone_Decl (Spec_Id);
24032 elsif Is_Entity_Name (Nod)
24034 (Etype (Nod) = Disp_Typ
24035 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24036 and then Ekind_In (Entity (Nod), E_Constant, E_Variable)
24039 ("object in class-wide condition must be formal of type &",
24042 elsif Nkind (Nod) = N_Explicit_Dereference
24043 and then (Etype (Nod) = Disp_Typ
24044 or else Etype (Nod) = Class_Wide_Type (Disp_Typ))
24045 and then (not Is_Entity_Name (Prefix (Nod))
24046 or else not Is_Formal (Entity (Prefix (Nod))))
24049 ("operation in class-wide condition must be primitive of &",
24054 end Check_References;
24056 procedure Check_Class_Wide_Condition is
24057 new Traverse_Proc (Check_References);
24061 Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id));
24062 Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
24063 -- Save the Ghost mode to restore on exit
24066 Restore_Scope : Boolean := False;
24068 -- Start of processing for Analyze_Pre_Post_Condition_In_Decl_Part
24071 -- Do not analyze the pragma multiple times
24073 if Is_Analyzed_Pragma (N) then
24077 -- Set the Ghost mode in effect from the pragma. Due to the delayed
24078 -- analysis of the pragma, the Ghost mode at point of declaration and
24079 -- point of analysis may not necessarily be the same. Use the mode in
24080 -- effect at the point of declaration.
24082 Set_Ghost_Mode (N);
24084 -- Ensure that the subprogram and its formals are visible when analyzing
24085 -- the expression of the pragma.
24087 if not In_Open_Scopes (Spec_Id) then
24088 Restore_Scope := True;
24089 Push_Scope (Spec_Id);
24091 if Is_Generic_Subprogram (Spec_Id) then
24092 Install_Generic_Formals (Spec_Id);
24094 Install_Formals (Spec_Id);
24098 Errors := Serious_Errors_Detected;
24099 Preanalyze_Assert_Expression (Expr, Standard_Boolean);
24101 -- Emit a clarification message when the expression contains at least
24102 -- one undefined reference, possibly due to contract "freezing".
24104 if Errors /= Serious_Errors_Detected
24105 and then Present (Freeze_Id)
24106 and then Has_Undefined_Reference (Expr)
24108 Contract_Freeze_Error (Spec_Id, Freeze_Id);
24111 if Class_Present (N) then
24113 -- Verify that a class-wide condition is legal, i.e. the operation is
24114 -- a primitive of a tagged type. Note that a generic subprogram is
24115 -- not a primitive operation.
24117 Disp_Typ := Find_Dispatching_Type (Spec_Id);
24119 if No (Disp_Typ) or else Is_Generic_Subprogram (Spec_Id) then
24120 Error_Msg_Name_1 := Original_Aspect_Pragma_Name (N);
24122 if From_Aspect_Specification (N) then
24124 ("aspect % can only be specified for a primitive operation "
24125 & "of a tagged type", Corresponding_Aspect (N));
24127 -- The pragma is a source construct
24131 ("pragma % can only be specified for a primitive operation "
24132 & "of a tagged type", N);
24135 -- Remaining semantic checks require a full tree traversal
24138 Check_Class_Wide_Condition (Expr);
24143 if Restore_Scope then
24147 -- If analysis of the condition indicates that a class-wide clone
24148 -- has been created, build and analyze its declaration.
24150 if Is_Subprogram (Spec_Id)
24151 and then Present (Class_Wide_Clone (Spec_Id))
24153 Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id)));
24156 -- Currently it is not possible to inline pre/postconditions on a
24157 -- subprogram subject to pragma Inline_Always.
24159 Check_Postcondition_Use_In_Inlined_Subprogram (N, Spec_Id);
24160 Set_Is_Analyzed_Pragma (N);
24162 Restore_Ghost_Mode (Saved_GM);
24163 end Analyze_Pre_Post_Condition_In_Decl_Part;
24165 ------------------------------------------
24166 -- Analyze_Refined_Depends_In_Decl_Part --
24167 ------------------------------------------
24169 procedure Analyze_Refined_Depends_In_Decl_Part (N : Node_Id) is
24170 procedure Check_Dependency_Clause
24171 (Spec_Id : Entity_Id;
24172 Dep_Clause : Node_Id;
24173 Dep_States : Elist_Id;
24174 Refinements : List_Id;
24175 Matched_Items : in out Elist_Id);
24176 -- Try to match a single dependency clause Dep_Clause against one or
24177 -- more refinement clauses found in list Refinements. Each successful
24178 -- match eliminates at least one refinement clause from Refinements.
24179 -- Spec_Id denotes the entity of the related subprogram. Dep_States
24180 -- denotes the entities of all abstract states which appear in pragma
24181 -- Depends. Matched_Items contains the entities of all successfully
24182 -- matched items found in pragma Depends.
24184 procedure Check_Output_States
24185 (Spec_Id : Entity_Id;
24186 Spec_Inputs : Elist_Id;
24187 Spec_Outputs : Elist_Id;
24188 Body_Inputs : Elist_Id;
24189 Body_Outputs : Elist_Id);
24190 -- Determine whether pragma Depends contains an output state with a
24191 -- visible refinement and if so, ensure that pragma Refined_Depends
24192 -- mentions all its constituents as outputs. Spec_Id is the entity of
24193 -- the related subprograms. Spec_Inputs and Spec_Outputs denote the
24194 -- inputs and outputs of the subprogram spec synthesized from pragma
24195 -- Depends. Body_Inputs and Body_Outputs denote the inputs and outputs
24196 -- of the subprogram body synthesized from pragma Refined_Depends.
24198 function Collect_States (Clauses : List_Id) return Elist_Id;
24199 -- Given a normalized list of dependencies obtained from calling
24200 -- Normalize_Clauses, return a list containing the entities of all
24201 -- states appearing in dependencies. It helps in checking refinements
24202 -- involving a state and a corresponding constituent which is not a
24203 -- direct constituent of the state.
24205 procedure Normalize_Clauses (Clauses : List_Id);
24206 -- Given a list of dependence or refinement clauses Clauses, normalize
24207 -- each clause by creating multiple dependencies with exactly one input
24210 procedure Remove_Extra_Clauses
24211 (Clauses : List_Id;
24212 Matched_Items : Elist_Id);
24213 -- Given a list of refinement clauses Clauses, remove all clauses whose
24214 -- inputs and/or outputs have been previously matched. See the body for
24215 -- all special cases. Matched_Items contains the entities of all matched
24216 -- items found in pragma Depends.
24218 procedure Report_Extra_Clauses
24219 (Spec_Id : Entity_Id;
24220 Clauses : List_Id);
24221 -- Emit an error for each extra clause found in list Clauses. Spec_Id
24222 -- denotes the entity of the related subprogram.
24224 -----------------------------
24225 -- Check_Dependency_Clause --
24226 -----------------------------
24228 procedure Check_Dependency_Clause
24229 (Spec_Id : Entity_Id;
24230 Dep_Clause : Node_Id;
24231 Dep_States : Elist_Id;
24232 Refinements : List_Id;
24233 Matched_Items : in out Elist_Id)
24235 Dep_Input : constant Node_Id := Expression (Dep_Clause);
24236 Dep_Output : constant Node_Id := First (Choices (Dep_Clause));
24238 function Is_Already_Matched (Dep_Item : Node_Id) return Boolean;
24239 -- Determine whether dependency item Dep_Item has been matched in a
24240 -- previous clause.
24242 function Is_In_Out_State_Clause return Boolean;
24243 -- Determine whether dependence clause Dep_Clause denotes an abstract
24244 -- state that depends on itself (State => State).
24246 function Is_Null_Refined_State (Item : Node_Id) return Boolean;
24247 -- Determine whether item Item denotes an abstract state with visible
24248 -- null refinement.
24250 procedure Match_Items
24251 (Dep_Item : Node_Id;
24252 Ref_Item : Node_Id;
24253 Matched : out Boolean);
24254 -- Try to match dependence item Dep_Item against refinement item
24255 -- Ref_Item. To match against a possible null refinement (see 2, 9),
24256 -- set Ref_Item to Empty. Flag Matched is set to True when one of
24257 -- the following conformance scenarios is in effect:
24258 -- 1) Both items denote null
24259 -- 2) Dep_Item denotes null and Ref_Item is Empty (special case)
24260 -- 3) Both items denote attribute 'Result
24261 -- 4) Both items denote the same object
24262 -- 5) Both items denote the same formal parameter
24263 -- 6) Both items denote the same current instance of a type
24264 -- 7) Both items denote the same discriminant
24265 -- 8) Dep_Item is an abstract state with visible null refinement
24266 -- and Ref_Item denotes null.
24267 -- 9) Dep_Item is an abstract state with visible null refinement
24268 -- and Ref_Item is Empty (special case).
24269 -- 10) Dep_Item is an abstract state with full or partial visible
24270 -- non-null refinement and Ref_Item denotes one of its
24272 -- 11) Dep_Item is an abstract state without a full visible
24273 -- refinement and Ref_Item denotes the same state.
24274 -- When scenario 10 is in effect, the entity of the abstract state
24275 -- denoted by Dep_Item is added to list Refined_States.
24277 procedure Record_Item
(Item_Id
: Entity_Id
);
24278 -- Store the entity of an item denoted by Item_Id in Matched_Items
24280 ------------------------
24281 -- Is_Already_Matched --
24282 ------------------------
24284 function Is_Already_Matched
(Dep_Item
: Node_Id
) return Boolean is
24285 Item_Id
: Entity_Id
:= Empty
;
24288 -- When the dependency item denotes attribute 'Result, check for
24289 -- the entity of the related subprogram.
24291 if Is_Attribute_Result
(Dep_Item
) then
24292 Item_Id
:= Spec_Id
;
24294 elsif Is_Entity_Name
(Dep_Item
) then
24295 Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24299 Present
(Item_Id
) and then Contains
(Matched_Items
, Item_Id
);
24300 end Is_Already_Matched
;
24302 ----------------------------
24303 -- Is_In_Out_State_Clause --
24304 ----------------------------
24306 function Is_In_Out_State_Clause
return Boolean is
24307 Dep_Input_Id
: Entity_Id
;
24308 Dep_Output_Id
: Entity_Id
;
24311 -- Detect the following clause:
24314 if Is_Entity_Name
(Dep_Input
)
24315 and then Is_Entity_Name
(Dep_Output
)
24317 -- Handle abstract views generated for limited with clauses
24319 Dep_Input_Id
:= Available_View
(Entity_Of
(Dep_Input
));
24320 Dep_Output_Id
:= Available_View
(Entity_Of
(Dep_Output
));
24323 Ekind
(Dep_Input_Id
) = E_Abstract_State
24324 and then Dep_Input_Id
= Dep_Output_Id
;
24328 end Is_In_Out_State_Clause
;
24330 ---------------------------
24331 -- Is_Null_Refined_State --
24332 ---------------------------
24334 function Is_Null_Refined_State
(Item
: Node_Id
) return Boolean is
24335 Item_Id
: Entity_Id
;
24338 if Is_Entity_Name
(Item
) then
24340 -- Handle abstract views generated for limited with clauses
24342 Item_Id
:= Available_View
(Entity_Of
(Item
));
24345 Ekind
(Item_Id
) = E_Abstract_State
24346 and then Has_Null_Visible_Refinement
(Item_Id
);
24350 end Is_Null_Refined_State
;
24356 procedure Match_Items
24357 (Dep_Item
: Node_Id
;
24358 Ref_Item
: Node_Id
;
24359 Matched
: out Boolean)
24361 Dep_Item_Id
: Entity_Id
;
24362 Ref_Item_Id
: Entity_Id
;
24365 -- Assume that the two items do not match
24369 -- A null matches null or Empty (special case)
24371 if Nkind
(Dep_Item
) = N_Null
24372 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24376 -- Attribute 'Result matches attribute 'Result
24378 elsif Is_Attribute_Result
(Dep_Item
)
24379 and then Is_Attribute_Result
(Ref_Item
)
24381 -- Put the entity of the related function on the list of
24382 -- matched items because attribute 'Result does not carry
24383 -- an entity similar to states and constituents.
24385 Record_Item
(Spec_Id
);
24388 -- Abstract states, current instances of concurrent types,
24389 -- discriminants, formal parameters and objects.
24391 elsif Is_Entity_Name
(Dep_Item
) then
24393 -- Handle abstract views generated for limited with clauses
24395 Dep_Item_Id
:= Available_View
(Entity_Of
(Dep_Item
));
24397 if Ekind
(Dep_Item_Id
) = E_Abstract_State
then
24399 -- An abstract state with visible null refinement matches
24400 -- null or Empty (special case).
24402 if Has_Null_Visible_Refinement
(Dep_Item_Id
)
24403 and then (No
(Ref_Item
) or else Nkind
(Ref_Item
) = N_Null
)
24405 Record_Item
(Dep_Item_Id
);
24408 -- An abstract state with visible non-null refinement
24409 -- matches one of its constituents, or itself for an
24410 -- abstract state with partial visible refinement.
24412 elsif Has_Non_Null_Visible_Refinement
(Dep_Item_Id
) then
24413 if Is_Entity_Name
(Ref_Item
) then
24414 Ref_Item_Id
:= Entity_Of
(Ref_Item
);
24416 if Ekind_In
(Ref_Item_Id
, E_Abstract_State
,
24419 and then Present
(Encapsulating_State
(Ref_Item_Id
))
24420 and then Find_Encapsulating_State
24421 (Dep_States
, Ref_Item_Id
) = Dep_Item_Id
24423 Record_Item
(Dep_Item_Id
);
24426 elsif not Has_Visible_Refinement
(Dep_Item_Id
)
24427 and then Ref_Item_Id
= Dep_Item_Id
24429 Record_Item
(Dep_Item_Id
);
24434 -- An abstract state without a visible refinement matches
24437 elsif Is_Entity_Name
(Ref_Item
)
24438 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24440 Record_Item
(Dep_Item_Id
);
24444 -- A current instance of a concurrent type, discriminant,
24445 -- formal parameter or an object matches itself.
24447 elsif Is_Entity_Name
(Ref_Item
)
24448 and then Entity_Of
(Ref_Item
) = Dep_Item_Id
24450 Record_Item
(Dep_Item_Id
);
24460 procedure Record_Item
(Item_Id
: Entity_Id
) is
24462 if No
(Matched_Items
) then
24463 Matched_Items
:= New_Elmt_List
;
24466 Append_Unique_Elmt
(Item_Id
, Matched_Items
);
24471 Clause_Matched
: Boolean := False;
24472 Dummy
: Boolean := False;
24473 Inputs_Match
: Boolean;
24474 Next_Ref_Clause
: Node_Id
;
24475 Outputs_Match
: Boolean;
24476 Ref_Clause
: Node_Id
;
24477 Ref_Input
: Node_Id
;
24478 Ref_Output
: Node_Id
;
24480 -- Start of processing for Check_Dependency_Clause
24483 -- Do not perform this check in an instance because it was already
24484 -- performed successfully in the generic template.
24486 if Is_Generic_Instance
(Spec_Id
) then
24490 -- Examine all refinement clauses and compare them against the
24491 -- dependence clause.
24493 Ref_Clause
:= First
(Refinements
);
24494 while Present
(Ref_Clause
) loop
24495 Next_Ref_Clause
:= Next
(Ref_Clause
);
24497 -- Obtain the attributes of the current refinement clause
24499 Ref_Input
:= Expression
(Ref_Clause
);
24500 Ref_Output
:= First
(Choices
(Ref_Clause
));
24502 -- The current refinement clause matches the dependence clause
24503 -- when both outputs match and both inputs match. See routine
24504 -- Match_Items for all possible conformance scenarios.
24506 -- Depends Dep_Output => Dep_Input
24510 -- Refined_Depends Ref_Output => Ref_Input
24513 (Dep_Item
=> Dep_Input
,
24514 Ref_Item
=> Ref_Input
,
24515 Matched
=> Inputs_Match
);
24518 (Dep_Item
=> Dep_Output
,
24519 Ref_Item
=> Ref_Output
,
24520 Matched
=> Outputs_Match
);
24522 -- An In_Out state clause may be matched against a refinement with
24523 -- a null input or null output as long as the non-null side of the
24524 -- relation contains a valid constituent of the In_Out_State.
24526 if Is_In_Out_State_Clause
then
24528 -- Depends => (State => State)
24529 -- Refined_Depends => (null => Constit) -- OK
24532 and then not Outputs_Match
24533 and then Nkind
(Ref_Output
) = N_Null
24535 Outputs_Match
:= True;
24538 -- Depends => (State => State)
24539 -- Refined_Depends => (Constit => null) -- OK
24541 if not Inputs_Match
24542 and then Outputs_Match
24543 and then Nkind
(Ref_Input
) = N_Null
24545 Inputs_Match
:= True;
24549 -- The current refinement clause is legally constructed following
24550 -- the rules in SPARK RM 7.2.5, therefore it can be removed from
24551 -- the pool of candidates. The seach continues because a single
24552 -- dependence clause may have multiple matching refinements.
24554 if Inputs_Match
and Outputs_Match
then
24555 Clause_Matched
:= True;
24556 Remove
(Ref_Clause
);
24559 Ref_Clause
:= Next_Ref_Clause
;
24562 -- Depending on the order or composition of refinement clauses, an
24563 -- In_Out state clause may not be directly refinable.
24565 -- Refined_State => (State => (Constit_1, Constit_2))
24566 -- Depends => ((Output, State) => (Input, State))
24567 -- Refined_Depends => (Constit_1 => Input, Output => Constit_2)
24569 -- Matching normalized clause (State => State) fails because there is
24570 -- no direct refinement capable of satisfying this relation. Another
24571 -- similar case arises when clauses (Constit_1 => Input) and (Output
24572 -- => Constit_2) are matched first, leaving no candidates for clause
24573 -- (State => State). Both scenarios are legal as long as one of the
24574 -- previous clauses mentioned a valid constituent of State.
24576 if not Clause_Matched
24577 and then Is_In_Out_State_Clause
24578 and then Is_Already_Matched
(Dep_Input
)
24580 Clause_Matched
:= True;
24583 -- A clause where the input is an abstract state with visible null
24584 -- refinement or a 'Result attribute is implicitly matched when the
24585 -- output has already been matched in a previous clause.
24587 -- Refined_State => (State => null)
24588 -- Depends => (Output => State) -- implicitly OK
24589 -- Refined_Depends => (Output => ...)
24590 -- Depends => (...'Result => State) -- implicitly OK
24591 -- Refined_Depends => (...'Result => ...)
24593 if not Clause_Matched
24594 and then Is_Null_Refined_State
(Dep_Input
)
24595 and then Is_Already_Matched
(Dep_Output
)
24597 Clause_Matched
:= True;
24600 -- A clause where the output is an abstract state with visible null
24601 -- refinement is implicitly matched when the input has already been
24602 -- matched in a previous clause.
24604 -- Refined_State => (State => null)
24605 -- Depends => (State => Input) -- implicitly OK
24606 -- Refined_Depends => (... => Input)
24608 if not Clause_Matched
24609 and then Is_Null_Refined_State
(Dep_Output
)
24610 and then Is_Already_Matched
(Dep_Input
)
24612 Clause_Matched
:= True;
24615 -- At this point either all refinement clauses have been examined or
24616 -- pragma Refined_Depends contains a solitary null. Only an abstract
24617 -- state with null refinement can possibly match these cases.
24619 -- Refined_State => (State => null)
24620 -- Depends => (State => null)
24621 -- Refined_Depends => null -- OK
24623 if not Clause_Matched
then
24625 (Dep_Item
=> Dep_Input
,
24627 Matched
=> Inputs_Match
);
24630 (Dep_Item
=> Dep_Output
,
24632 Matched
=> Outputs_Match
);
24634 Clause_Matched
:= Inputs_Match
and Outputs_Match
;
24637 -- If the contents of Refined_Depends are legal, then the current
24638 -- dependence clause should be satisfied either by an explicit match
24639 -- or by one of the special cases.
24641 if not Clause_Matched
then
24643 (Fix_Msg
(Spec_Id
, "dependence clause of subprogram & has no "
24644 & "matching refinement in body"), Dep_Clause
, Spec_Id
);
24646 end Check_Dependency_Clause
;
24648 -------------------------
24649 -- Check_Output_States --
24650 -------------------------
24652 procedure Check_Output_States
24653 (Spec_Id
: Entity_Id
;
24654 Spec_Inputs
: Elist_Id
;
24655 Spec_Outputs
: Elist_Id
;
24656 Body_Inputs
: Elist_Id
;
24657 Body_Outputs
: Elist_Id
)
24659 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
24660 -- Determine whether all constituents of state State_Id with full
24661 -- visible refinement are used as outputs in pragma Refined_Depends.
24662 -- Emit an error if this is not the case (SPARK RM 7.2.4(5)).
24664 -----------------------------
24665 -- Check_Constituent_Usage --
24666 -----------------------------
24668 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
24669 Constits
: constant Elist_Id
:=
24670 Partial_Refinement_Constituents
(State_Id
);
24671 Constit_Elmt
: Elmt_Id
;
24672 Constit_Id
: Entity_Id
;
24673 Only_Partial
: constant Boolean :=
24674 not Has_Visible_Refinement
(State_Id
);
24675 Posted
: Boolean := False;
24678 if Present
(Constits
) then
24679 Constit_Elmt
:= First_Elmt
(Constits
);
24680 while Present
(Constit_Elmt
) loop
24681 Constit_Id
:= Node
(Constit_Elmt
);
24683 -- Issue an error when a constituent of State_Id is used,
24684 -- and State_Id has only partial visible refinement
24685 -- (SPARK RM 7.2.4(3d)).
24687 if Only_Partial
then
24688 if (Present
(Body_Inputs
)
24689 and then Appears_In
(Body_Inputs
, Constit_Id
))
24691 (Present
(Body_Outputs
)
24692 and then Appears_In
(Body_Outputs
, Constit_Id
))
24694 Error_Msg_Name_1
:= Chars
(State_Id
);
24696 ("constituent & of state % cannot be used in "
24697 & "dependence refinement", N
, Constit_Id
);
24698 Error_Msg_Name_1
:= Chars
(State_Id
);
24699 SPARK_Msg_N
("\use state % instead", N
);
24702 -- The constituent acts as an input (SPARK RM 7.2.5(3))
24704 elsif Present
(Body_Inputs
)
24705 and then Appears_In
(Body_Inputs
, Constit_Id
)
24707 Error_Msg_Name_1
:= Chars
(State_Id
);
24709 ("constituent & of state % must act as output in "
24710 & "dependence refinement", N
, Constit_Id
);
24712 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
24714 elsif No
(Body_Outputs
)
24715 or else not Appears_In
(Body_Outputs
, Constit_Id
)
24720 ("output state & must be replaced by all its "
24721 & "constituents in dependence refinement",
24726 ("\constituent & is missing in output list",
24730 Next_Elmt
(Constit_Elmt
);
24733 end Check_Constituent_Usage
;
24738 Item_Elmt
: Elmt_Id
;
24739 Item_Id
: Entity_Id
;
24741 -- Start of processing for Check_Output_States
24744 -- Do not perform this check in an instance because it was already
24745 -- performed successfully in the generic template.
24747 if Is_Generic_Instance
(Spec_Id
) then
24750 -- Inspect the outputs of pragma Depends looking for a state with a
24751 -- visible refinement.
24753 elsif Present
(Spec_Outputs
) then
24754 Item_Elmt
:= First_Elmt
(Spec_Outputs
);
24755 while Present
(Item_Elmt
) loop
24756 Item
:= Node
(Item_Elmt
);
24758 -- Deal with the mixed nature of the input and output lists
24760 if Nkind
(Item
) = N_Defining_Identifier
then
24763 Item_Id
:= Available_View
(Entity_Of
(Item
));
24766 if Ekind
(Item_Id
) = E_Abstract_State
then
24768 -- The state acts as an input-output, skip it
24770 if Present
(Spec_Inputs
)
24771 and then Appears_In
(Spec_Inputs
, Item_Id
)
24775 -- Ensure that all of the constituents are utilized as
24776 -- outputs in pragma Refined_Depends.
24778 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
24779 Check_Constituent_Usage
(Item_Id
);
24783 Next_Elmt
(Item_Elmt
);
24786 end Check_Output_States
;
24788 --------------------
24789 -- Collect_States --
24790 --------------------
24792 function Collect_States
(Clauses
: List_Id
) return Elist_Id
is
24793 procedure Collect_State
24795 States
: in out Elist_Id
);
24796 -- Add the entity of Item to list States when it denotes to a state
24798 -------------------
24799 -- Collect_State --
24800 -------------------
24802 procedure Collect_State
24804 States
: in out Elist_Id
)
24809 if Is_Entity_Name
(Item
) then
24810 Id
:= Entity_Of
(Item
);
24812 if Ekind
(Id
) = E_Abstract_State
then
24813 if No
(States
) then
24814 States
:= New_Elmt_List
;
24817 Append_Unique_Elmt
(Id
, States
);
24827 States
: Elist_Id
:= No_Elist
;
24829 -- Start of processing for Collect_States
24832 Clause
:= First
(Clauses
);
24833 while Present
(Clause
) loop
24834 Input
:= Expression
(Clause
);
24835 Output
:= First
(Choices
(Clause
));
24837 Collect_State
(Input
, States
);
24838 Collect_State
(Output
, States
);
24844 end Collect_States
;
24846 -----------------------
24847 -- Normalize_Clauses --
24848 -----------------------
24850 procedure Normalize_Clauses
(Clauses
: List_Id
) is
24851 procedure Normalize_Inputs
(Clause
: Node_Id
);
24852 -- Normalize clause Clause by creating multiple clauses for each
24853 -- input item of Clause. It is assumed that Clause has exactly one
24854 -- output. The transformation is as follows:
24856 -- Output => (Input_1, Input_2) -- original
24858 -- Output => Input_1 -- normalizations
24859 -- Output => Input_2
24861 procedure Normalize_Outputs
(Clause
: Node_Id
);
24862 -- Normalize clause Clause by creating multiple clause for each
24863 -- output item of Clause. The transformation is as follows:
24865 -- (Output_1, Output_2) => Input -- original
24867 -- Output_1 => Input -- normalization
24868 -- Output_2 => Input
24870 ----------------------
24871 -- Normalize_Inputs --
24872 ----------------------
24874 procedure Normalize_Inputs
(Clause
: Node_Id
) is
24875 Inputs
: constant Node_Id
:= Expression
(Clause
);
24876 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24877 Output
: constant List_Id
:= Choices
(Clause
);
24878 Last_Input
: Node_Id
;
24880 New_Clause
: Node_Id
;
24881 Next_Input
: Node_Id
;
24884 -- Normalization is performed only when the original clause has
24885 -- more than one input. Multiple inputs appear as an aggregate.
24887 if Nkind
(Inputs
) = N_Aggregate
then
24888 Last_Input
:= Last
(Expressions
(Inputs
));
24890 -- Create a new clause for each input
24892 Input
:= First
(Expressions
(Inputs
));
24893 while Present
(Input
) loop
24894 Next_Input
:= Next
(Input
);
24896 -- Unhook the current input from the original input list
24897 -- because it will be relocated to a new clause.
24901 -- Special processing for the last input. At this point the
24902 -- original aggregate has been stripped down to one element.
24903 -- Replace the aggregate by the element itself.
24905 if Input
= Last_Input
then
24906 Rewrite
(Inputs
, Input
);
24908 -- Generate a clause of the form:
24913 Make_Component_Association
(Loc
,
24914 Choices
=> New_Copy_List_Tree
(Output
),
24915 Expression
=> Input
);
24917 -- The new clause contains replicated content that has
24918 -- already been analyzed, mark the clause as analyzed.
24920 Set_Analyzed
(New_Clause
);
24921 Insert_After
(Clause
, New_Clause
);
24924 Input
:= Next_Input
;
24927 end Normalize_Inputs
;
24929 -----------------------
24930 -- Normalize_Outputs --
24931 -----------------------
24933 procedure Normalize_Outputs
(Clause
: Node_Id
) is
24934 Inputs
: constant Node_Id
:= Expression
(Clause
);
24935 Loc
: constant Source_Ptr
:= Sloc
(Clause
);
24936 Outputs
: constant Node_Id
:= First
(Choices
(Clause
));
24937 Last_Output
: Node_Id
;
24938 New_Clause
: Node_Id
;
24939 Next_Output
: Node_Id
;
24943 -- Multiple outputs appear as an aggregate. Nothing to do when
24944 -- the clause has exactly one output.
24946 if Nkind
(Outputs
) = N_Aggregate
then
24947 Last_Output
:= Last
(Expressions
(Outputs
));
24949 -- Create a clause for each output. Note that each time a new
24950 -- clause is created, the original output list slowly shrinks
24951 -- until there is one item left.
24953 Output
:= First
(Expressions
(Outputs
));
24954 while Present
(Output
) loop
24955 Next_Output
:= Next
(Output
);
24957 -- Unhook the output from the original output list as it
24958 -- will be relocated to a new clause.
24962 -- Special processing for the last output. At this point
24963 -- the original aggregate has been stripped down to one
24964 -- element. Replace the aggregate by the element itself.
24966 if Output
= Last_Output
then
24967 Rewrite
(Outputs
, Output
);
24970 -- Generate a clause of the form:
24971 -- (Output => Inputs)
24974 Make_Component_Association
(Loc
,
24975 Choices
=> New_List
(Output
),
24976 Expression
=> New_Copy_Tree
(Inputs
));
24978 -- The new clause contains replicated content that has
24979 -- already been analyzed. There is not need to reanalyze
24982 Set_Analyzed
(New_Clause
);
24983 Insert_After
(Clause
, New_Clause
);
24986 Output
:= Next_Output
;
24989 end Normalize_Outputs
;
24995 -- Start of processing for Normalize_Clauses
24998 Clause
:= First
(Clauses
);
24999 while Present
(Clause
) loop
25000 Normalize_Outputs
(Clause
);
25004 Clause
:= First
(Clauses
);
25005 while Present
(Clause
) loop
25006 Normalize_Inputs
(Clause
);
25009 end Normalize_Clauses
;
25011 --------------------------
25012 -- Remove_Extra_Clauses --
25013 --------------------------
25015 procedure Remove_Extra_Clauses
25016 (Clauses
: List_Id
;
25017 Matched_Items
: Elist_Id
)
25021 Input_Id
: Entity_Id
;
25022 Next_Clause
: Node_Id
;
25024 State_Id
: Entity_Id
;
25027 Clause
:= First
(Clauses
);
25028 while Present
(Clause
) loop
25029 Next_Clause
:= Next
(Clause
);
25031 Input
:= Expression
(Clause
);
25032 Output
:= First
(Choices
(Clause
));
25034 -- Recognize a clause of the form
25038 -- where Input is a constituent of a state which was already
25039 -- successfully matched. This clause must be removed because it
25040 -- simply indicates that some of the constituents of the state
25043 -- Refined_State => (State => (Constit_1, Constit_2))
25044 -- Depends => (Output => State)
25045 -- Refined_Depends => ((Output => Constit_1), -- State matched
25046 -- (null => Constit_2)) -- OK
25048 if Nkind
(Output
) = N_Null
and then Is_Entity_Name
(Input
) then
25050 -- Handle abstract views generated for limited with clauses
25052 Input_Id
:= Available_View
(Entity_Of
(Input
));
25054 -- The input must be a constituent of a state
25056 if Ekind_In
(Input_Id
, E_Abstract_State
,
25059 and then Present
(Encapsulating_State
(Input_Id
))
25061 State_Id
:= Encapsulating_State
(Input_Id
);
25063 -- The state must have a non-null visible refinement and be
25064 -- matched in a previous clause.
25066 if Has_Non_Null_Visible_Refinement
(State_Id
)
25067 and then Contains
(Matched_Items
, State_Id
)
25073 -- Recognize a clause of the form
25077 -- where Output is an arbitrary item. This clause must be removed
25078 -- because a null input legitimately matches anything.
25080 elsif Nkind
(Input
) = N_Null
then
25084 Clause
:= Next_Clause
;
25086 end Remove_Extra_Clauses
;
25088 --------------------------
25089 -- Report_Extra_Clauses --
25090 --------------------------
25092 procedure Report_Extra_Clauses
25093 (Spec_Id
: Entity_Id
;
25099 -- Do not perform this check in an instance because it was already
25100 -- performed successfully in the generic template.
25102 if Is_Generic_Instance
(Spec_Id
) then
25105 elsif Present
(Clauses
) then
25106 Clause
:= First
(Clauses
);
25107 while Present
(Clause
) loop
25109 ("unmatched or extra clause in dependence refinement",
25115 end Report_Extra_Clauses
;
25119 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
25120 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
25121 Errors
: constant Nat
:= Serious_Errors_Detected
;
25128 Body_Inputs
: Elist_Id
:= No_Elist
;
25129 Body_Outputs
: Elist_Id
:= No_Elist
;
25130 -- The inputs and outputs of the subprogram body synthesized from pragma
25131 -- Refined_Depends.
25133 Dependencies
: List_Id
:= No_List
;
25135 -- The corresponding Depends pragma along with its clauses
25137 Matched_Items
: Elist_Id
:= No_Elist
;
25138 -- A list containing the entities of all successfully matched items
25139 -- found in pragma Depends.
25141 Refinements
: List_Id
:= No_List
;
25142 -- The clauses of pragma Refined_Depends
25144 Spec_Id
: Entity_Id
;
25145 -- The entity of the subprogram subject to pragma Refined_Depends
25147 Spec_Inputs
: Elist_Id
:= No_Elist
;
25148 Spec_Outputs
: Elist_Id
:= No_Elist
;
25149 -- The inputs and outputs of the subprogram spec synthesized from pragma
25152 States
: Elist_Id
:= No_Elist
;
25153 -- A list containing the entities of all states whose constituents
25154 -- appear in pragma Depends.
25156 -- Start of processing for Analyze_Refined_Depends_In_Decl_Part
25159 -- Do not analyze the pragma multiple times
25161 if Is_Analyzed_Pragma
(N
) then
25165 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
25167 -- Use the anonymous object as the proper spec when Refined_Depends
25168 -- applies to the body of a single task type. The object carries the
25169 -- proper Chars as well as all non-refined versions of pragmas.
25171 if Is_Single_Concurrent_Type
(Spec_Id
) then
25172 Spec_Id
:= Anonymous_Object
(Spec_Id
);
25175 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
25177 -- Subprogram declarations lacks pragma Depends. Refined_Depends is
25178 -- rendered useless as there is nothing to refine (SPARK RM 7.2.5(2)).
25180 if No
(Depends
) then
25182 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
25183 & "& lacks aspect or pragma Depends"), N
, Spec_Id
);
25187 Deps
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
25189 -- A null dependency relation renders the refinement useless because it
25190 -- cannot possibly mention abstract states with visible refinement. Note
25191 -- that the inverse is not true as states may be refined to null
25192 -- (SPARK RM 7.2.5(2)).
25194 if Nkind
(Deps
) = N_Null
then
25196 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
25197 & "depend on abstract state with visible refinement"), N
, Spec_Id
);
25201 -- Analyze Refined_Depends as if it behaved as a regular pragma Depends.
25202 -- This ensures that the categorization of all refined dependency items
25203 -- is consistent with their role.
25205 Analyze_Depends_In_Decl_Part
(N
);
25207 -- Do not match dependencies against refinements if Refined_Depends is
25208 -- illegal to avoid emitting misleading error.
25210 if Serious_Errors_Detected
= Errors
then
25212 -- The related subprogram lacks pragma [Refined_]Global. Synthesize
25213 -- the inputs and outputs of the subprogram spec and body to verify
25214 -- the use of states with visible refinement and their constituents.
25216 if No
(Get_Pragma
(Spec_Id
, Pragma_Global
))
25217 or else No
(Get_Pragma
(Body_Id
, Pragma_Refined_Global
))
25219 Collect_Subprogram_Inputs_Outputs
25220 (Subp_Id
=> Spec_Id
,
25221 Synthesize
=> True,
25222 Subp_Inputs
=> Spec_Inputs
,
25223 Subp_Outputs
=> Spec_Outputs
,
25224 Global_Seen
=> Dummy
);
25226 Collect_Subprogram_Inputs_Outputs
25227 (Subp_Id
=> Body_Id
,
25228 Synthesize
=> True,
25229 Subp_Inputs
=> Body_Inputs
,
25230 Subp_Outputs
=> Body_Outputs
,
25231 Global_Seen
=> Dummy
);
25233 -- For an output state with a visible refinement, ensure that all
25234 -- constituents appear as outputs in the dependency refinement.
25236 Check_Output_States
25237 (Spec_Id
=> Spec_Id
,
25238 Spec_Inputs
=> Spec_Inputs
,
25239 Spec_Outputs
=> Spec_Outputs
,
25240 Body_Inputs
=> Body_Inputs
,
25241 Body_Outputs
=> Body_Outputs
);
25244 -- Matching is disabled in ASIS because clauses are not normalized as
25245 -- this is a tree altering activity similar to expansion.
25251 -- Multiple dependency clauses appear as component associations of an
25252 -- aggregate. Note that the clauses are copied because the algorithm
25253 -- modifies them and this should not be visible in Depends.
25255 pragma Assert
(Nkind
(Deps
) = N_Aggregate
);
25256 Dependencies
:= New_Copy_List_Tree
(Component_Associations
(Deps
));
25257 Normalize_Clauses
(Dependencies
);
25259 -- Gather all states which appear in Depends
25261 States
:= Collect_States
(Dependencies
);
25263 Refs
:= Expression
(Get_Argument
(N
, Spec_Id
));
25265 if Nkind
(Refs
) = N_Null
then
25266 Refinements
:= No_List
;
25268 -- Multiple dependency clauses appear as component associations of an
25269 -- aggregate. Note that the clauses are copied because the algorithm
25270 -- modifies them and this should not be visible in Refined_Depends.
25272 else pragma Assert
(Nkind
(Refs
) = N_Aggregate
);
25273 Refinements
:= New_Copy_List_Tree
(Component_Associations
(Refs
));
25274 Normalize_Clauses
(Refinements
);
25277 -- At this point the clauses of pragmas Depends and Refined_Depends
25278 -- have been normalized into simple dependencies between one output
25279 -- and one input. Examine all clauses of pragma Depends looking for
25280 -- matching clauses in pragma Refined_Depends.
25282 Clause
:= First
(Dependencies
);
25283 while Present
(Clause
) loop
25284 Check_Dependency_Clause
25285 (Spec_Id
=> Spec_Id
,
25286 Dep_Clause
=> Clause
,
25287 Dep_States
=> States
,
25288 Refinements
=> Refinements
,
25289 Matched_Items
=> Matched_Items
);
25294 -- Pragma Refined_Depends may contain multiple clarification clauses
25295 -- which indicate that certain constituents do not influence the data
25296 -- flow in any way. Such clauses must be removed as long as the state
25297 -- has been matched, otherwise they will be incorrectly flagged as
25300 -- Refined_State => (State => (Constit_1, Constit_2))
25301 -- Depends => (Output => State)
25302 -- Refined_Depends => ((Output => Constit_1), -- State matched
25303 -- (null => Constit_2)) -- must be removed
25305 Remove_Extra_Clauses
(Refinements
, Matched_Items
);
25307 if Serious_Errors_Detected
= Errors
then
25308 Report_Extra_Clauses
(Spec_Id
, Refinements
);
25313 Set_Is_Analyzed_Pragma
(N
);
25314 end Analyze_Refined_Depends_In_Decl_Part
;
25316 -----------------------------------------
25317 -- Analyze_Refined_Global_In_Decl_Part --
25318 -----------------------------------------
25320 procedure Analyze_Refined_Global_In_Decl_Part
(N
: Node_Id
) is
25322 -- The corresponding Global pragma
25324 Has_In_State
: Boolean := False;
25325 Has_In_Out_State
: Boolean := False;
25326 Has_Out_State
: Boolean := False;
25327 Has_Proof_In_State
: Boolean := False;
25328 -- These flags are set when the corresponding Global pragma has a state
25329 -- of mode Input, In_Out, Output or Proof_In respectively with a visible
25332 Has_Null_State
: Boolean := False;
25333 -- This flag is set when the corresponding Global pragma has at least
25334 -- one state with a null refinement.
25336 In_Constits
: Elist_Id
:= No_Elist
;
25337 In_Out_Constits
: Elist_Id
:= No_Elist
;
25338 Out_Constits
: Elist_Id
:= No_Elist
;
25339 Proof_In_Constits
: Elist_Id
:= No_Elist
;
25340 -- These lists contain the entities of all Input, In_Out, Output and
25341 -- Proof_In constituents that appear in Refined_Global and participate
25342 -- in state refinement.
25344 In_Items
: Elist_Id
:= No_Elist
;
25345 In_Out_Items
: Elist_Id
:= No_Elist
;
25346 Out_Items
: Elist_Id
:= No_Elist
;
25347 Proof_In_Items
: Elist_Id
:= No_Elist
;
25348 -- These lists contain the entities of all Input, In_Out, Output and
25349 -- Proof_In items defined in the corresponding Global pragma.
25351 Repeat_Items
: Elist_Id
:= No_Elist
;
25352 -- A list of all global items without full visible refinement found
25353 -- in pragma Global. These states should be repeated in the global
25354 -- refinement (SPARK RM 7.2.4(3c)) unless they have a partial visible
25355 -- refinement, in which case they may be repeated (SPARK RM 7.2.4(3d)).
25357 Spec_Id
: Entity_Id
;
25358 -- The entity of the subprogram subject to pragma Refined_Global
25360 States
: Elist_Id
:= No_Elist
;
25361 -- A list of all states with full or partial visible refinement found in
25364 procedure Check_In_Out_States
;
25365 -- Determine whether the corresponding Global pragma mentions In_Out
25366 -- states with visible refinement and if so, ensure that one of the
25367 -- following completions apply to the constituents of the state:
25368 -- 1) there is at least one constituent of mode In_Out
25369 -- 2) there is at least one Input and one Output constituent
25370 -- 3) not all constituents are present and one of them is of mode
25372 -- This routine may remove elements from In_Constits, In_Out_Constits,
25373 -- Out_Constits and Proof_In_Constits.
25375 procedure Check_Input_States
;
25376 -- Determine whether the corresponding Global pragma mentions Input
25377 -- states with visible refinement and if so, ensure that at least one of
25378 -- its constituents appears as an Input item in Refined_Global.
25379 -- This routine may remove elements from In_Constits, In_Out_Constits,
25380 -- Out_Constits and Proof_In_Constits.
25382 procedure Check_Output_States
;
25383 -- Determine whether the corresponding Global pragma mentions Output
25384 -- states with visible refinement and if so, ensure that all of its
25385 -- constituents appear as Output items in Refined_Global.
25386 -- This routine may remove elements from In_Constits, In_Out_Constits,
25387 -- Out_Constits and Proof_In_Constits.
25389 procedure Check_Proof_In_States
;
25390 -- Determine whether the corresponding Global pragma mentions Proof_In
25391 -- states with visible refinement and if so, ensure that at least one of
25392 -- its constituents appears as a Proof_In item in Refined_Global.
25393 -- This routine may remove elements from In_Constits, In_Out_Constits,
25394 -- Out_Constits and Proof_In_Constits.
25396 procedure Check_Refined_Global_List
25398 Global_Mode
: Name_Id
:= Name_Input
);
25399 -- Verify the legality of a single global list declaration. Global_Mode
25400 -- denotes the current mode in effect.
25402 procedure Collect_Global_Items
25404 Mode
: Name_Id
:= Name_Input
);
25405 -- Gather all Input, In_Out, Output and Proof_In items from node List
25406 -- and separate them in lists In_Items, In_Out_Items, Out_Items and
25407 -- Proof_In_Items. Flags Has_In_State, Has_In_Out_State, Has_Out_State
25408 -- and Has_Proof_In_State are set when there is at least one abstract
25409 -- state with full or partial visible refinement available in the
25410 -- corresponding mode. Flag Has_Null_State is set when at least state
25411 -- has a null refinement. Mode denotes the current global mode in
25414 function Present_Then_Remove
25416 Item
: Entity_Id
) return Boolean;
25417 -- Search List for a particular entity Item. If Item has been found,
25418 -- remove it from List. This routine is used to strip lists In_Constits,
25419 -- In_Out_Constits and Out_Constits of valid constituents.
25421 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
);
25422 -- Same as function Present_Then_Remove, but do not report the presence
25423 -- of Item in List.
25425 procedure Report_Extra_Constituents
;
25426 -- Emit an error for each constituent found in lists In_Constits,
25427 -- In_Out_Constits and Out_Constits.
25429 procedure Report_Missing_Items
;
25430 -- Emit an error for each global item not repeated found in list
25433 -------------------------
25434 -- Check_In_Out_States --
25435 -------------------------
25437 procedure Check_In_Out_States
is
25438 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25439 -- Determine whether one of the following coverage scenarios is in
25441 -- 1) there is at least one constituent of mode In_Out or Output
25442 -- 2) there is at least one pair of constituents with modes Input
25443 -- and Output, or Proof_In and Output.
25444 -- 3) there is at least one constituent of mode Output and not all
25445 -- constituents are present.
25446 -- If this is not the case, emit an error (SPARK RM 7.2.4(5)).
25448 -----------------------------
25449 -- Check_Constituent_Usage --
25450 -----------------------------
25452 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25453 Constits
: constant Elist_Id
:=
25454 Partial_Refinement_Constituents
(State_Id
);
25455 Constit_Elmt
: Elmt_Id
;
25456 Constit_Id
: Entity_Id
;
25457 Has_Missing
: Boolean := False;
25458 In_Out_Seen
: Boolean := False;
25459 Input_Seen
: Boolean := False;
25460 Output_Seen
: Boolean := False;
25461 Proof_In_Seen
: Boolean := False;
25464 -- Process all the constituents of the state and note their modes
25465 -- within the global refinement.
25467 if Present
(Constits
) then
25468 Constit_Elmt
:= First_Elmt
(Constits
);
25469 while Present
(Constit_Elmt
) loop
25470 Constit_Id
:= Node
(Constit_Elmt
);
25472 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25473 Input_Seen
:= True;
25475 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
) then
25476 In_Out_Seen
:= True;
25478 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25479 Output_Seen
:= True;
25481 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25483 Proof_In_Seen
:= True;
25486 Has_Missing
:= True;
25489 Next_Elmt
(Constit_Elmt
);
25493 -- An In_Out constituent is a valid completion
25495 if In_Out_Seen
then
25498 -- A pair of one Input/Proof_In and one Output constituent is a
25499 -- valid completion.
25501 elsif (Input_Seen
or Proof_In_Seen
) and Output_Seen
then
25504 elsif Output_Seen
then
25506 -- A single Output constituent is a valid completion only when
25507 -- some of the other constituents are missing.
25509 if Has_Missing
then
25512 -- Otherwise all constituents are of mode Output
25516 ("global refinement of state & must include at least one "
25517 & "constituent of mode `In_Out`, `Input`, or `Proof_In`",
25521 -- The state lacks a completion. When full refinement is visible,
25522 -- always emit an error (SPARK RM 7.2.4(3a)). When only partial
25523 -- refinement is visible, emit an error if the abstract state
25524 -- itself is not utilized (SPARK RM 7.2.4(3d)). In the case where
25525 -- both are utilized, Check_State_And_Constituent_Use. will issue
25528 elsif not Input_Seen
25529 and then not In_Out_Seen
25530 and then not Output_Seen
25531 and then not Proof_In_Seen
25533 if Has_Visible_Refinement
(State_Id
)
25534 or else Contains
(Repeat_Items
, State_Id
)
25537 ("missing global refinement of state &", N
, State_Id
);
25540 -- Otherwise the state has a malformed completion where at least
25541 -- one of the constituents has a different mode.
25545 ("global refinement of state & redefines the mode of its "
25546 & "constituents", N
, State_Id
);
25548 end Check_Constituent_Usage
;
25552 Item_Elmt
: Elmt_Id
;
25553 Item_Id
: Entity_Id
;
25555 -- Start of processing for Check_In_Out_States
25558 -- Do not perform this check in an instance because it was already
25559 -- performed successfully in the generic template.
25561 if Is_Generic_Instance
(Spec_Id
) then
25564 -- Inspect the In_Out items of the corresponding Global pragma
25565 -- looking for a state with a visible refinement.
25567 elsif Has_In_Out_State
and then Present
(In_Out_Items
) then
25568 Item_Elmt
:= First_Elmt
(In_Out_Items
);
25569 while Present
(Item_Elmt
) loop
25570 Item_Id
:= Node
(Item_Elmt
);
25572 -- Ensure that one of the three coverage variants is satisfied
25574 if Ekind
(Item_Id
) = E_Abstract_State
25575 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25577 Check_Constituent_Usage
(Item_Id
);
25580 Next_Elmt
(Item_Elmt
);
25583 end Check_In_Out_States
;
25585 ------------------------
25586 -- Check_Input_States --
25587 ------------------------
25589 procedure Check_Input_States
is
25590 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25591 -- Determine whether at least one constituent of state State_Id with
25592 -- full or partial visible refinement is used and has mode Input.
25593 -- Ensure that the remaining constituents do not have In_Out or
25594 -- Output modes. Emit an error if this is not the case
25595 -- (SPARK RM 7.2.4(5)).
25597 -----------------------------
25598 -- Check_Constituent_Usage --
25599 -----------------------------
25601 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25602 Constits
: constant Elist_Id
:=
25603 Partial_Refinement_Constituents
(State_Id
);
25604 Constit_Elmt
: Elmt_Id
;
25605 Constit_Id
: Entity_Id
;
25606 In_Seen
: Boolean := False;
25609 if Present
(Constits
) then
25610 Constit_Elmt
:= First_Elmt
(Constits
);
25611 while Present
(Constit_Elmt
) loop
25612 Constit_Id
:= Node
(Constit_Elmt
);
25614 -- At least one of the constituents appears as an Input
25616 if Present_Then_Remove
(In_Constits
, Constit_Id
) then
25619 -- A Proof_In constituent can refine an Input state as long
25620 -- as there is at least one Input constituent present.
25622 elsif Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25626 -- The constituent appears in the global refinement, but has
25627 -- mode In_Out or Output (SPARK RM 7.2.4(5)).
25629 elsif Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25630 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25632 Error_Msg_Name_1
:= Chars
(State_Id
);
25634 ("constituent & of state % must have mode `Input` in "
25635 & "global refinement", N
, Constit_Id
);
25638 Next_Elmt
(Constit_Elmt
);
25642 -- Not one of the constituents appeared as Input. Always emit an
25643 -- error when the full refinement is visible (SPARK RM 7.2.4(3a)).
25644 -- When only partial refinement is visible, emit an error if the
25645 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25646 -- the case where both are utilized, an error will be issued in
25647 -- Check_State_And_Constituent_Use.
25650 and then (Has_Visible_Refinement
(State_Id
)
25651 or else Contains
(Repeat_Items
, State_Id
))
25654 ("global refinement of state & must include at least one "
25655 & "constituent of mode `Input`", N
, State_Id
);
25657 end Check_Constituent_Usage
;
25661 Item_Elmt
: Elmt_Id
;
25662 Item_Id
: Entity_Id
;
25664 -- Start of processing for Check_Input_States
25667 -- Do not perform this check in an instance because it was already
25668 -- performed successfully in the generic template.
25670 if Is_Generic_Instance
(Spec_Id
) then
25673 -- Inspect the Input items of the corresponding Global pragma looking
25674 -- for a state with a visible refinement.
25676 elsif Has_In_State
and then Present
(In_Items
) then
25677 Item_Elmt
:= First_Elmt
(In_Items
);
25678 while Present
(Item_Elmt
) loop
25679 Item_Id
:= Node
(Item_Elmt
);
25681 -- When full refinement is visible, ensure that at least one of
25682 -- the constituents is utilized and is of mode Input. When only
25683 -- partial refinement is visible, ensure that either one of
25684 -- the constituents is utilized and is of mode Input, or the
25685 -- abstract state is repeated and no constituent is utilized.
25687 if Ekind
(Item_Id
) = E_Abstract_State
25688 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25690 Check_Constituent_Usage
(Item_Id
);
25693 Next_Elmt
(Item_Elmt
);
25696 end Check_Input_States
;
25698 -------------------------
25699 -- Check_Output_States --
25700 -------------------------
25702 procedure Check_Output_States
is
25703 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25704 -- Determine whether all constituents of state State_Id with full
25705 -- visible refinement are used and have mode Output. Emit an error
25706 -- if this is not the case (SPARK RM 7.2.4(5)).
25708 -----------------------------
25709 -- Check_Constituent_Usage --
25710 -----------------------------
25712 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25713 Constits
: constant Elist_Id
:=
25714 Partial_Refinement_Constituents
(State_Id
);
25715 Only_Partial
: constant Boolean :=
25716 not Has_Visible_Refinement
(State_Id
);
25717 Constit_Elmt
: Elmt_Id
;
25718 Constit_Id
: Entity_Id
;
25719 Posted
: Boolean := False;
25722 if Present
(Constits
) then
25723 Constit_Elmt
:= First_Elmt
(Constits
);
25724 while Present
(Constit_Elmt
) loop
25725 Constit_Id
:= Node
(Constit_Elmt
);
25727 -- Issue an error when a constituent of State_Id is utilized
25728 -- and State_Id has only partial visible refinement
25729 -- (SPARK RM 7.2.4(3d)).
25731 if Only_Partial
then
25732 if Present_Then_Remove
(Out_Constits
, Constit_Id
)
25733 or else Present_Then_Remove
(In_Constits
, Constit_Id
)
25735 Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25737 Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25739 Error_Msg_Name_1
:= Chars
(State_Id
);
25741 ("constituent & of state % cannot be used in global "
25742 & "refinement", N
, Constit_Id
);
25743 Error_Msg_Name_1
:= Chars
(State_Id
);
25744 SPARK_Msg_N
("\use state % instead", N
);
25747 elsif Present_Then_Remove
(Out_Constits
, Constit_Id
) then
25750 -- The constituent appears in the global refinement, but has
25751 -- mode Input, In_Out or Proof_In (SPARK RM 7.2.4(5)).
25753 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25754 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25755 or else Present_Then_Remove
(Proof_In_Constits
, Constit_Id
)
25757 Error_Msg_Name_1
:= Chars
(State_Id
);
25759 ("constituent & of state % must have mode `Output` in "
25760 & "global refinement", N
, Constit_Id
);
25762 -- The constituent is altogether missing (SPARK RM 7.2.5(3))
25768 ("`Output` state & must be replaced by all its "
25769 & "constituents in global refinement", N
, State_Id
);
25773 ("\constituent & is missing in output list",
25777 Next_Elmt
(Constit_Elmt
);
25780 end Check_Constituent_Usage
;
25784 Item_Elmt
: Elmt_Id
;
25785 Item_Id
: Entity_Id
;
25787 -- Start of processing for Check_Output_States
25790 -- Do not perform this check in an instance because it was already
25791 -- performed successfully in the generic template.
25793 if Is_Generic_Instance
(Spec_Id
) then
25796 -- Inspect the Output items of the corresponding Global pragma
25797 -- looking for a state with a visible refinement.
25799 elsif Has_Out_State
and then Present
(Out_Items
) then
25800 Item_Elmt
:= First_Elmt
(Out_Items
);
25801 while Present
(Item_Elmt
) loop
25802 Item_Id
:= Node
(Item_Elmt
);
25804 -- When full refinement is visible, ensure that all of the
25805 -- constituents are utilized and they have mode Output. When
25806 -- only partial refinement is visible, ensure that no
25807 -- constituent is utilized.
25809 if Ekind
(Item_Id
) = E_Abstract_State
25810 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25812 Check_Constituent_Usage
(Item_Id
);
25815 Next_Elmt
(Item_Elmt
);
25818 end Check_Output_States
;
25820 ---------------------------
25821 -- Check_Proof_In_States --
25822 ---------------------------
25824 procedure Check_Proof_In_States
is
25825 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
);
25826 -- Determine whether at least one constituent of state State_Id with
25827 -- full or partial visible refinement is used and has mode Proof_In.
25828 -- Ensure that the remaining constituents do not have Input, In_Out,
25829 -- or Output modes. Emit an error if this is not the case
25830 -- (SPARK RM 7.2.4(5)).
25832 -----------------------------
25833 -- Check_Constituent_Usage --
25834 -----------------------------
25836 procedure Check_Constituent_Usage
(State_Id
: Entity_Id
) is
25837 Constits
: constant Elist_Id
:=
25838 Partial_Refinement_Constituents
(State_Id
);
25839 Constit_Elmt
: Elmt_Id
;
25840 Constit_Id
: Entity_Id
;
25841 Proof_In_Seen
: Boolean := False;
25844 if Present
(Constits
) then
25845 Constit_Elmt
:= First_Elmt
(Constits
);
25846 while Present
(Constit_Elmt
) loop
25847 Constit_Id
:= Node
(Constit_Elmt
);
25849 -- At least one of the constituents appears as Proof_In
25851 if Present_Then_Remove
(Proof_In_Constits
, Constit_Id
) then
25852 Proof_In_Seen
:= True;
25854 -- The constituent appears in the global refinement, but has
25855 -- mode Input, In_Out or Output (SPARK RM 7.2.4(5)).
25857 elsif Present_Then_Remove
(In_Constits
, Constit_Id
)
25858 or else Present_Then_Remove
(In_Out_Constits
, Constit_Id
)
25859 or else Present_Then_Remove
(Out_Constits
, Constit_Id
)
25861 Error_Msg_Name_1
:= Chars
(State_Id
);
25863 ("constituent & of state % must have mode `Proof_In` "
25864 & "in global refinement", N
, Constit_Id
);
25867 Next_Elmt
(Constit_Elmt
);
25871 -- Not one of the constituents appeared as Proof_In. Always emit
25872 -- an error when full refinement is visible (SPARK RM 7.2.4(3a)).
25873 -- When only partial refinement is visible, emit an error if the
25874 -- abstract state itself is not utilized (SPARK RM 7.2.4(3d)). In
25875 -- the case where both are utilized, an error will be issued by
25876 -- Check_State_And_Constituent_Use.
25878 if not Proof_In_Seen
25879 and then (Has_Visible_Refinement
(State_Id
)
25880 or else Contains
(Repeat_Items
, State_Id
))
25883 ("global refinement of state & must include at least one "
25884 & "constituent of mode `Proof_In`", N
, State_Id
);
25886 end Check_Constituent_Usage
;
25890 Item_Elmt
: Elmt_Id
;
25891 Item_Id
: Entity_Id
;
25893 -- Start of processing for Check_Proof_In_States
25896 -- Do not perform this check in an instance because it was already
25897 -- performed successfully in the generic template.
25899 if Is_Generic_Instance
(Spec_Id
) then
25902 -- Inspect the Proof_In items of the corresponding Global pragma
25903 -- looking for a state with a visible refinement.
25905 elsif Has_Proof_In_State
and then Present
(Proof_In_Items
) then
25906 Item_Elmt
:= First_Elmt
(Proof_In_Items
);
25907 while Present
(Item_Elmt
) loop
25908 Item_Id
:= Node
(Item_Elmt
);
25910 -- Ensure that at least one of the constituents is utilized
25911 -- and is of mode Proof_In. When only partial refinement is
25912 -- visible, ensure that either one of the constituents is
25913 -- utilized and is of mode Proof_In, or the abstract state
25914 -- is repeated and no constituent is utilized.
25916 if Ekind
(Item_Id
) = E_Abstract_State
25917 and then Has_Non_Null_Visible_Refinement
(Item_Id
)
25919 Check_Constituent_Usage
(Item_Id
);
25922 Next_Elmt
(Item_Elmt
);
25925 end Check_Proof_In_States
;
25927 -------------------------------
25928 -- Check_Refined_Global_List --
25929 -------------------------------
25931 procedure Check_Refined_Global_List
25933 Global_Mode
: Name_Id
:= Name_Input
)
25935 procedure Check_Refined_Global_Item
25937 Global_Mode
: Name_Id
);
25938 -- Verify the legality of a single global item declaration. Parameter
25939 -- Global_Mode denotes the current mode in effect.
25941 -------------------------------
25942 -- Check_Refined_Global_Item --
25943 -------------------------------
25945 procedure Check_Refined_Global_Item
25947 Global_Mode
: Name_Id
)
25949 Item_Id
: constant Entity_Id
:= Entity_Of
(Item
);
25951 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
);
25952 -- Issue a common error message for all mode mismatches. Expect
25953 -- denotes the expected mode.
25955 -----------------------------
25956 -- Inconsistent_Mode_Error --
25957 -----------------------------
25959 procedure Inconsistent_Mode_Error
(Expect
: Name_Id
) is
25962 ("global item & has inconsistent modes", Item
, Item_Id
);
25964 Error_Msg_Name_1
:= Global_Mode
;
25965 Error_Msg_Name_2
:= Expect
;
25966 SPARK_Msg_N
("\expected mode %, found mode %", Item
);
25967 end Inconsistent_Mode_Error
;
25971 Enc_State
: Entity_Id
:= Empty
;
25972 -- Encapsulating state for constituent, Empty otherwise
25974 -- Start of processing for Check_Refined_Global_Item
25977 if Ekind_In
(Item_Id
, E_Abstract_State
,
25981 Enc_State
:= Find_Encapsulating_State
(States
, Item_Id
);
25984 -- When the state or object acts as a constituent of another
25985 -- state with a visible refinement, collect it for the state
25986 -- completeness checks performed later on. Note that the item
25987 -- acts as a constituent only when the encapsulating state is
25988 -- present in pragma Global.
25990 if Present
(Enc_State
)
25991 and then (Has_Visible_Refinement
(Enc_State
)
25992 or else Has_Partial_Visible_Refinement
(Enc_State
))
25993 and then Contains
(States
, Enc_State
)
25995 -- If the state has only partial visible refinement, remove it
25996 -- from the list of items that should be repeated from pragma
25999 if not Has_Visible_Refinement
(Enc_State
) then
26000 Present_Then_Remove
(Repeat_Items
, Enc_State
);
26003 if Global_Mode
= Name_Input
then
26004 Append_New_Elmt
(Item_Id
, In_Constits
);
26006 elsif Global_Mode
= Name_In_Out
then
26007 Append_New_Elmt
(Item_Id
, In_Out_Constits
);
26009 elsif Global_Mode
= Name_Output
then
26010 Append_New_Elmt
(Item_Id
, Out_Constits
);
26012 elsif Global_Mode
= Name_Proof_In
then
26013 Append_New_Elmt
(Item_Id
, Proof_In_Constits
);
26016 -- When not a constituent, ensure that both occurrences of the
26017 -- item in pragmas Global and Refined_Global match. Also remove
26018 -- it when present from the list of items that should be repeated
26019 -- from pragma Global.
26022 Present_Then_Remove
(Repeat_Items
, Item_Id
);
26024 if Contains
(In_Items
, Item_Id
) then
26025 if Global_Mode
/= Name_Input
then
26026 Inconsistent_Mode_Error
(Name_Input
);
26029 elsif Contains
(In_Out_Items
, Item_Id
) then
26030 if Global_Mode
/= Name_In_Out
then
26031 Inconsistent_Mode_Error
(Name_In_Out
);
26034 elsif Contains
(Out_Items
, Item_Id
) then
26035 if Global_Mode
/= Name_Output
then
26036 Inconsistent_Mode_Error
(Name_Output
);
26039 elsif Contains
(Proof_In_Items
, Item_Id
) then
26042 -- The item does not appear in the corresponding Global pragma,
26043 -- it must be an extra (SPARK RM 7.2.4(3)).
26046 SPARK_Msg_NE
("extra global item &", Item
, Item_Id
);
26049 end Check_Refined_Global_Item
;
26055 -- Start of processing for Check_Refined_Global_List
26058 -- Do not perform this check in an instance because it was already
26059 -- performed successfully in the generic template.
26061 if Is_Generic_Instance
(Spec_Id
) then
26064 elsif Nkind
(List
) = N_Null
then
26067 -- Single global item declaration
26069 elsif Nkind_In
(List
, N_Expanded_Name
,
26071 N_Selected_Component
)
26073 Check_Refined_Global_Item
(List
, Global_Mode
);
26075 -- Simple global list or moded global list declaration
26077 elsif Nkind
(List
) = N_Aggregate
then
26079 -- The declaration of a simple global list appear as a collection
26082 if Present
(Expressions
(List
)) then
26083 Item
:= First
(Expressions
(List
));
26084 while Present
(Item
) loop
26085 Check_Refined_Global_Item
(Item
, Global_Mode
);
26089 -- The declaration of a moded global list appears as a collection
26090 -- of component associations where individual choices denote
26093 elsif Present
(Component_Associations
(List
)) then
26094 Item
:= First
(Component_Associations
(List
));
26095 while Present
(Item
) loop
26096 Check_Refined_Global_List
26097 (List
=> Expression
(Item
),
26098 Global_Mode
=> Chars
(First
(Choices
(Item
))));
26106 raise Program_Error
;
26112 raise Program_Error
;
26114 end Check_Refined_Global_List
;
26116 --------------------------
26117 -- Collect_Global_Items --
26118 --------------------------
26120 procedure Collect_Global_Items
26122 Mode
: Name_Id
:= Name_Input
)
26124 procedure Collect_Global_Item
26126 Item_Mode
: Name_Id
);
26127 -- Add a single item to the appropriate list. Item_Mode denotes the
26128 -- current mode in effect.
26130 -------------------------
26131 -- Collect_Global_Item --
26132 -------------------------
26134 procedure Collect_Global_Item
26136 Item_Mode
: Name_Id
)
26138 Item_Id
: constant Entity_Id
:= Available_View
(Entity_Of
(Item
));
26139 -- The above handles abstract views of variables and states built
26140 -- for limited with clauses.
26143 -- Signal that the global list contains at least one abstract
26144 -- state with a visible refinement. Note that the refinement may
26145 -- be null in which case there are no constituents.
26147 if Ekind
(Item_Id
) = E_Abstract_State
then
26148 if Has_Null_Visible_Refinement
(Item_Id
) then
26149 Has_Null_State
:= True;
26151 elsif Has_Non_Null_Visible_Refinement
(Item_Id
) then
26152 Append_New_Elmt
(Item_Id
, States
);
26154 if Item_Mode
= Name_Input
then
26155 Has_In_State
:= True;
26156 elsif Item_Mode
= Name_In_Out
then
26157 Has_In_Out_State
:= True;
26158 elsif Item_Mode
= Name_Output
then
26159 Has_Out_State
:= True;
26160 elsif Item_Mode
= Name_Proof_In
then
26161 Has_Proof_In_State
:= True;
26166 -- Record global items without full visible refinement found in
26167 -- pragma Global which should be repeated in the global refinement
26168 -- (SPARK RM 7.2.4(3c), SPARK RM 7.2.4(3d)).
26170 if Ekind
(Item_Id
) /= E_Abstract_State
26171 or else not Has_Visible_Refinement
(Item_Id
)
26173 Append_New_Elmt
(Item_Id
, Repeat_Items
);
26176 -- Add the item to the proper list
26178 if Item_Mode
= Name_Input
then
26179 Append_New_Elmt
(Item_Id
, In_Items
);
26180 elsif Item_Mode
= Name_In_Out
then
26181 Append_New_Elmt
(Item_Id
, In_Out_Items
);
26182 elsif Item_Mode
= Name_Output
then
26183 Append_New_Elmt
(Item_Id
, Out_Items
);
26184 elsif Item_Mode
= Name_Proof_In
then
26185 Append_New_Elmt
(Item_Id
, Proof_In_Items
);
26187 end Collect_Global_Item
;
26193 -- Start of processing for Collect_Global_Items
26196 if Nkind
(List
) = N_Null
then
26199 -- Single global item declaration
26201 elsif Nkind_In
(List
, N_Expanded_Name
,
26203 N_Selected_Component
)
26205 Collect_Global_Item
(List
, Mode
);
26207 -- Single global list or moded global list declaration
26209 elsif Nkind
(List
) = N_Aggregate
then
26211 -- The declaration of a simple global list appear as a collection
26214 if Present
(Expressions
(List
)) then
26215 Item
:= First
(Expressions
(List
));
26216 while Present
(Item
) loop
26217 Collect_Global_Item
(Item
, Mode
);
26221 -- The declaration of a moded global list appears as a collection
26222 -- of component associations where individual choices denote mode.
26224 elsif Present
(Component_Associations
(List
)) then
26225 Item
:= First
(Component_Associations
(List
));
26226 while Present
(Item
) loop
26227 Collect_Global_Items
26228 (List
=> Expression
(Item
),
26229 Mode
=> Chars
(First
(Choices
(Item
))));
26237 raise Program_Error
;
26240 -- To accommodate partial decoration of disabled SPARK features, this
26241 -- routine may be called with illegal input. If this is the case, do
26242 -- not raise Program_Error.
26247 end Collect_Global_Items
;
26249 -------------------------
26250 -- Present_Then_Remove --
26251 -------------------------
26253 function Present_Then_Remove
26255 Item
: Entity_Id
) return Boolean
26260 if Present
(List
) then
26261 Elmt
:= First_Elmt
(List
);
26262 while Present
(Elmt
) loop
26263 if Node
(Elmt
) = Item
then
26264 Remove_Elmt
(List
, Elmt
);
26273 end Present_Then_Remove
;
26275 procedure Present_Then_Remove
(List
: Elist_Id
; Item
: Entity_Id
) is
26278 Ignore
:= Present_Then_Remove
(List
, Item
);
26279 end Present_Then_Remove
;
26281 -------------------------------
26282 -- Report_Extra_Constituents --
26283 -------------------------------
26285 procedure Report_Extra_Constituents
is
26286 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
);
26287 -- Emit an error for every element of List
26289 ---------------------------------------
26290 -- Report_Extra_Constituents_In_List --
26291 ---------------------------------------
26293 procedure Report_Extra_Constituents_In_List
(List
: Elist_Id
) is
26294 Constit_Elmt
: Elmt_Id
;
26297 if Present
(List
) then
26298 Constit_Elmt
:= First_Elmt
(List
);
26299 while Present
(Constit_Elmt
) loop
26300 SPARK_Msg_NE
("extra constituent &", N
, Node
(Constit_Elmt
));
26301 Next_Elmt
(Constit_Elmt
);
26304 end Report_Extra_Constituents_In_List
;
26306 -- Start of processing for Report_Extra_Constituents
26309 -- Do not perform this check in an instance because it was already
26310 -- performed successfully in the generic template.
26312 if Is_Generic_Instance
(Spec_Id
) then
26316 Report_Extra_Constituents_In_List
(In_Constits
);
26317 Report_Extra_Constituents_In_List
(In_Out_Constits
);
26318 Report_Extra_Constituents_In_List
(Out_Constits
);
26319 Report_Extra_Constituents_In_List
(Proof_In_Constits
);
26321 end Report_Extra_Constituents
;
26323 --------------------------
26324 -- Report_Missing_Items --
26325 --------------------------
26327 procedure Report_Missing_Items
is
26328 Item_Elmt
: Elmt_Id
;
26329 Item_Id
: Entity_Id
;
26332 -- Do not perform this check in an instance because it was already
26333 -- performed successfully in the generic template.
26335 if Is_Generic_Instance
(Spec_Id
) then
26339 if Present
(Repeat_Items
) then
26340 Item_Elmt
:= First_Elmt
(Repeat_Items
);
26341 while Present
(Item_Elmt
) loop
26342 Item_Id
:= Node
(Item_Elmt
);
26343 SPARK_Msg_NE
("missing global item &", N
, Item_Id
);
26344 Next_Elmt
(Item_Elmt
);
26348 end Report_Missing_Items
;
26352 Body_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
26353 Errors
: constant Nat
:= Serious_Errors_Detected
;
26355 No_Constit
: Boolean;
26357 -- Start of processing for Analyze_Refined_Global_In_Decl_Part
26360 -- Do not analyze the pragma multiple times
26362 if Is_Analyzed_Pragma
(N
) then
26366 Spec_Id
:= Unique_Defining_Entity
(Body_Decl
);
26368 -- Use the anonymous object as the proper spec when Refined_Global
26369 -- applies to the body of a single task type. The object carries the
26370 -- proper Chars as well as all non-refined versions of pragmas.
26372 if Is_Single_Concurrent_Type
(Spec_Id
) then
26373 Spec_Id
:= Anonymous_Object
(Spec_Id
);
26376 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
26377 Items
:= Expression
(Get_Argument
(N
, Spec_Id
));
26379 -- The subprogram declaration lacks pragma Global. This renders
26380 -- Refined_Global useless as there is nothing to refine.
26382 if No
(Global
) then
26384 (Fix_Msg
(Spec_Id
, "useless refinement, declaration of subprogram "
26385 & "& lacks aspect or pragma Global"), N
, Spec_Id
);
26389 -- Extract all relevant items from the corresponding Global pragma
26391 Collect_Global_Items
(Expression
(Get_Argument
(Global
, Spec_Id
)));
26393 -- Package and subprogram bodies are instantiated individually in
26394 -- a separate compiler pass. Due to this mode of instantiation, the
26395 -- refinement of a state may no longer be visible when a subprogram
26396 -- body contract is instantiated. Since the generic template is legal,
26397 -- do not perform this check in the instance to circumvent this oddity.
26399 if Is_Generic_Instance
(Spec_Id
) then
26402 -- Non-instance case
26405 -- The corresponding Global pragma must mention at least one
26406 -- state with a visible refinement at the point Refined_Global
26407 -- is processed. States with null refinements need Refined_Global
26408 -- pragma (SPARK RM 7.2.4(2)).
26410 if not Has_In_State
26411 and then not Has_In_Out_State
26412 and then not Has_Out_State
26413 and then not Has_Proof_In_State
26414 and then not Has_Null_State
26417 (Fix_Msg
(Spec_Id
, "useless refinement, subprogram & does not "
26418 & "depend on abstract state with visible refinement"),
26422 -- The global refinement of inputs and outputs cannot be null when
26423 -- the corresponding Global pragma contains at least one item except
26424 -- in the case where we have states with null refinements.
26426 elsif Nkind
(Items
) = N_Null
26428 (Present
(In_Items
)
26429 or else Present
(In_Out_Items
)
26430 or else Present
(Out_Items
)
26431 or else Present
(Proof_In_Items
))
26432 and then not Has_Null_State
26435 (Fix_Msg
(Spec_Id
, "refinement cannot be null, subprogram & has "
26436 & "global items"), N
, Spec_Id
);
26441 -- Analyze Refined_Global as if it behaved as a regular pragma Global.
26442 -- This ensures that the categorization of all refined global items is
26443 -- consistent with their role.
26445 Analyze_Global_In_Decl_Part
(N
);
26447 -- Perform all refinement checks with respect to completeness and mode
26450 if Serious_Errors_Detected
= Errors
then
26451 Check_Refined_Global_List
(Items
);
26454 -- Store the information that no constituent is used in the global
26455 -- refinement, prior to calling checking procedures which remove items
26456 -- from the list of constituents.
26460 and then No
(In_Out_Constits
)
26461 and then No
(Out_Constits
)
26462 and then No
(Proof_In_Constits
);
26464 -- For Input states with visible refinement, at least one constituent
26465 -- must be used as an Input in the global refinement.
26467 if Serious_Errors_Detected
= Errors
then
26468 Check_Input_States
;
26471 -- Verify all possible completion variants for In_Out states with
26472 -- visible refinement.
26474 if Serious_Errors_Detected
= Errors
then
26475 Check_In_Out_States
;
26478 -- For Output states with visible refinement, all constituents must be
26479 -- used as Outputs in the global refinement.
26481 if Serious_Errors_Detected
= Errors
then
26482 Check_Output_States
;
26485 -- For Proof_In states with visible refinement, at least one constituent
26486 -- must be used as Proof_In in the global refinement.
26488 if Serious_Errors_Detected
= Errors
then
26489 Check_Proof_In_States
;
26492 -- Emit errors for all constituents that belong to other states with
26493 -- visible refinement that do not appear in Global.
26495 if Serious_Errors_Detected
= Errors
then
26496 Report_Extra_Constituents
;
26499 -- Emit errors for all items in Global that are not repeated in the
26500 -- global refinement and for which there is no full visible refinement
26501 -- and, in the case of states with partial visible refinement, no
26502 -- constituent is mentioned in the global refinement.
26504 if Serious_Errors_Detected
= Errors
then
26505 Report_Missing_Items
;
26508 -- Emit an error if no constituent is used in the global refinement
26509 -- (SPARK RM 7.2.4(3f)). Emit this error last, in case a more precise
26510 -- one may be issued by the checking procedures. Do not perform this
26511 -- check in an instance because it was already performed successfully
26512 -- in the generic template.
26514 if Serious_Errors_Detected
= Errors
26515 and then not Is_Generic_Instance
(Spec_Id
)
26516 and then not Has_Null_State
26517 and then No_Constit
26519 SPARK_Msg_N
("missing refinement", N
);
26523 Set_Is_Analyzed_Pragma
(N
);
26524 end Analyze_Refined_Global_In_Decl_Part
;
26526 ----------------------------------------
26527 -- Analyze_Refined_State_In_Decl_Part --
26528 ----------------------------------------
26530 procedure Analyze_Refined_State_In_Decl_Part
26532 Freeze_Id
: Entity_Id
:= Empty
)
26534 Body_Decl
: constant Node_Id
:= Find_Related_Package_Or_Body
(N
);
26535 Body_Id
: constant Entity_Id
:= Defining_Entity
(Body_Decl
);
26536 Spec_Id
: constant Entity_Id
:= Corresponding_Spec
(Body_Decl
);
26538 Available_States
: Elist_Id
:= No_Elist
;
26539 -- A list of all abstract states defined in the package declaration that
26540 -- are available for refinement. The list is used to report unrefined
26543 Body_States
: Elist_Id
:= No_Elist
;
26544 -- A list of all hidden states that appear in the body of the related
26545 -- package. The list is used to report unused hidden states.
26547 Constituents_Seen
: Elist_Id
:= No_Elist
;
26548 -- A list that contains all constituents processed so far. The list is
26549 -- used to detect multiple uses of the same constituent.
26551 Freeze_Posted
: Boolean := False;
26552 -- A flag that controls the output of a freezing-related error (see use
26555 Refined_States_Seen
: Elist_Id
:= No_Elist
;
26556 -- A list that contains all refined states processed so far. The list is
26557 -- used to detect duplicate refinements.
26559 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
);
26560 -- Perform full analysis of a single refinement clause
26562 procedure Report_Unrefined_States
(States
: Elist_Id
);
26563 -- Emit errors for all unrefined abstract states found in list States
26565 -------------------------------
26566 -- Analyze_Refinement_Clause --
26567 -------------------------------
26569 procedure Analyze_Refinement_Clause
(Clause
: Node_Id
) is
26570 AR_Constit
: Entity_Id
:= Empty
;
26571 AW_Constit
: Entity_Id
:= Empty
;
26572 ER_Constit
: Entity_Id
:= Empty
;
26573 EW_Constit
: Entity_Id
:= Empty
;
26574 -- The entities of external constituents that contain one of the
26575 -- following enabled properties: Async_Readers, Async_Writers,
26576 -- Effective_Reads and Effective_Writes.
26578 External_Constit_Seen
: Boolean := False;
26579 -- Flag used to mark when at least one external constituent is part
26580 -- of the state refinement.
26582 Non_Null_Seen
: Boolean := False;
26583 Null_Seen
: Boolean := False;
26584 -- Flags used to detect multiple uses of null in a single clause or a
26585 -- mixture of null and non-null constituents.
26587 Part_Of_Constits
: Elist_Id
:= No_Elist
;
26588 -- A list of all candidate constituents subject to indicator Part_Of
26589 -- where the encapsulating state is the current state.
26592 State_Id
: Entity_Id
;
26593 -- The current state being refined
26595 procedure Analyze_Constituent
(Constit
: Node_Id
);
26596 -- Perform full analysis of a single constituent
26598 procedure Check_External_Property
26599 (Prop_Nam
: Name_Id
;
26601 Constit
: Entity_Id
);
26602 -- Determine whether a property denoted by name Prop_Nam is present
26603 -- in the refined state. Emit an error if this is not the case. Flag
26604 -- Enabled should be set when the property applies to the refined
26605 -- state. Constit denotes the constituent (if any) which introduces
26606 -- the property in the refinement.
26608 procedure Match_State
;
26609 -- Determine whether the state being refined appears in list
26610 -- Available_States. Emit an error when attempting to re-refine the
26611 -- state or when the state is not defined in the package declaration,
26612 -- otherwise remove the state from Available_States.
26614 procedure Report_Unused_Constituents
(Constits
: Elist_Id
);
26615 -- Emit errors for all unused Part_Of constituents in list Constits
26617 -------------------------
26618 -- Analyze_Constituent --
26619 -------------------------
26621 procedure Analyze_Constituent
(Constit
: Node_Id
) is
26622 procedure Match_Constituent
(Constit_Id
: Entity_Id
);
26623 -- Determine whether constituent Constit denoted by its entity
26624 -- Constit_Id appears in Body_States. Emit an error when the
26625 -- constituent is not a valid hidden state of the related package
26626 -- or when it is used more than once. Otherwise remove the
26627 -- constituent from Body_States.
26629 -----------------------
26630 -- Match_Constituent --
26631 -----------------------
26633 procedure Match_Constituent
(Constit_Id
: Entity_Id
) is
26634 procedure Collect_Constituent
;
26635 -- Verify the legality of constituent Constit_Id and add it to
26636 -- the refinements of State_Id.
26638 -------------------------
26639 -- Collect_Constituent --
26640 -------------------------
26642 procedure Collect_Constituent
is
26643 Constits
: Elist_Id
;
26646 -- The Ghost policy in effect at the point of abstract state
26647 -- declaration and constituent must match (SPARK RM 6.9(15))
26649 Check_Ghost_Refinement
26650 (State
, State_Id
, Constit
, Constit_Id
);
26652 -- A synchronized state must be refined by a synchronized
26653 -- object or another synchronized state (SPARK RM 9.6).
26655 if Is_Synchronized_State
(State_Id
)
26656 and then not Is_Synchronized_Object
(Constit_Id
)
26657 and then not Is_Synchronized_State
(Constit_Id
)
26660 ("constituent of synchronized state & must be "
26661 & "synchronized", Constit
, State_Id
);
26664 -- Add the constituent to the list of processed items to aid
26665 -- with the detection of duplicates.
26667 Append_New_Elmt
(Constit_Id
, Constituents_Seen
);
26669 -- Collect the constituent in the list of refinement items
26670 -- and establish a relation between the refined state and
26673 Constits
:= Refinement_Constituents
(State_Id
);
26675 if No
(Constits
) then
26676 Constits
:= New_Elmt_List
;
26677 Set_Refinement_Constituents
(State_Id
, Constits
);
26680 Append_Elmt
(Constit_Id
, Constits
);
26681 Set_Encapsulating_State
(Constit_Id
, State_Id
);
26683 -- The state has at least one legal constituent, mark the
26684 -- start of the refinement region. The region ends when the
26685 -- body declarations end (see routine Analyze_Declarations).
26687 Set_Has_Visible_Refinement
(State_Id
);
26689 -- When the constituent is external, save its relevant
26690 -- property for further checks.
26692 if Async_Readers_Enabled
(Constit_Id
) then
26693 AR_Constit
:= Constit_Id
;
26694 External_Constit_Seen
:= True;
26697 if Async_Writers_Enabled
(Constit_Id
) then
26698 AW_Constit
:= Constit_Id
;
26699 External_Constit_Seen
:= True;
26702 if Effective_Reads_Enabled
(Constit_Id
) then
26703 ER_Constit
:= Constit_Id
;
26704 External_Constit_Seen
:= True;
26707 if Effective_Writes_Enabled
(Constit_Id
) then
26708 EW_Constit
:= Constit_Id
;
26709 External_Constit_Seen
:= True;
26711 end Collect_Constituent
;
26715 State_Elmt
: Elmt_Id
;
26717 -- Start of processing for Match_Constituent
26720 -- Detect a duplicate use of a constituent
26722 if Contains
(Constituents_Seen
, Constit_Id
) then
26724 ("duplicate use of constituent &", Constit
, Constit_Id
);
26728 -- The constituent is subject to a Part_Of indicator
26730 if Present
(Encapsulating_State
(Constit_Id
)) then
26731 if Encapsulating_State
(Constit_Id
) = State_Id
then
26732 Remove
(Part_Of_Constits
, Constit_Id
);
26733 Collect_Constituent
;
26735 -- The constituent is part of another state and is used
26736 -- incorrectly in the refinement of the current state.
26739 Error_Msg_Name_1
:= Chars
(State_Id
);
26741 ("& cannot act as constituent of state %",
26742 Constit
, Constit_Id
);
26744 ("\Part_Of indicator specifies encapsulator &",
26745 Constit
, Encapsulating_State
(Constit_Id
));
26748 -- The only other source of legal constituents is the body
26749 -- state space of the related package.
26752 if Present
(Body_States
) then
26753 State_Elmt
:= First_Elmt
(Body_States
);
26754 while Present
(State_Elmt
) loop
26756 -- Consume a valid constituent to signal that it has
26757 -- been encountered.
26759 if Node
(State_Elmt
) = Constit_Id
then
26760 Remove_Elmt
(Body_States
, State_Elmt
);
26761 Collect_Constituent
;
26765 Next_Elmt
(State_Elmt
);
26769 -- Constants are part of the hidden state of a package, but
26770 -- the compiler cannot determine whether they have variable
26771 -- input (SPARK RM 7.1.1(2)) and cannot classify them as a
26772 -- hidden state. Accept the constant quietly even if it is
26773 -- a visible state or lacks a Part_Of indicator.
26775 if Ekind
(Constit_Id
) = E_Constant
then
26776 Collect_Constituent
;
26778 -- If we get here, then the constituent is not a hidden
26779 -- state of the related package and may not be used in a
26780 -- refinement (SPARK RM 7.2.2(9)).
26783 Error_Msg_Name_1
:= Chars
(Spec_Id
);
26785 ("cannot use & in refinement, constituent is not a "
26786 & "hidden state of package %", Constit
, Constit_Id
);
26789 end Match_Constituent
;
26793 Constit_Id
: Entity_Id
;
26794 Constits
: Elist_Id
;
26796 -- Start of processing for Analyze_Constituent
26799 -- Detect multiple uses of null in a single refinement clause or a
26800 -- mixture of null and non-null constituents.
26802 if Nkind
(Constit
) = N_Null
then
26805 ("multiple null constituents not allowed", Constit
);
26807 elsif Non_Null_Seen
then
26809 ("cannot mix null and non-null constituents", Constit
);
26814 -- Collect the constituent in the list of refinement items
26816 Constits
:= Refinement_Constituents
(State_Id
);
26818 if No
(Constits
) then
26819 Constits
:= New_Elmt_List
;
26820 Set_Refinement_Constituents
(State_Id
, Constits
);
26823 Append_Elmt
(Constit
, Constits
);
26825 -- The state has at least one legal constituent, mark the
26826 -- start of the refinement region. The region ends when the
26827 -- body declarations end (see Analyze_Declarations).
26829 Set_Has_Visible_Refinement
(State_Id
);
26832 -- Non-null constituents
26835 Non_Null_Seen
:= True;
26839 ("cannot mix null and non-null constituents", Constit
);
26843 Resolve_State
(Constit
);
26845 -- Ensure that the constituent denotes a valid state or a
26846 -- whole object (SPARK RM 7.2.2(5)).
26848 if Is_Entity_Name
(Constit
) then
26849 Constit_Id
:= Entity_Of
(Constit
);
26851 -- When a constituent is declared after a subprogram body
26852 -- that caused "freezing" of the related contract where
26853 -- pragma Refined_State resides, the constituent appears
26854 -- undefined and carries Any_Id as its entity.
26856 -- package body Pack
26857 -- with Refined_State => (State => Constit)
26860 -- with Refined_Global => (Input => Constit)
26868 if Constit_Id
= Any_Id
then
26869 SPARK_Msg_NE
("& is undefined", Constit
, Constit_Id
);
26871 -- Emit a specialized info message when the contract of
26872 -- the related package body was "frozen" by another body.
26873 -- Note that it is not possible to precisely identify why
26874 -- the constituent is undefined because it is not visible
26875 -- when pragma Refined_State is analyzed. This message is
26876 -- a reasonable approximation.
26878 if Present
(Freeze_Id
) and then not Freeze_Posted
then
26879 Freeze_Posted
:= True;
26881 Error_Msg_Name_1
:= Chars
(Body_Id
);
26882 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
26884 ("body & declared # freezes the contract of %",
26887 ("\all constituents must be declared before body #",
26890 -- A misplaced constituent is a critical error because
26891 -- pragma Refined_Depends or Refined_Global depends on
26892 -- the proper link between a state and a constituent.
26893 -- Stop the compilation, as this leads to a multitude
26894 -- of misleading cascaded errors.
26896 raise Program_Error
;
26899 -- The constituent is a valid state or object
26901 elsif Ekind_In
(Constit_Id
, E_Abstract_State
,
26905 Match_Constituent
(Constit_Id
);
26907 -- The variable may eventually become a constituent of a
26908 -- single protected/task type. Record the reference now
26909 -- and verify its legality when analyzing the contract of
26910 -- the variable (SPARK RM 9.3).
26912 if Ekind
(Constit_Id
) = E_Variable
then
26913 Record_Possible_Part_Of_Reference
26914 (Var_Id
=> Constit_Id
,
26918 -- Otherwise the constituent is illegal
26922 ("constituent & must denote object or state",
26923 Constit
, Constit_Id
);
26926 -- The constituent is illegal
26929 SPARK_Msg_N
("malformed constituent", Constit
);
26932 end Analyze_Constituent
;
26934 -----------------------------
26935 -- Check_External_Property --
26936 -----------------------------
26938 procedure Check_External_Property
26939 (Prop_Nam
: Name_Id
;
26941 Constit
: Entity_Id
)
26944 -- The property is missing in the declaration of the state, but
26945 -- a constituent is introducing it in the state refinement
26946 -- (SPARK RM 7.2.8(2)).
26948 if not Enabled
and then Present
(Constit
) then
26949 Error_Msg_Name_1
:= Prop_Nam
;
26950 Error_Msg_Name_2
:= Chars
(State_Id
);
26952 ("constituent & introduces external property % in refinement "
26953 & "of state %", State
, Constit
);
26955 Error_Msg_Sloc
:= Sloc
(State_Id
);
26957 ("\property is missing in abstract state declaration #",
26960 end Check_External_Property
;
26966 procedure Match_State
is
26967 State_Elmt
: Elmt_Id
;
26970 -- Detect a duplicate refinement of a state (SPARK RM 7.2.2(8))
26972 if Contains
(Refined_States_Seen
, State_Id
) then
26974 ("duplicate refinement of state &", State
, State_Id
);
26978 -- Inspect the abstract states defined in the package declaration
26979 -- looking for a match.
26981 State_Elmt
:= First_Elmt
(Available_States
);
26982 while Present
(State_Elmt
) loop
26984 -- A valid abstract state is being refined in the body. Add
26985 -- the state to the list of processed refined states to aid
26986 -- with the detection of duplicate refinements. Remove the
26987 -- state from Available_States to signal that it has already
26990 if Node
(State_Elmt
) = State_Id
then
26991 Append_New_Elmt
(State_Id
, Refined_States_Seen
);
26992 Remove_Elmt
(Available_States
, State_Elmt
);
26996 Next_Elmt
(State_Elmt
);
26999 -- If we get here, we are refining a state that is not defined in
27000 -- the package declaration.
27002 Error_Msg_Name_1
:= Chars
(Spec_Id
);
27004 ("cannot refine state, & is not defined in package %",
27008 --------------------------------
27009 -- Report_Unused_Constituents --
27010 --------------------------------
27012 procedure Report_Unused_Constituents
(Constits
: Elist_Id
) is
27013 Constit_Elmt
: Elmt_Id
;
27014 Constit_Id
: Entity_Id
;
27015 Posted
: Boolean := False;
27018 if Present
(Constits
) then
27019 Constit_Elmt
:= First_Elmt
(Constits
);
27020 while Present
(Constit_Elmt
) loop
27021 Constit_Id
:= Node
(Constit_Elmt
);
27023 -- Generate an error message of the form:
27025 -- state ... has unused Part_Of constituents
27026 -- abstract state ... defined at ...
27027 -- constant ... defined at ...
27028 -- variable ... defined at ...
27033 ("state & has unused Part_Of constituents",
27037 Error_Msg_Sloc
:= Sloc
(Constit_Id
);
27039 if Ekind
(Constit_Id
) = E_Abstract_State
then
27041 ("\abstract state & defined #", State
, Constit_Id
);
27043 elsif Ekind
(Constit_Id
) = E_Constant
then
27045 ("\constant & defined #", State
, Constit_Id
);
27048 pragma Assert
(Ekind
(Constit_Id
) = E_Variable
);
27049 SPARK_Msg_NE
("\variable & defined #", State
, Constit_Id
);
27052 Next_Elmt
(Constit_Elmt
);
27055 end Report_Unused_Constituents
;
27057 -- Local declarations
27059 Body_Ref
: Node_Id
;
27060 Body_Ref_Elmt
: Elmt_Id
;
27062 Extra_State
: Node_Id
;
27064 -- Start of processing for Analyze_Refinement_Clause
27067 -- A refinement clause appears as a component association where the
27068 -- sole choice is the state and the expressions are the constituents.
27069 -- This is a syntax error, always report.
27071 if Nkind
(Clause
) /= N_Component_Association
then
27072 Error_Msg_N
("malformed state refinement clause", Clause
);
27076 -- Analyze the state name of a refinement clause
27078 State
:= First
(Choices
(Clause
));
27081 Resolve_State
(State
);
27083 -- Ensure that the state name denotes a valid abstract state that is
27084 -- defined in the spec of the related package.
27086 if Is_Entity_Name
(State
) then
27087 State_Id
:= Entity_Of
(State
);
27089 -- When the abstract state is undefined, it appears as Any_Id. Do
27090 -- not continue with the analysis of the clause.
27092 if State_Id
= Any_Id
then
27095 -- Catch any attempts to re-refine a state or refine a state that
27096 -- is not defined in the package declaration.
27098 elsif Ekind
(State_Id
) = E_Abstract_State
then
27102 SPARK_Msg_NE
("& must denote abstract state", State
, State_Id
);
27106 -- References to a state with visible refinement are illegal.
27107 -- When nested packages are involved, detecting such references is
27108 -- tricky because pragma Refined_State is analyzed later than the
27109 -- offending pragma Depends or Global. References that occur in
27110 -- such nested context are stored in a list. Emit errors for all
27111 -- references found in Body_References (SPARK RM 6.1.4(8)).
27113 if Present
(Body_References
(State_Id
)) then
27114 Body_Ref_Elmt
:= First_Elmt
(Body_References
(State_Id
));
27115 while Present
(Body_Ref_Elmt
) loop
27116 Body_Ref
:= Node
(Body_Ref_Elmt
);
27118 SPARK_Msg_N
("reference to & not allowed", Body_Ref
);
27119 Error_Msg_Sloc
:= Sloc
(State
);
27120 SPARK_Msg_N
("\refinement of & is visible#", Body_Ref
);
27122 Next_Elmt
(Body_Ref_Elmt
);
27126 -- The state name is illegal. This is a syntax error, always report.
27129 Error_Msg_N
("malformed state name in refinement clause", State
);
27133 -- A refinement clause may only refine one state at a time
27135 Extra_State
:= Next
(State
);
27137 if Present
(Extra_State
) then
27139 ("refinement clause cannot cover multiple states", Extra_State
);
27142 -- Replicate the Part_Of constituents of the refined state because
27143 -- the algorithm will consume items.
27145 Part_Of_Constits
:= New_Copy_Elist
(Part_Of_Constituents
(State_Id
));
27147 -- Analyze all constituents of the refinement. Multiple constituents
27148 -- appear as an aggregate.
27150 Constit
:= Expression
(Clause
);
27152 if Nkind
(Constit
) = N_Aggregate
then
27153 if Present
(Component_Associations
(Constit
)) then
27155 ("constituents of refinement clause must appear in "
27156 & "positional form", Constit
);
27158 else pragma Assert
(Present
(Expressions
(Constit
)));
27159 Constit
:= First
(Expressions
(Constit
));
27160 while Present
(Constit
) loop
27161 Analyze_Constituent
(Constit
);
27166 -- Various forms of a single constituent. Note that these may include
27167 -- malformed constituents.
27170 Analyze_Constituent
(Constit
);
27173 -- Verify that external constituents do not introduce new external
27174 -- property in the state refinement (SPARK RM 7.2.8(2)).
27176 if Is_External_State
(State_Id
) then
27177 Check_External_Property
27178 (Prop_Nam
=> Name_Async_Readers
,
27179 Enabled
=> Async_Readers_Enabled
(State_Id
),
27180 Constit
=> AR_Constit
);
27182 Check_External_Property
27183 (Prop_Nam
=> Name_Async_Writers
,
27184 Enabled
=> Async_Writers_Enabled
(State_Id
),
27185 Constit
=> AW_Constit
);
27187 Check_External_Property
27188 (Prop_Nam
=> Name_Effective_Reads
,
27189 Enabled
=> Effective_Reads_Enabled
(State_Id
),
27190 Constit
=> ER_Constit
);
27192 Check_External_Property
27193 (Prop_Nam
=> Name_Effective_Writes
,
27194 Enabled
=> Effective_Writes_Enabled
(State_Id
),
27195 Constit
=> EW_Constit
);
27197 -- When a refined state is not external, it should not have external
27198 -- constituents (SPARK RM 7.2.8(1)).
27200 elsif External_Constit_Seen
then
27202 ("non-external state & cannot contain external constituents in "
27203 & "refinement", State
, State_Id
);
27206 -- Ensure that all Part_Of candidate constituents have been mentioned
27207 -- in the refinement clause.
27209 Report_Unused_Constituents
(Part_Of_Constits
);
27210 end Analyze_Refinement_Clause
;
27212 -----------------------------
27213 -- Report_Unrefined_States --
27214 -----------------------------
27216 procedure Report_Unrefined_States
(States
: Elist_Id
) is
27217 State_Elmt
: Elmt_Id
;
27220 if Present
(States
) then
27221 State_Elmt
:= First_Elmt
(States
);
27222 while Present
(State_Elmt
) loop
27224 ("abstract state & must be refined", Node
(State_Elmt
));
27226 Next_Elmt
(State_Elmt
);
27229 end Report_Unrefined_States
;
27231 -- Local declarations
27233 Clauses
: constant Node_Id
:= Expression
(Get_Argument
(N
, Spec_Id
));
27236 -- Start of processing for Analyze_Refined_State_In_Decl_Part
27239 -- Do not analyze the pragma multiple times
27241 if Is_Analyzed_Pragma
(N
) then
27245 -- Replicate the abstract states declared by the package because the
27246 -- matching algorithm will consume states.
27248 Available_States
:= New_Copy_Elist
(Abstract_States
(Spec_Id
));
27250 -- Gather all abstract states and objects declared in the visible
27251 -- state space of the package body. These items must be utilized as
27252 -- constituents in a state refinement.
27254 Body_States
:= Collect_Body_States
(Body_Id
);
27256 -- Multiple non-null state refinements appear as an aggregate
27258 if Nkind
(Clauses
) = N_Aggregate
then
27259 if Present
(Expressions
(Clauses
)) then
27261 ("state refinements must appear as component associations",
27264 else pragma Assert
(Present
(Component_Associations
(Clauses
)));
27265 Clause
:= First
(Component_Associations
(Clauses
));
27266 while Present
(Clause
) loop
27267 Analyze_Refinement_Clause
(Clause
);
27272 -- Various forms of a single state refinement. Note that these may
27273 -- include malformed refinements.
27276 Analyze_Refinement_Clause
(Clauses
);
27279 -- List all abstract states that were left unrefined
27281 Report_Unrefined_States
(Available_States
);
27283 Set_Is_Analyzed_Pragma
(N
);
27284 end Analyze_Refined_State_In_Decl_Part
;
27286 ------------------------------------
27287 -- Analyze_Test_Case_In_Decl_Part --
27288 ------------------------------------
27290 procedure Analyze_Test_Case_In_Decl_Part
(N
: Node_Id
) is
27291 Subp_Decl
: constant Node_Id
:= Find_Related_Declaration_Or_Body
(N
);
27292 Spec_Id
: constant Entity_Id
:= Unique_Defining_Entity
(Subp_Decl
);
27294 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
);
27295 -- Preanalyze one of the optional arguments "Requires" or "Ensures"
27296 -- denoted by Arg_Nam.
27298 ------------------------------
27299 -- Preanalyze_Test_Case_Arg --
27300 ------------------------------
27302 procedure Preanalyze_Test_Case_Arg
(Arg_Nam
: Name_Id
) is
27306 -- Preanalyze the original aspect argument for ASIS or for a generic
27307 -- subprogram to properly capture global references.
27309 if ASIS_Mode
or else Is_Generic_Subprogram
(Spec_Id
) then
27313 Arg_Nam
=> Arg_Nam
,
27314 From_Aspect
=> True);
27316 if Present
(Arg
) then
27317 Preanalyze_Assert_Expression
27318 (Expression
(Arg
), Standard_Boolean
);
27322 Arg
:= Test_Case_Arg
(N
, Arg_Nam
);
27324 if Present
(Arg
) then
27325 Preanalyze_Assert_Expression
(Expression
(Arg
), Standard_Boolean
);
27327 end Preanalyze_Test_Case_Arg
;
27331 Restore_Scope
: Boolean := False;
27333 -- Start of processing for Analyze_Test_Case_In_Decl_Part
27336 -- Do not analyze the pragma multiple times
27338 if Is_Analyzed_Pragma
(N
) then
27342 -- Ensure that the formal parameters are visible when analyzing all
27343 -- clauses. This falls out of the general rule of aspects pertaining
27344 -- to subprogram declarations.
27346 if not In_Open_Scopes
(Spec_Id
) then
27347 Restore_Scope
:= True;
27348 Push_Scope
(Spec_Id
);
27350 if Is_Generic_Subprogram
(Spec_Id
) then
27351 Install_Generic_Formals
(Spec_Id
);
27353 Install_Formals
(Spec_Id
);
27357 Preanalyze_Test_Case_Arg
(Name_Requires
);
27358 Preanalyze_Test_Case_Arg
(Name_Ensures
);
27360 if Restore_Scope
then
27364 -- Currently it is not possible to inline pre/postconditions on a
27365 -- subprogram subject to pragma Inline_Always.
27367 Check_Postcondition_Use_In_Inlined_Subprogram
(N
, Spec_Id
);
27369 Set_Is_Analyzed_Pragma
(N
);
27370 end Analyze_Test_Case_In_Decl_Part
;
27376 function Appears_In
(List
: Elist_Id
; Item_Id
: Entity_Id
) return Boolean is
27381 if Present
(List
) then
27382 Elmt
:= First_Elmt
(List
);
27383 while Present
(Elmt
) loop
27384 if Nkind
(Node
(Elmt
)) = N_Defining_Identifier
then
27387 Id
:= Entity_Of
(Node
(Elmt
));
27390 if Id
= Item_Id
then
27401 -----------------------------------
27402 -- Build_Pragma_Check_Equivalent --
27403 -----------------------------------
27405 function Build_Pragma_Check_Equivalent
27407 Subp_Id
: Entity_Id
:= Empty
;
27408 Inher_Id
: Entity_Id
:= Empty
;
27409 Keep_Pragma_Id
: Boolean := False) return Node_Id
27411 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
;
27412 -- Detect whether node N references a formal parameter subject to
27413 -- pragma Unreferenced. If this is the case, set Comes_From_Source
27414 -- to False to suppress the generation of a reference when analyzing
27417 ------------------------
27418 -- Suppress_Reference --
27419 ------------------------
27421 function Suppress_Reference
(N
: Node_Id
) return Traverse_Result
is
27422 Formal
: Entity_Id
;
27425 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
27426 Formal
:= Entity
(N
);
27428 -- The formal parameter is subject to pragma Unreferenced. Prevent
27429 -- the generation of references by resetting the Comes_From_Source
27432 if Is_Formal
(Formal
)
27433 and then Has_Pragma_Unreferenced
(Formal
)
27435 Set_Comes_From_Source
(N
, False);
27440 end Suppress_Reference
;
27442 procedure Suppress_References
is
27443 new Traverse_Proc
(Suppress_Reference
);
27447 Loc
: constant Source_Ptr
:= Sloc
(Prag
);
27448 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
27449 Check_Prag
: Node_Id
;
27453 Needs_Wrapper
: Boolean;
27454 pragma Unreferenced
(Needs_Wrapper
);
27456 -- Start of processing for Build_Pragma_Check_Equivalent
27459 -- When the pre- or postcondition is inherited, map the formals of the
27460 -- inherited subprogram to those of the current subprogram. In addition,
27461 -- map primitive operations of the parent type into the corresponding
27462 -- primitive operations of the descendant.
27464 if Present
(Inher_Id
) then
27465 pragma Assert
(Present
(Subp_Id
));
27467 Update_Primitives_Mapping
(Inher_Id
, Subp_Id
);
27469 -- Use generic machinery to copy inherited pragma, as if it were an
27470 -- instantiation, resetting source locations appropriately, so that
27471 -- expressions inside the inherited pragma use chained locations.
27472 -- This is used in particular in GNATprove to locate precisely
27473 -- messages on a given inherited pragma.
27475 Set_Copied_Sloc_For_Inherited_Pragma
27476 (Unit_Declaration_Node
(Subp_Id
), Inher_Id
);
27477 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27479 -- Build the inherited class-wide condition
27481 Build_Class_Wide_Expression
27482 (Prag
=> Check_Prag
,
27484 Par_Subp
=> Inher_Id
,
27485 Adjust_Sloc
=> True,
27486 Needs_Wrapper
=> Needs_Wrapper
);
27488 -- If not an inherited condition simply copy the original pragma
27491 Check_Prag
:= New_Copy_Tree
(Source
=> Prag
);
27494 -- Mark the pragma as being internally generated and reset the Analyzed
27497 Set_Analyzed
(Check_Prag
, False);
27498 Set_Comes_From_Source
(Check_Prag
, False);
27500 -- The tree of the original pragma may contain references to the
27501 -- formal parameters of the related subprogram. At the same time
27502 -- the corresponding body may mark the formals as unreferenced:
27504 -- procedure Proc (Formal : ...)
27505 -- with Pre => Formal ...;
27507 -- procedure Proc (Formal : ...) is
27508 -- pragma Unreferenced (Formal);
27511 -- This creates problems because all pragma Check equivalents are
27512 -- analyzed at the end of the body declarations. Since all source
27513 -- references have already been accounted for, reset any references
27514 -- to such formals in the generated pragma Check equivalent.
27516 Suppress_References
(Check_Prag
);
27518 if Present
(Corresponding_Aspect
(Prag
)) then
27519 Nam
:= Chars
(Identifier
(Corresponding_Aspect
(Prag
)));
27524 -- Unless Keep_Pragma_Id is True in order to keep the identifier of
27525 -- the copied pragma in the newly created pragma, convert the copy into
27526 -- pragma Check by correcting the name and adding a check_kind argument.
27528 if not Keep_Pragma_Id
then
27529 Set_Class_Present
(Check_Prag
, False);
27531 Set_Pragma_Identifier
27532 (Check_Prag
, Make_Identifier
(Loc
, Name_Check
));
27534 Prepend_To
(Pragma_Argument_Associations
(Check_Prag
),
27535 Make_Pragma_Argument_Association
(Loc
,
27536 Expression
=> Make_Identifier
(Loc
, Nam
)));
27539 -- Update the error message when the pragma is inherited
27541 if Present
(Inher_Id
) then
27542 Msg_Arg
:= Last
(Pragma_Argument_Associations
(Check_Prag
));
27544 if Chars
(Msg_Arg
) = Name_Message
then
27545 String_To_Name_Buffer
(Strval
(Expression
(Msg_Arg
)));
27547 -- Insert "inherited" to improve the error message
27549 if Name_Buffer
(1 .. 8) = "failed p" then
27550 Insert_Str_In_Name_Buffer
("inherited ", 8);
27551 Set_Strval
(Expression
(Msg_Arg
), String_From_Name_Buffer
);
27557 end Build_Pragma_Check_Equivalent
;
27559 -----------------------------
27560 -- Check_Applicable_Policy --
27561 -----------------------------
27563 procedure Check_Applicable_Policy
(N
: Node_Id
) is
27567 Ename
: constant Name_Id
:= Original_Aspect_Pragma_Name
(N
);
27570 -- No effect if not valid assertion kind name
27572 if not Is_Valid_Assertion_Kind
(Ename
) then
27576 -- Loop through entries in check policy list
27578 PP
:= Opt
.Check_Policy_List
;
27579 while Present
(PP
) loop
27581 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27582 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27586 or else Pnm
= Name_Assertion
27587 or else (Pnm
= Name_Statement_Assertions
27588 and then Nam_In
(Ename
, Name_Assert
,
27589 Name_Assert_And_Cut
,
27591 Name_Loop_Invariant
,
27592 Name_Loop_Variant
))
27594 Policy
:= Chars
(Get_Pragma_Arg
(Last
(PPA
)));
27600 Set_Is_Ignored
(N
, True);
27601 Set_Is_Checked
(N
, False);
27606 Set_Is_Checked
(N
, True);
27607 Set_Is_Ignored
(N
, False);
27609 when Name_Disable
=>
27610 Set_Is_Ignored
(N
, True);
27611 Set_Is_Checked
(N
, False);
27612 Set_Is_Disabled
(N
, True);
27614 -- That should be exhaustive, the null here is a defence
27615 -- against a malformed tree from previous errors.
27624 PP
:= Next_Pragma
(PP
);
27628 -- If there are no specific entries that matched, then we let the
27629 -- setting of assertions govern. Note that this provides the needed
27630 -- compatibility with the RM for the cases of assertion, invariant,
27631 -- precondition, predicate, and postcondition.
27633 if Assertions_Enabled
then
27634 Set_Is_Checked
(N
, True);
27635 Set_Is_Ignored
(N
, False);
27637 Set_Is_Checked
(N
, False);
27638 Set_Is_Ignored
(N
, True);
27640 end Check_Applicable_Policy
;
27642 -------------------------------
27643 -- Check_External_Properties --
27644 -------------------------------
27646 procedure Check_External_Properties
27654 -- All properties enabled
27656 if AR
and AW
and ER
and EW
then
27659 -- Async_Readers + Effective_Writes
27660 -- Async_Readers + Async_Writers + Effective_Writes
27662 elsif AR
and EW
and not ER
then
27665 -- Async_Writers + Effective_Reads
27666 -- Async_Readers + Async_Writers + Effective_Reads
27668 elsif AW
and ER
and not EW
then
27671 -- Async_Readers + Async_Writers
27673 elsif AR
and AW
and not ER
and not EW
then
27678 elsif AR
and not AW
and not ER
and not EW
then
27683 elsif AW
and not AR
and not ER
and not EW
then
27688 ("illegal combination of external properties (SPARK RM 7.1.2(6))",
27691 end Check_External_Properties
;
27697 function Check_Kind
(Nam
: Name_Id
) return Name_Id
is
27701 -- Loop through entries in check policy list
27703 PP
:= Opt
.Check_Policy_List
;
27704 while Present
(PP
) loop
27706 PPA
: constant List_Id
:= Pragma_Argument_Associations
(PP
);
27707 Pnm
: constant Name_Id
:= Chars
(Get_Pragma_Arg
(First
(PPA
)));
27711 or else (Pnm
= Name_Assertion
27712 and then Is_Valid_Assertion_Kind
(Nam
))
27713 or else (Pnm
= Name_Statement_Assertions
27714 and then Nam_In
(Nam
, Name_Assert
,
27715 Name_Assert_And_Cut
,
27717 Name_Loop_Invariant
,
27718 Name_Loop_Variant
))
27720 case (Chars
(Get_Pragma_Arg
(Last
(PPA
)))) is
27729 return Name_Ignore
;
27731 when Name_Disable
=>
27732 return Name_Disable
;
27735 raise Program_Error
;
27739 PP
:= Next_Pragma
(PP
);
27744 -- If there are no specific entries that matched, then we let the
27745 -- setting of assertions govern. Note that this provides the needed
27746 -- compatibility with the RM for the cases of assertion, invariant,
27747 -- precondition, predicate, and postcondition.
27749 if Assertions_Enabled
then
27752 return Name_Ignore
;
27756 ---------------------------
27757 -- Check_Missing_Part_Of --
27758 ---------------------------
27760 procedure Check_Missing_Part_Of
(Item_Id
: Entity_Id
) is
27761 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean;
27762 -- Determine whether a package denoted by Pack_Id declares at least one
27765 -----------------------
27766 -- Has_Visible_State --
27767 -----------------------
27769 function Has_Visible_State
(Pack_Id
: Entity_Id
) return Boolean is
27770 Item_Id
: Entity_Id
;
27773 -- Traverse the entity chain of the package trying to find at least
27774 -- one visible abstract state, variable or a package [instantiation]
27775 -- that declares a visible state.
27777 Item_Id
:= First_Entity
(Pack_Id
);
27778 while Present
(Item_Id
)
27779 and then not In_Private_Part
(Item_Id
)
27781 -- Do not consider internally generated items
27783 if not Comes_From_Source
(Item_Id
) then
27786 -- A visible state has been found
27788 elsif Ekind_In
(Item_Id
, E_Abstract_State
, E_Variable
) then
27791 -- Recursively peek into nested packages and instantiations
27793 elsif Ekind
(Item_Id
) = E_Package
27794 and then Has_Visible_State
(Item_Id
)
27799 Next_Entity
(Item_Id
);
27803 end Has_Visible_State
;
27807 Pack_Id
: Entity_Id
;
27808 Placement
: State_Space_Kind
;
27810 -- Start of processing for Check_Missing_Part_Of
27813 -- Do not consider abstract states, variables or package instantiations
27814 -- coming from an instance as those always inherit the Part_Of indicator
27815 -- of the instance itself.
27817 if In_Instance
then
27820 -- Do not consider internally generated entities as these can never
27821 -- have a Part_Of indicator.
27823 elsif not Comes_From_Source
(Item_Id
) then
27826 -- Perform these checks only when SPARK_Mode is enabled as they will
27827 -- interfere with standard Ada rules and produce false positives.
27829 elsif SPARK_Mode
/= On
then
27832 -- Do not consider constants, because the compiler cannot accurately
27833 -- determine whether they have variable input (SPARK RM 7.1.1(2)) and
27834 -- act as a hidden state of a package.
27836 elsif Ekind
(Item_Id
) = E_Constant
then
27840 -- Find where the abstract state, variable or package instantiation
27841 -- lives with respect to the state space.
27843 Find_Placement_In_State_Space
27844 (Item_Id
=> Item_Id
,
27845 Placement
=> Placement
,
27846 Pack_Id
=> Pack_Id
);
27848 -- Items that appear in a non-package construct (subprogram, block, etc)
27849 -- do not require a Part_Of indicator because they can never act as a
27852 if Placement
= Not_In_Package
then
27855 -- An item declared in the body state space of a package always act as a
27856 -- constituent and does not need explicit Part_Of indicator.
27858 elsif Placement
= Body_State_Space
then
27861 -- In general an item declared in the visible state space of a package
27862 -- does not require a Part_Of indicator. The only exception is when the
27863 -- related package is a private child unit in which case Part_Of must
27864 -- denote a state in the parent unit or in one of its descendants.
27866 elsif Placement
= Visible_State_Space
then
27867 if Is_Child_Unit
(Pack_Id
)
27868 and then Is_Private_Descendant
(Pack_Id
)
27870 -- A package instantiation does not need a Part_Of indicator when
27871 -- the related generic template has no visible state.
27873 if Ekind
(Item_Id
) = E_Package
27874 and then Is_Generic_Instance
(Item_Id
)
27875 and then not Has_Visible_State
(Item_Id
)
27879 -- All other cases require Part_Of
27883 ("indicator Part_Of is required in this context "
27884 & "(SPARK RM 7.2.6(3))", Item_Id
);
27885 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27887 ("\& is declared in the visible part of private child "
27888 & "unit %", Item_Id
);
27892 -- When the item appears in the private state space of a packge, it must
27893 -- be a part of some state declared by the said package.
27895 else pragma Assert
(Placement
= Private_State_Space
);
27897 -- The related package does not declare a state, the item cannot act
27898 -- as a Part_Of constituent.
27900 if No
(Get_Pragma
(Pack_Id
, Pragma_Abstract_State
)) then
27903 -- A package instantiation does not need a Part_Of indicator when the
27904 -- related generic template has no visible state.
27906 elsif Ekind
(Pack_Id
) = E_Package
27907 and then Is_Generic_Instance
(Pack_Id
)
27908 and then not Has_Visible_State
(Pack_Id
)
27912 -- All other cases require Part_Of
27916 ("indicator Part_Of is required in this context "
27917 & "(SPARK RM 7.2.6(2))", Item_Id
);
27918 Error_Msg_Name_1
:= Chars
(Pack_Id
);
27920 ("\& is declared in the private part of package %", Item_Id
);
27923 end Check_Missing_Part_Of
;
27925 ---------------------------------------------------
27926 -- Check_Postcondition_Use_In_Inlined_Subprogram --
27927 ---------------------------------------------------
27929 procedure Check_Postcondition_Use_In_Inlined_Subprogram
27931 Spec_Id
: Entity_Id
)
27934 if Warn_On_Redundant_Constructs
27935 and then Has_Pragma_Inline_Always
(Spec_Id
)
27937 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
27939 if From_Aspect_Specification
(Prag
) then
27941 ("aspect % not enforced on inlined subprogram &?r?",
27942 Corresponding_Aspect
(Prag
), Spec_Id
);
27945 ("pragma % not enforced on inlined subprogram &?r?",
27949 end Check_Postcondition_Use_In_Inlined_Subprogram
;
27951 -------------------------------------
27952 -- Check_State_And_Constituent_Use --
27953 -------------------------------------
27955 procedure Check_State_And_Constituent_Use
27956 (States
: Elist_Id
;
27957 Constits
: Elist_Id
;
27960 Constit_Elmt
: Elmt_Id
;
27961 Constit_Id
: Entity_Id
;
27962 State_Id
: Entity_Id
;
27965 -- Nothing to do if there are no states or constituents
27967 if No
(States
) or else No
(Constits
) then
27971 -- Inspect the list of constituents and try to determine whether its
27972 -- encapsulating state is in list States.
27974 Constit_Elmt
:= First_Elmt
(Constits
);
27975 while Present
(Constit_Elmt
) loop
27976 Constit_Id
:= Node
(Constit_Elmt
);
27978 -- Determine whether the constituent is part of an encapsulating
27979 -- state that appears in the same context and if this is the case,
27980 -- emit an error (SPARK RM 7.2.6(7)).
27982 State_Id
:= Find_Encapsulating_State
(States
, Constit_Id
);
27984 if Present
(State_Id
) then
27985 Error_Msg_Name_1
:= Chars
(Constit_Id
);
27987 ("cannot mention state & and its constituent % in the same "
27988 & "context", Context
, State_Id
);
27992 Next_Elmt
(Constit_Elmt
);
27994 end Check_State_And_Constituent_Use
;
27996 ---------------------------------------------
27997 -- Collect_Inherited_Class_Wide_Conditions --
27998 ---------------------------------------------
28000 procedure Collect_Inherited_Class_Wide_Conditions
(Subp
: Entity_Id
) is
28001 Parent_Subp
: constant Entity_Id
:=
28002 Ultimate_Alias
(Overridden_Operation
(Subp
));
28003 -- The Overridden_Operation may itself be inherited and as such have no
28004 -- explicit contract.
28006 Prags
: constant Node_Id
:= Contract
(Parent_Subp
);
28007 In_Spec_Expr
: Boolean;
28008 Installed
: Boolean;
28010 New_Prag
: Node_Id
;
28013 Installed
:= False;
28015 -- Iterate over the contract of the overridden subprogram to find all
28016 -- inherited class-wide pre- and postconditions.
28018 if Present
(Prags
) then
28019 Prag
:= Pre_Post_Conditions
(Prags
);
28021 while Present
(Prag
) loop
28022 if Nam_In
(Pragma_Name_Unmapped
(Prag
),
28023 Name_Precondition
, Name_Postcondition
)
28024 and then Class_Present
(Prag
)
28026 -- The generated pragma must be analyzed in the context of
28027 -- the subprogram, to make its formals visible. In addition,
28028 -- we must inhibit freezing and full analysis because the
28029 -- controlling type of the subprogram is not frozen yet, and
28030 -- may have further primitives.
28032 if not Installed
then
28035 Install_Formals
(Subp
);
28036 In_Spec_Expr
:= In_Spec_Expression
;
28037 In_Spec_Expression
:= True;
28041 Build_Pragma_Check_Equivalent
28042 (Prag
, Subp
, Parent_Subp
, Keep_Pragma_Id
=> True);
28044 Insert_After
(Unit_Declaration_Node
(Subp
), New_Prag
);
28045 Preanalyze
(New_Prag
);
28047 -- Prevent further analysis in subsequent processing of the
28048 -- current list of declarations
28050 Set_Analyzed
(New_Prag
);
28053 Prag
:= Next_Pragma
(Prag
);
28057 In_Spec_Expression
:= In_Spec_Expr
;
28061 end Collect_Inherited_Class_Wide_Conditions
;
28063 ---------------------------------------
28064 -- Collect_Subprogram_Inputs_Outputs --
28065 ---------------------------------------
28067 procedure Collect_Subprogram_Inputs_Outputs
28068 (Subp_Id
: Entity_Id
;
28069 Synthesize
: Boolean := False;
28070 Subp_Inputs
: in out Elist_Id
;
28071 Subp_Outputs
: in out Elist_Id
;
28072 Global_Seen
: out Boolean)
28074 procedure Collect_Dependency_Clause
(Clause
: Node_Id
);
28075 -- Collect all relevant items from a dependency clause
28077 procedure Collect_Global_List
28079 Mode
: Name_Id
:= Name_Input
);
28080 -- Collect all relevant items from a global list
28082 -------------------------------
28083 -- Collect_Dependency_Clause --
28084 -------------------------------
28086 procedure Collect_Dependency_Clause
(Clause
: Node_Id
) is
28087 procedure Collect_Dependency_Item
28089 Is_Input
: Boolean);
28090 -- Add an item to the proper subprogram input or output collection
28092 -----------------------------
28093 -- Collect_Dependency_Item --
28094 -----------------------------
28096 procedure Collect_Dependency_Item
28098 Is_Input
: Boolean)
28103 -- Nothing to collect when the item is null
28105 if Nkind
(Item
) = N_Null
then
28108 -- Ditto for attribute 'Result
28110 elsif Is_Attribute_Result
(Item
) then
28113 -- Multiple items appear as an aggregate
28115 elsif Nkind
(Item
) = N_Aggregate
then
28116 Extra
:= First
(Expressions
(Item
));
28117 while Present
(Extra
) loop
28118 Collect_Dependency_Item
(Extra
, Is_Input
);
28122 -- Otherwise this is a solitary item
28126 Append_New_Elmt
(Item
, Subp_Inputs
);
28128 Append_New_Elmt
(Item
, Subp_Outputs
);
28131 end Collect_Dependency_Item
;
28133 -- Start of processing for Collect_Dependency_Clause
28136 if Nkind
(Clause
) = N_Null
then
28139 -- A dependency cause appears as component association
28141 elsif Nkind
(Clause
) = N_Component_Association
then
28142 Collect_Dependency_Item
28143 (Item
=> Expression
(Clause
),
28146 Collect_Dependency_Item
28147 (Item
=> First
(Choices
(Clause
)),
28148 Is_Input
=> False);
28150 -- To accommodate partial decoration of disabled SPARK features, this
28151 -- routine may be called with illegal input. If this is the case, do
28152 -- not raise Program_Error.
28157 end Collect_Dependency_Clause
;
28159 -------------------------
28160 -- Collect_Global_List --
28161 -------------------------
28163 procedure Collect_Global_List
28165 Mode
: Name_Id
:= Name_Input
)
28167 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
);
28168 -- Add an item to the proper subprogram input or output collection
28170 -------------------------
28171 -- Collect_Global_Item --
28172 -------------------------
28174 procedure Collect_Global_Item
(Item
: Node_Id
; Mode
: Name_Id
) is
28176 if Nam_In
(Mode
, Name_In_Out
, Name_Input
) then
28177 Append_New_Elmt
(Item
, Subp_Inputs
);
28180 if Nam_In
(Mode
, Name_In_Out
, Name_Output
) then
28181 Append_New_Elmt
(Item
, Subp_Outputs
);
28183 end Collect_Global_Item
;
28190 -- Start of processing for Collect_Global_List
28193 if Nkind
(List
) = N_Null
then
28196 -- Single global item declaration
28198 elsif Nkind_In
(List
, N_Expanded_Name
,
28200 N_Selected_Component
)
28202 Collect_Global_Item
(List
, Mode
);
28204 -- Simple global list or moded global list declaration
28206 elsif Nkind
(List
) = N_Aggregate
then
28207 if Present
(Expressions
(List
)) then
28208 Item
:= First
(Expressions
(List
));
28209 while Present
(Item
) loop
28210 Collect_Global_Item
(Item
, Mode
);
28215 Assoc
:= First
(Component_Associations
(List
));
28216 while Present
(Assoc
) loop
28217 Collect_Global_List
28218 (List
=> Expression
(Assoc
),
28219 Mode
=> Chars
(First
(Choices
(Assoc
))));
28224 -- To accommodate partial decoration of disabled SPARK features, this
28225 -- routine may be called with illegal input. If this is the case, do
28226 -- not raise Program_Error.
28231 end Collect_Global_List
;
28238 Formal
: Entity_Id
;
28240 Spec_Id
: Entity_Id
;
28241 Subp_Decl
: Node_Id
;
28244 -- Start of processing for Collect_Subprogram_Inputs_Outputs
28247 Global_Seen
:= False;
28249 -- Process all formal parameters of entries, [generic] subprograms, and
28252 if Ekind_In
(Subp_Id
, E_Entry
,
28255 E_Generic_Function
,
28256 E_Generic_Procedure
,
28260 Subp_Decl
:= Unit_Declaration_Node
(Subp_Id
);
28261 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28263 -- Process all [generic] formal parameters
28265 Formal
:= First_Entity
(Spec_Id
);
28266 while Present
(Formal
) loop
28267 if Ekind_In
(Formal
, E_Generic_In_Parameter
,
28268 E_In_Out_Parameter
,
28271 Append_New_Elmt
(Formal
, Subp_Inputs
);
28274 if Ekind_In
(Formal
, E_Generic_In_Out_Parameter
,
28275 E_In_Out_Parameter
,
28278 Append_New_Elmt
(Formal
, Subp_Outputs
);
28280 -- Out parameters can act as inputs when the related type is
28281 -- tagged, unconstrained array, unconstrained record, or record
28282 -- with unconstrained components.
28284 if Ekind
(Formal
) = E_Out_Parameter
28285 and then Is_Unconstrained_Or_Tagged_Item
(Formal
)
28287 Append_New_Elmt
(Formal
, Subp_Inputs
);
28291 Next_Entity
(Formal
);
28294 -- Otherwise the input denotes a task type, a task body, or the
28295 -- anonymous object created for a single task type.
28297 elsif Ekind_In
(Subp_Id
, E_Task_Type
, E_Task_Body
)
28298 or else Is_Single_Task_Object
(Subp_Id
)
28300 Subp_Decl
:= Declaration_Node
(Subp_Id
);
28301 Spec_Id
:= Unique_Defining_Entity
(Subp_Decl
);
28304 -- When processing an entry, subprogram or task body, look for pragmas
28305 -- Refined_Depends and Refined_Global as they specify the inputs and
28308 if Is_Entry_Body
(Subp_Id
)
28309 or else Ekind_In
(Subp_Id
, E_Subprogram_Body
, E_Task_Body
)
28311 Depends
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Depends
);
28312 Global
:= Get_Pragma
(Subp_Id
, Pragma_Refined_Global
);
28314 -- Subprogram declaration or stand alone body case, look for pragmas
28315 -- Depends and Global
28318 Depends
:= Get_Pragma
(Spec_Id
, Pragma_Depends
);
28319 Global
:= Get_Pragma
(Spec_Id
, Pragma_Global
);
28322 -- Pragma [Refined_]Global takes precedence over [Refined_]Depends
28323 -- because it provides finer granularity of inputs and outputs.
28325 if Present
(Global
) then
28326 Global_Seen
:= True;
28327 Collect_Global_List
(Expression
(Get_Argument
(Global
, Spec_Id
)));
28329 -- When the related subprogram lacks pragma [Refined_]Global, fall back
28330 -- to [Refined_]Depends if the caller requests this behavior. Synthesize
28331 -- the inputs and outputs from [Refined_]Depends.
28333 elsif Synthesize
and then Present
(Depends
) then
28334 Clauses
:= Expression
(Get_Argument
(Depends
, Spec_Id
));
28336 -- Multiple dependency clauses appear as an aggregate
28338 if Nkind
(Clauses
) = N_Aggregate
then
28339 Clause
:= First
(Component_Associations
(Clauses
));
28340 while Present
(Clause
) loop
28341 Collect_Dependency_Clause
(Clause
);
28345 -- Otherwise this is a single dependency clause
28348 Collect_Dependency_Clause
(Clauses
);
28352 -- The current instance of a protected type acts as a formal parameter
28353 -- of mode IN for functions and IN OUT for entries and procedures
28354 -- (SPARK RM 6.1.4).
28356 if Ekind
(Scope
(Spec_Id
)) = E_Protected_Type
then
28357 Typ
:= Scope
(Spec_Id
);
28359 -- Use the anonymous object when the type is single protected
28361 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28362 Typ
:= Anonymous_Object
(Typ
);
28365 Append_New_Elmt
(Typ
, Subp_Inputs
);
28367 if Ekind_In
(Spec_Id
, E_Entry
, E_Entry_Family
, E_Procedure
) then
28368 Append_New_Elmt
(Typ
, Subp_Outputs
);
28371 -- The current instance of a task type acts as a formal parameter of
28372 -- mode IN OUT (SPARK RM 6.1.4).
28374 elsif Ekind
(Spec_Id
) = E_Task_Type
then
28377 -- Use the anonymous object when the type is single task
28379 if Is_Single_Concurrent_Type_Declaration
(Declaration_Node
(Typ
)) then
28380 Typ
:= Anonymous_Object
(Typ
);
28383 Append_New_Elmt
(Typ
, Subp_Inputs
);
28384 Append_New_Elmt
(Typ
, Subp_Outputs
);
28386 elsif Is_Single_Task_Object
(Spec_Id
) then
28387 Append_New_Elmt
(Spec_Id
, Subp_Inputs
);
28388 Append_New_Elmt
(Spec_Id
, Subp_Outputs
);
28390 end Collect_Subprogram_Inputs_Outputs
;
28392 ---------------------------
28393 -- Contract_Freeze_Error --
28394 ---------------------------
28396 procedure Contract_Freeze_Error
28397 (Contract_Id
: Entity_Id
;
28398 Freeze_Id
: Entity_Id
)
28401 Error_Msg_Name_1
:= Chars
(Contract_Id
);
28402 Error_Msg_Sloc
:= Sloc
(Freeze_Id
);
28405 ("body & declared # freezes the contract of%", Contract_Id
, Freeze_Id
);
28407 ("\all contractual items must be declared before body #", Contract_Id
);
28408 end Contract_Freeze_Error
;
28410 ---------------------------------
28411 -- Delay_Config_Pragma_Analyze --
28412 ---------------------------------
28414 function Delay_Config_Pragma_Analyze
(N
: Node_Id
) return Boolean is
28416 return Nam_In
(Pragma_Name_Unmapped
(N
),
28417 Name_Interrupt_State
, Name_Priority_Specific_Dispatching
);
28418 end Delay_Config_Pragma_Analyze
;
28420 -----------------------
28421 -- Duplication_Error --
28422 -----------------------
28424 procedure Duplication_Error
(Prag
: Node_Id
; Prev
: Node_Id
) is
28425 Prag_From_Asp
: constant Boolean := From_Aspect_Specification
(Prag
);
28426 Prev_From_Asp
: constant Boolean := From_Aspect_Specification
(Prev
);
28429 Error_Msg_Sloc
:= Sloc
(Prev
);
28430 Error_Msg_Name_1
:= Original_Aspect_Pragma_Name
(Prag
);
28432 -- Emit a precise message to distinguish between source pragmas and
28433 -- pragmas generated from aspects. The ordering of the two pragmas is
28437 -- Prag -- duplicate
28439 -- No error is emitted when both pragmas come from aspects because this
28440 -- is already detected by the general aspect analysis mechanism.
28442 if Prag_From_Asp
and Prev_From_Asp
then
28444 elsif Prag_From_Asp
then
28445 Error_Msg_N
("aspect % duplicates pragma declared #", Prag
);
28446 elsif Prev_From_Asp
then
28447 Error_Msg_N
("pragma % duplicates aspect declared #", Prag
);
28449 Error_Msg_N
("pragma % duplicates pragma declared #", Prag
);
28451 end Duplication_Error
;
28453 ------------------------------
28454 -- Find_Encapsulating_State --
28455 ------------------------------
28457 function Find_Encapsulating_State
28458 (States
: Elist_Id
;
28459 Constit_Id
: Entity_Id
) return Entity_Id
28461 State_Id
: Entity_Id
;
28464 -- Since a constituent may be part of a larger constituent set, climb
28465 -- the encapsulating state chain looking for a state that appears in
28468 State_Id
:= Encapsulating_State
(Constit_Id
);
28469 while Present
(State_Id
) loop
28470 if Contains
(States
, State_Id
) then
28474 State_Id
:= Encapsulating_State
(State_Id
);
28478 end Find_Encapsulating_State
;
28480 --------------------------
28481 -- Find_Related_Context --
28482 --------------------------
28484 function Find_Related_Context
28486 Do_Checks
: Boolean := False) return Node_Id
28491 Stmt
:= Prev
(Prag
);
28492 while Present
(Stmt
) loop
28494 -- Skip prior pragmas, but check for duplicates
28496 if Nkind
(Stmt
) = N_Pragma
then
28498 and then Pragma_Name
(Stmt
) = Pragma_Name
(Prag
)
28505 -- Skip internally generated code
28507 elsif not Comes_From_Source
(Stmt
) then
28509 -- The anonymous object created for a single concurrent type is a
28510 -- suitable context.
28512 if Nkind
(Stmt
) = N_Object_Declaration
28513 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28518 -- Return the current source construct
28528 end Find_Related_Context
;
28530 --------------------------------------
28531 -- Find_Related_Declaration_Or_Body --
28532 --------------------------------------
28534 function Find_Related_Declaration_Or_Body
28536 Do_Checks
: Boolean := False) return Node_Id
28538 Prag_Nam
: constant Name_Id
:= Original_Aspect_Pragma_Name
(Prag
);
28540 procedure Expression_Function_Error
;
28541 -- Emit an error concerning pragma Prag that illegaly applies to an
28542 -- expression function.
28544 -------------------------------
28545 -- Expression_Function_Error --
28546 -------------------------------
28548 procedure Expression_Function_Error
is
28550 Error_Msg_Name_1
:= Prag_Nam
;
28552 -- Emit a precise message to distinguish between source pragmas and
28553 -- pragmas generated from aspects.
28555 if From_Aspect_Specification
(Prag
) then
28557 ("aspect % cannot apply to a stand alone expression function",
28561 ("pragma % cannot apply to a stand alone expression function",
28564 end Expression_Function_Error
;
28568 Context
: constant Node_Id
:= Parent
(Prag
);
28571 Look_For_Body
: constant Boolean :=
28572 Nam_In
(Prag_Nam
, Name_Refined_Depends
,
28573 Name_Refined_Global
,
28574 Name_Refined_Post
);
28575 -- Refinement pragmas must be associated with a subprogram body [stub]
28577 -- Start of processing for Find_Related_Declaration_Or_Body
28580 Stmt
:= Prev
(Prag
);
28581 while Present
(Stmt
) loop
28583 -- Skip prior pragmas, but check for duplicates. Pragmas produced
28584 -- by splitting a complex pre/postcondition are not considered to
28587 if Nkind
(Stmt
) = N_Pragma
then
28589 and then not Split_PPC
(Stmt
)
28590 and then Original_Aspect_Pragma_Name
(Stmt
) = Prag_Nam
28597 -- Emit an error when a refinement pragma appears on an expression
28598 -- function without a completion.
28601 and then Look_For_Body
28602 and then Nkind
(Stmt
) = N_Subprogram_Declaration
28603 and then Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
28604 and then not Has_Completion
(Defining_Entity
(Stmt
))
28606 Expression_Function_Error
;
28609 -- The refinement pragma applies to a subprogram body stub
28611 elsif Look_For_Body
28612 and then Nkind
(Stmt
) = N_Subprogram_Body_Stub
28616 -- Skip internally generated code
28618 elsif not Comes_From_Source
(Stmt
) then
28620 -- The anonymous object created for a single concurrent type is a
28621 -- suitable context.
28623 if Nkind
(Stmt
) = N_Object_Declaration
28624 and then Is_Single_Concurrent_Object
(Defining_Entity
(Stmt
))
28628 elsif Nkind
(Stmt
) = N_Subprogram_Declaration
then
28630 -- The subprogram declaration is an internally generated spec
28631 -- for an expression function.
28633 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28636 -- The subprogram is actually an instance housed within an
28637 -- anonymous wrapper package.
28639 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28644 -- Return the current construct which is either a subprogram body,
28645 -- a subprogram declaration or is illegal.
28654 -- If we fall through, then the pragma was either the first declaration
28655 -- or it was preceded by other pragmas and no source constructs.
28657 -- The pragma is associated with a library-level subprogram
28659 if Nkind
(Context
) = N_Compilation_Unit_Aux
then
28660 return Unit
(Parent
(Context
));
28662 -- The pragma appears inside the declarations of an entry body
28664 elsif Nkind
(Context
) = N_Entry_Body
then
28667 -- The pragma appears inside the statements of a subprogram body. This
28668 -- placement is the result of subprogram contract expansion.
28670 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
then
28671 return Parent
(Context
);
28673 -- The pragma appears inside the declarative part of a subprogram body
28675 elsif Nkind
(Context
) = N_Subprogram_Body
then
28678 -- The pragma appears inside the declarative part of a task body
28680 elsif Nkind
(Context
) = N_Task_Body
then
28683 -- The pragma is a byproduct of aspect expansion, return the related
28684 -- context of the original aspect. This case has a lower priority as
28685 -- the above circuitry pinpoints precisely the related context.
28687 elsif Present
(Corresponding_Aspect
(Prag
)) then
28688 return Parent
(Corresponding_Aspect
(Prag
));
28690 -- No candidate subprogram [body] found
28695 end Find_Related_Declaration_Or_Body
;
28697 ----------------------------------
28698 -- Find_Related_Package_Or_Body --
28699 ----------------------------------
28701 function Find_Related_Package_Or_Body
28703 Do_Checks
: Boolean := False) return Node_Id
28705 Context
: constant Node_Id
:= Parent
(Prag
);
28706 Prag_Nam
: constant Name_Id
:= Pragma_Name
(Prag
);
28710 Stmt
:= Prev
(Prag
);
28711 while Present
(Stmt
) loop
28713 -- Skip prior pragmas, but check for duplicates
28715 if Nkind
(Stmt
) = N_Pragma
then
28716 if Do_Checks
and then Pragma_Name
(Stmt
) = Prag_Nam
then
28722 -- Skip internally generated code
28724 elsif not Comes_From_Source
(Stmt
) then
28725 if Nkind
(Stmt
) = N_Subprogram_Declaration
then
28727 -- The subprogram declaration is an internally generated spec
28728 -- for an expression function.
28730 if Nkind
(Original_Node
(Stmt
)) = N_Expression_Function
then
28733 -- The subprogram is actually an instance housed within an
28734 -- anonymous wrapper package.
28736 elsif Present
(Generic_Parent
(Specification
(Stmt
))) then
28741 -- Return the current source construct which is illegal
28750 -- If we fall through, then the pragma was either the first declaration
28751 -- or it was preceded by other pragmas and no source constructs.
28753 -- The pragma is associated with a package. The immediate context in
28754 -- this case is the specification of the package.
28756 if Nkind
(Context
) = N_Package_Specification
then
28757 return Parent
(Context
);
28759 -- The pragma appears in the declarations of a package body
28761 elsif Nkind
(Context
) = N_Package_Body
then
28764 -- The pragma appears in the statements of a package body
28766 elsif Nkind
(Context
) = N_Handled_Sequence_Of_Statements
28767 and then Nkind
(Parent
(Context
)) = N_Package_Body
28769 return Parent
(Context
);
28771 -- The pragma is a byproduct of aspect expansion, return the related
28772 -- context of the original aspect. This case has a lower priority as
28773 -- the above circuitry pinpoints precisely the related context.
28775 elsif Present
(Corresponding_Aspect
(Prag
)) then
28776 return Parent
(Corresponding_Aspect
(Prag
));
28778 -- No candidate packge [body] found
28783 end Find_Related_Package_Or_Body
;
28789 function Get_Argument
28791 Context_Id
: Entity_Id
:= Empty
) return Node_Id
28793 Args
: constant List_Id
:= Pragma_Argument_Associations
(Prag
);
28796 -- Use the expression of the original aspect when compiling for ASIS or
28797 -- when analyzing the template of a generic unit. In both cases the
28798 -- aspect's tree must be decorated to allow for ASIS queries or to save
28799 -- the global references in the generic context.
28801 if From_Aspect_Specification
(Prag
)
28802 and then (ASIS_Mode
or else (Present
(Context_Id
)
28803 and then Is_Generic_Unit
(Context_Id
)))
28805 return Corresponding_Aspect
(Prag
);
28807 -- Otherwise use the expression of the pragma
28809 elsif Present
(Args
) then
28810 return First
(Args
);
28817 -------------------------
28818 -- Get_Base_Subprogram --
28819 -------------------------
28821 function Get_Base_Subprogram
(Def_Id
: Entity_Id
) return Entity_Id
is
28822 Result
: Entity_Id
;
28825 -- Follow subprogram renaming chain
28829 if Is_Subprogram
(Result
)
28831 Nkind
(Parent
(Declaration_Node
(Result
))) =
28832 N_Subprogram_Renaming_Declaration
28833 and then Present
(Alias
(Result
))
28835 Result
:= Alias
(Result
);
28839 end Get_Base_Subprogram
;
28841 -----------------------
28842 -- Get_SPARK_Mode_Type --
28843 -----------------------
28845 function Get_SPARK_Mode_Type
(N
: Name_Id
) return SPARK_Mode_Type
is
28847 if N
= Name_On
then
28849 elsif N
= Name_Off
then
28852 -- Any other argument is illegal
28855 raise Program_Error
;
28857 end Get_SPARK_Mode_Type
;
28859 ------------------------------------
28860 -- Get_SPARK_Mode_From_Annotation --
28861 ------------------------------------
28863 function Get_SPARK_Mode_From_Annotation
28864 (N
: Node_Id
) return SPARK_Mode_Type
28869 if Nkind
(N
) = N_Aspect_Specification
then
28870 Mode
:= Expression
(N
);
28872 else pragma Assert
(Nkind
(N
) = N_Pragma
);
28873 Mode
:= First
(Pragma_Argument_Associations
(N
));
28875 if Present
(Mode
) then
28876 Mode
:= Get_Pragma_Arg
(Mode
);
28880 -- Aspect or pragma SPARK_Mode specifies an explicit mode
28882 if Present
(Mode
) then
28883 if Nkind
(Mode
) = N_Identifier
then
28884 return Get_SPARK_Mode_Type
(Chars
(Mode
));
28886 -- In case of a malformed aspect or pragma, return the default None
28892 -- Otherwise the lack of an expression defaults SPARK_Mode to On
28897 end Get_SPARK_Mode_From_Annotation
;
28899 ---------------------------
28900 -- Has_Extra_Parentheses --
28901 ---------------------------
28903 function Has_Extra_Parentheses
(Clause
: Node_Id
) return Boolean is
28907 -- The aggregate should not have an expression list because a clause
28908 -- is always interpreted as a component association. The only way an
28909 -- expression list can sneak in is by adding extra parentheses around
28910 -- the individual clauses:
28912 -- Depends (Output => Input) -- proper form
28913 -- Depends ((Output => Input)) -- extra parentheses
28915 -- Since the extra parentheses are not allowed by the syntax of the
28916 -- pragma, flag them now to avoid emitting misleading errors down the
28919 if Nkind
(Clause
) = N_Aggregate
28920 and then Present
(Expressions
(Clause
))
28922 Expr
:= First
(Expressions
(Clause
));
28923 while Present
(Expr
) loop
28925 -- A dependency clause surrounded by extra parentheses appears
28926 -- as an aggregate of component associations with an optional
28927 -- Paren_Count set.
28929 if Nkind
(Expr
) = N_Aggregate
28930 and then Present
(Component_Associations
(Expr
))
28933 ("dependency clause contains extra parentheses", Expr
);
28935 -- Otherwise the expression is a malformed construct
28938 SPARK_Msg_N
("malformed dependency clause", Expr
);
28948 end Has_Extra_Parentheses
;
28954 procedure Initialize
is
28965 Dummy
:= Dummy
+ 1;
28968 -----------------------------
28969 -- Is_Config_Static_String --
28970 -----------------------------
28972 function Is_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28974 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean;
28975 -- This is an internal recursive function that is just like the outer
28976 -- function except that it adds the string to the name buffer rather
28977 -- than placing the string in the name buffer.
28979 ------------------------------
28980 -- Add_Config_Static_String --
28981 ------------------------------
28983 function Add_Config_Static_String
(Arg
: Node_Id
) return Boolean is
28990 if Nkind
(N
) = N_Op_Concat
then
28991 if Add_Config_Static_String
(Left_Opnd
(N
)) then
28992 N
:= Right_Opnd
(N
);
28998 if Nkind
(N
) /= N_String_Literal
then
28999 Error_Msg_N
("string literal expected for pragma argument", N
);
29003 for J
in 1 .. String_Length
(Strval
(N
)) loop
29004 C
:= Get_String_Char
(Strval
(N
), J
);
29006 if not In_Character_Range
(C
) then
29008 ("string literal contains invalid wide character",
29009 Sloc
(N
) + 1 + Source_Ptr
(J
));
29013 Add_Char_To_Name_Buffer
(Get_Character
(C
));
29018 end Add_Config_Static_String
;
29020 -- Start of processing for Is_Config_Static_String
29025 return Add_Config_Static_String
(Arg
);
29026 end Is_Config_Static_String
;
29028 ---------------------
29029 -- Is_CCT_Instance --
29030 ---------------------
29032 function Is_CCT_Instance
29033 (Ref_Id
: Entity_Id
;
29034 Context_Id
: Entity_Id
) return Boolean
29040 -- When the reference denotes a single protected type, the context is
29041 -- either a protected subprogram or its body.
29043 if Is_Single_Protected_Object
(Ref_Id
) then
29044 Typ
:= Scope
(Context_Id
);
29047 Ekind
(Typ
) = E_Protected_Type
29048 and then Present
(Anonymous_Object
(Typ
))
29049 and then Anonymous_Object
(Typ
) = Ref_Id
;
29051 -- When the reference denotes a single task type, the context is either
29052 -- the same type or if inside the body, the anonymous task type.
29054 elsif Is_Single_Task_Object
(Ref_Id
) then
29055 if Ekind
(Context_Id
) = E_Task_Type
then
29057 Present
(Anonymous_Object
(Context_Id
))
29058 and then Anonymous_Object
(Context_Id
) = Ref_Id
;
29060 return Ref_Id
= Context_Id
;
29063 -- Otherwise the reference denotes a protected or a task type. Climb the
29064 -- scope chain looking for an enclosing concurrent type that matches the
29065 -- referenced entity.
29068 pragma Assert
(Ekind_In
(Ref_Id
, E_Protected_Type
, E_Task_Type
));
29070 S
:= Current_Scope
;
29071 while Present
(S
) and then S
/= Standard_Standard
loop
29072 if Ekind_In
(S
, E_Protected_Type
, E_Task_Type
)
29073 and then S
= Ref_Id
29083 end Is_CCT_Instance
;
29085 -------------------------------
29086 -- Is_Elaboration_SPARK_Mode --
29087 -------------------------------
29089 function Is_Elaboration_SPARK_Mode
(N
: Node_Id
) return Boolean is
29092 (Nkind
(N
) = N_Pragma
29093 and then Pragma_Name
(N
) = Name_SPARK_Mode
29094 and then Is_List_Member
(N
));
29096 -- Pragma SPARK_Mode affects the elaboration of a package body when it
29097 -- appears in the statement part of the body.
29100 Present
(Parent
(N
))
29101 and then Nkind
(Parent
(N
)) = N_Handled_Sequence_Of_Statements
29102 and then List_Containing
(N
) = Statements
(Parent
(N
))
29103 and then Present
(Parent
(Parent
(N
)))
29104 and then Nkind
(Parent
(Parent
(N
))) = N_Package_Body
;
29105 end Is_Elaboration_SPARK_Mode
;
29107 -----------------------
29108 -- Is_Enabled_Pragma --
29109 -----------------------
29111 function Is_Enabled_Pragma
(Prag
: Node_Id
) return Boolean is
29115 if Present
(Prag
) then
29116 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
29118 if Present
(Arg
) then
29119 return Is_True
(Expr_Value
(Get_Pragma_Arg
(Arg
)));
29121 -- The lack of a Boolean argument automatically enables the pragma
29127 -- The pragma is missing, therefore it is not enabled
29132 end Is_Enabled_Pragma
;
29134 -----------------------------------------
29135 -- Is_Non_Significant_Pragma_Reference --
29136 -----------------------------------------
29138 -- This function makes use of the following static table which indicates
29139 -- whether appearance of some name in a given pragma is to be considered
29140 -- as a reference for the purposes of warnings about unreferenced objects.
29142 -- -1 indicates that appearence in any argument is significant
29143 -- 0 indicates that appearance in any argument is not significant
29144 -- +n indicates that appearance as argument n is significant, but all
29145 -- other arguments are not significant
29146 -- 9n arguments from n on are significant, before n insignificant
29148 Sig_Flags
: constant array (Pragma_Id
) of Int
:=
29149 (Pragma_Abort_Defer
=> -1,
29150 Pragma_Abstract_State
=> -1,
29151 Pragma_Ada_83
=> -1,
29152 Pragma_Ada_95
=> -1,
29153 Pragma_Ada_05
=> -1,
29154 Pragma_Ada_2005
=> -1,
29155 Pragma_Ada_12
=> -1,
29156 Pragma_Ada_2012
=> -1,
29157 Pragma_All_Calls_Remote
=> -1,
29158 Pragma_Allow_Integer_Address
=> -1,
29159 Pragma_Annotate
=> 93,
29160 Pragma_Assert
=> -1,
29161 Pragma_Assert_And_Cut
=> -1,
29162 Pragma_Assertion_Policy
=> 0,
29163 Pragma_Assume
=> -1,
29164 Pragma_Assume_No_Invalid_Values
=> 0,
29165 Pragma_Async_Readers
=> 0,
29166 Pragma_Async_Writers
=> 0,
29167 Pragma_Asynchronous
=> 0,
29168 Pragma_Atomic
=> 0,
29169 Pragma_Atomic_Components
=> 0,
29170 Pragma_Attach_Handler
=> -1,
29171 Pragma_Attribute_Definition
=> 92,
29172 Pragma_Check
=> -1,
29173 Pragma_Check_Float_Overflow
=> 0,
29174 Pragma_Check_Name
=> 0,
29175 Pragma_Check_Policy
=> 0,
29176 Pragma_CPP_Class
=> 0,
29177 Pragma_CPP_Constructor
=> 0,
29178 Pragma_CPP_Virtual
=> 0,
29179 Pragma_CPP_Vtable
=> 0,
29181 Pragma_C_Pass_By_Copy
=> 0,
29182 Pragma_Comment
=> -1,
29183 Pragma_Common_Object
=> 0,
29184 Pragma_Compile_Time_Error
=> -1,
29185 Pragma_Compile_Time_Warning
=> -1,
29186 Pragma_Compiler_Unit
=> -1,
29187 Pragma_Compiler_Unit_Warning
=> -1,
29188 Pragma_Complete_Representation
=> 0,
29189 Pragma_Complex_Representation
=> 0,
29190 Pragma_Component_Alignment
=> 0,
29191 Pragma_Constant_After_Elaboration
=> 0,
29192 Pragma_Contract_Cases
=> -1,
29193 Pragma_Controlled
=> 0,
29194 Pragma_Convention
=> 0,
29195 Pragma_Convention_Identifier
=> 0,
29196 Pragma_Deadline_Floor
=> -1,
29197 Pragma_Debug
=> -1,
29198 Pragma_Debug_Policy
=> 0,
29199 Pragma_Detect_Blocking
=> 0,
29200 Pragma_Default_Initial_Condition
=> -1,
29201 Pragma_Default_Scalar_Storage_Order
=> 0,
29202 Pragma_Default_Storage_Pool
=> 0,
29203 Pragma_Depends
=> -1,
29204 Pragma_Disable_Atomic_Synchronization
=> 0,
29205 Pragma_Discard_Names
=> 0,
29206 Pragma_Dispatching_Domain
=> -1,
29207 Pragma_Effective_Reads
=> 0,
29208 Pragma_Effective_Writes
=> 0,
29209 Pragma_Elaborate
=> 0,
29210 Pragma_Elaborate_All
=> 0,
29211 Pragma_Elaborate_Body
=> 0,
29212 Pragma_Elaboration_Checks
=> 0,
29213 Pragma_Eliminate
=> 0,
29214 Pragma_Enable_Atomic_Synchronization
=> 0,
29215 Pragma_Export
=> -1,
29216 Pragma_Export_Function
=> -1,
29217 Pragma_Export_Object
=> -1,
29218 Pragma_Export_Procedure
=> -1,
29219 Pragma_Export_Value
=> -1,
29220 Pragma_Export_Valued_Procedure
=> -1,
29221 Pragma_Extend_System
=> -1,
29222 Pragma_Extensions_Allowed
=> 0,
29223 Pragma_Extensions_Visible
=> 0,
29224 Pragma_External
=> -1,
29225 Pragma_Favor_Top_Level
=> 0,
29226 Pragma_External_Name_Casing
=> 0,
29227 Pragma_Fast_Math
=> 0,
29228 Pragma_Finalize_Storage_Only
=> 0,
29230 Pragma_Global
=> -1,
29231 Pragma_Ident
=> -1,
29232 Pragma_Ignore_Pragma
=> 0,
29233 Pragma_Implementation_Defined
=> -1,
29234 Pragma_Implemented
=> -1,
29235 Pragma_Implicit_Packing
=> 0,
29236 Pragma_Import
=> 93,
29237 Pragma_Import_Function
=> 0,
29238 Pragma_Import_Object
=> 0,
29239 Pragma_Import_Procedure
=> 0,
29240 Pragma_Import_Valued_Procedure
=> 0,
29241 Pragma_Independent
=> 0,
29242 Pragma_Independent_Components
=> 0,
29243 Pragma_Initial_Condition
=> -1,
29244 Pragma_Initialize_Scalars
=> 0,
29245 Pragma_Initializes
=> -1,
29246 Pragma_Inline
=> 0,
29247 Pragma_Inline_Always
=> 0,
29248 Pragma_Inline_Generic
=> 0,
29249 Pragma_Inspection_Point
=> -1,
29250 Pragma_Interface
=> 92,
29251 Pragma_Interface_Name
=> 0,
29252 Pragma_Interrupt_Handler
=> -1,
29253 Pragma_Interrupt_Priority
=> -1,
29254 Pragma_Interrupt_State
=> -1,
29255 Pragma_Invariant
=> -1,
29256 Pragma_Keep_Names
=> 0,
29257 Pragma_License
=> 0,
29258 Pragma_Link_With
=> -1,
29259 Pragma_Linker_Alias
=> -1,
29260 Pragma_Linker_Constructor
=> -1,
29261 Pragma_Linker_Destructor
=> -1,
29262 Pragma_Linker_Options
=> -1,
29263 Pragma_Linker_Section
=> 0,
29265 Pragma_Lock_Free
=> 0,
29266 Pragma_Locking_Policy
=> 0,
29267 Pragma_Loop_Invariant
=> -1,
29268 Pragma_Loop_Optimize
=> 0,
29269 Pragma_Loop_Variant
=> -1,
29270 Pragma_Machine_Attribute
=> -1,
29272 Pragma_Main_Storage
=> -1,
29273 Pragma_Max_Queue_Length
=> 0,
29274 Pragma_Memory_Size
=> 0,
29275 Pragma_No_Return
=> 0,
29276 Pragma_No_Body
=> 0,
29277 Pragma_No_Elaboration_Code_All
=> 0,
29278 Pragma_No_Heap_Finalization
=> 0,
29279 Pragma_No_Inline
=> 0,
29280 Pragma_No_Run_Time
=> -1,
29281 Pragma_No_Strict_Aliasing
=> -1,
29282 Pragma_No_Tagged_Streams
=> 0,
29283 Pragma_Normalize_Scalars
=> 0,
29284 Pragma_Obsolescent
=> 0,
29285 Pragma_Optimize
=> 0,
29286 Pragma_Optimize_Alignment
=> 0,
29287 Pragma_Overflow_Mode
=> 0,
29288 Pragma_Overriding_Renamings
=> 0,
29289 Pragma_Ordered
=> 0,
29292 Pragma_Part_Of
=> 0,
29293 Pragma_Partition_Elaboration_Policy
=> 0,
29294 Pragma_Passive
=> 0,
29295 Pragma_Persistent_BSS
=> 0,
29296 Pragma_Polling
=> 0,
29297 Pragma_Prefix_Exception_Messages
=> 0,
29299 Pragma_Postcondition
=> -1,
29300 Pragma_Post_Class
=> -1,
29302 Pragma_Precondition
=> -1,
29303 Pragma_Predicate
=> -1,
29304 Pragma_Predicate_Failure
=> -1,
29305 Pragma_Preelaborable_Initialization
=> -1,
29306 Pragma_Preelaborate
=> 0,
29307 Pragma_Pre_Class
=> -1,
29308 Pragma_Priority
=> -1,
29309 Pragma_Priority_Specific_Dispatching
=> 0,
29310 Pragma_Profile
=> 0,
29311 Pragma_Profile_Warnings
=> 0,
29312 Pragma_Propagate_Exceptions
=> 0,
29313 Pragma_Provide_Shift_Operators
=> 0,
29314 Pragma_Psect_Object
=> 0,
29316 Pragma_Pure_Function
=> 0,
29317 Pragma_Queuing_Policy
=> 0,
29318 Pragma_Rational
=> 0,
29319 Pragma_Ravenscar
=> 0,
29320 Pragma_Refined_Depends
=> -1,
29321 Pragma_Refined_Global
=> -1,
29322 Pragma_Refined_Post
=> -1,
29323 Pragma_Refined_State
=> -1,
29324 Pragma_Relative_Deadline
=> 0,
29325 Pragma_Rename_Pragma
=> 0,
29326 Pragma_Remote_Access_Type
=> -1,
29327 Pragma_Remote_Call_Interface
=> -1,
29328 Pragma_Remote_Types
=> -1,
29329 Pragma_Restricted_Run_Time
=> 0,
29330 Pragma_Restriction_Warnings
=> 0,
29331 Pragma_Restrictions
=> 0,
29332 Pragma_Reviewable
=> -1,
29333 Pragma_Secondary_Stack_Size
=> -1,
29334 Pragma_Short_Circuit_And_Or
=> 0,
29335 Pragma_Share_Generic
=> 0,
29336 Pragma_Shared
=> 0,
29337 Pragma_Shared_Passive
=> 0,
29338 Pragma_Short_Descriptors
=> 0,
29339 Pragma_Simple_Storage_Pool_Type
=> 0,
29340 Pragma_Source_File_Name
=> 0,
29341 Pragma_Source_File_Name_Project
=> 0,
29342 Pragma_Source_Reference
=> 0,
29343 Pragma_SPARK_Mode
=> 0,
29344 Pragma_Storage_Size
=> -1,
29345 Pragma_Storage_Unit
=> 0,
29346 Pragma_Static_Elaboration_Desired
=> 0,
29347 Pragma_Stream_Convert
=> 0,
29348 Pragma_Style_Checks
=> 0,
29349 Pragma_Subtitle
=> 0,
29350 Pragma_Suppress
=> 0,
29351 Pragma_Suppress_Exception_Locations
=> 0,
29352 Pragma_Suppress_All
=> 0,
29353 Pragma_Suppress_Debug_Info
=> 0,
29354 Pragma_Suppress_Initialization
=> 0,
29355 Pragma_System_Name
=> 0,
29356 Pragma_Task_Dispatching_Policy
=> 0,
29357 Pragma_Task_Info
=> -1,
29358 Pragma_Task_Name
=> -1,
29359 Pragma_Task_Storage
=> -1,
29360 Pragma_Test_Case
=> -1,
29361 Pragma_Thread_Local_Storage
=> -1,
29362 Pragma_Time_Slice
=> -1,
29364 Pragma_Type_Invariant
=> -1,
29365 Pragma_Type_Invariant_Class
=> -1,
29366 Pragma_Unchecked_Union
=> 0,
29367 Pragma_Unevaluated_Use_Of_Old
=> 0,
29368 Pragma_Unimplemented_Unit
=> 0,
29369 Pragma_Universal_Aliasing
=> 0,
29370 Pragma_Universal_Data
=> 0,
29371 Pragma_Unmodified
=> 0,
29372 Pragma_Unreferenced
=> 0,
29373 Pragma_Unreferenced_Objects
=> 0,
29374 Pragma_Unreserve_All_Interrupts
=> 0,
29375 Pragma_Unsuppress
=> 0,
29376 Pragma_Unused
=> 0,
29377 Pragma_Use_VADS_Size
=> 0,
29378 Pragma_Validity_Checks
=> 0,
29379 Pragma_Volatile
=> 0,
29380 Pragma_Volatile_Components
=> 0,
29381 Pragma_Volatile_Full_Access
=> 0,
29382 Pragma_Volatile_Function
=> 0,
29383 Pragma_Warning_As_Error
=> 0,
29384 Pragma_Warnings
=> 0,
29385 Pragma_Weak_External
=> 0,
29386 Pragma_Wide_Character_Encoding
=> 0,
29387 Unknown_Pragma
=> 0);
29389 function Is_Non_Significant_Pragma_Reference
(N
: Node_Id
) return Boolean is
29395 function Arg_No
return Nat
;
29396 -- Returns an integer showing what argument we are in. A value of
29397 -- zero means we are not in any of the arguments.
29403 function Arg_No
return Nat
is
29408 A
:= First
(Pragma_Argument_Associations
(Parent
(P
)));
29422 -- Start of processing for Non_Significant_Pragma_Reference
29427 if Nkind
(P
) /= N_Pragma_Argument_Association
then
29431 Id
:= Get_Pragma_Id
(Parent
(P
));
29432 C
:= Sig_Flags
(Id
);
29447 return AN
< (C
- 90);
29453 end Is_Non_Significant_Pragma_Reference
;
29455 ------------------------------
29456 -- Is_Pragma_String_Literal --
29457 ------------------------------
29459 -- This function returns true if the corresponding pragma argument is a
29460 -- static string expression. These are the only cases in which string
29461 -- literals can appear as pragma arguments. We also allow a string literal
29462 -- as the first argument to pragma Assert (although it will of course
29463 -- always generate a type error).
29465 function Is_Pragma_String_Literal
(Par
: Node_Id
) return Boolean is
29466 Pragn
: constant Node_Id
:= Parent
(Par
);
29467 Assoc
: constant List_Id
:= Pragma_Argument_Associations
(Pragn
);
29468 Pname
: constant Name_Id
:= Pragma_Name
(Pragn
);
29474 N
:= First
(Assoc
);
29481 if Pname
= Name_Assert
then
29484 elsif Pname
= Name_Export
then
29487 elsif Pname
= Name_Ident
then
29490 elsif Pname
= Name_Import
then
29493 elsif Pname
= Name_Interface_Name
then
29496 elsif Pname
= Name_Linker_Alias
then
29499 elsif Pname
= Name_Linker_Section
then
29502 elsif Pname
= Name_Machine_Attribute
then
29505 elsif Pname
= Name_Source_File_Name
then
29508 elsif Pname
= Name_Source_Reference
then
29511 elsif Pname
= Name_Title
then
29514 elsif Pname
= Name_Subtitle
then
29520 end Is_Pragma_String_Literal
;
29522 ---------------------------
29523 -- Is_Private_SPARK_Mode --
29524 ---------------------------
29526 function Is_Private_SPARK_Mode
(N
: Node_Id
) return Boolean is
29529 (Nkind
(N
) = N_Pragma
29530 and then Pragma_Name
(N
) = Name_SPARK_Mode
29531 and then Is_List_Member
(N
));
29533 -- For pragma SPARK_Mode to be private, it has to appear in the private
29534 -- declarations of a package.
29537 Present
(Parent
(N
))
29538 and then Nkind
(Parent
(N
)) = N_Package_Specification
29539 and then List_Containing
(N
) = Private_Declarations
(Parent
(N
));
29540 end Is_Private_SPARK_Mode
;
29542 -------------------------------------
29543 -- Is_Unconstrained_Or_Tagged_Item --
29544 -------------------------------------
29546 function Is_Unconstrained_Or_Tagged_Item
29547 (Item
: Entity_Id
) return Boolean
29549 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean;
29550 -- Determine whether record type Typ has at least one unconstrained
29553 ---------------------------------
29554 -- Has_Unconstrained_Component --
29555 ---------------------------------
29557 function Has_Unconstrained_Component
(Typ
: Entity_Id
) return Boolean is
29561 Comp
:= First_Component
(Typ
);
29562 while Present
(Comp
) loop
29563 if Is_Unconstrained_Or_Tagged_Item
(Comp
) then
29567 Next_Component
(Comp
);
29571 end Has_Unconstrained_Component
;
29575 Typ
: constant Entity_Id
:= Etype
(Item
);
29577 -- Start of processing for Is_Unconstrained_Or_Tagged_Item
29580 if Is_Tagged_Type
(Typ
) then
29583 elsif Is_Array_Type
(Typ
) and then not Is_Constrained
(Typ
) then
29586 elsif Is_Record_Type
(Typ
) then
29587 if Has_Discriminants
(Typ
) and then not Is_Constrained
(Typ
) then
29590 return Has_Unconstrained_Component
(Typ
);
29593 elsif Is_Private_Type
(Typ
) and then Has_Discriminants
(Typ
) then
29599 end Is_Unconstrained_Or_Tagged_Item
;
29601 -----------------------------
29602 -- Is_Valid_Assertion_Kind --
29603 -----------------------------
29605 function Is_Valid_Assertion_Kind
(Nam
: Name_Id
) return Boolean is
29612 | Name_Assertion_Policy
29613 | Name_Static_Predicate
29614 | Name_Dynamic_Predicate
29619 | Name_Type_Invariant
29620 | Name_uType_Invariant
29624 | Name_Assert_And_Cut
29626 | Name_Contract_Cases
29628 | Name_Default_Initial_Condition
29630 | Name_Initial_Condition
29633 | Name_Loop_Invariant
29634 | Name_Loop_Variant
29635 | Name_Postcondition
29636 | Name_Precondition
29638 | Name_Refined_Post
29639 | Name_Statement_Assertions
29646 end Is_Valid_Assertion_Kind
;
29648 --------------------------------------
29649 -- Process_Compilation_Unit_Pragmas --
29650 --------------------------------------
29652 procedure Process_Compilation_Unit_Pragmas
(N
: Node_Id
) is
29654 -- A special check for pragma Suppress_All, a very strange DEC pragma,
29655 -- strange because it comes at the end of the unit. Rational has the
29656 -- same name for a pragma, but treats it as a program unit pragma, In
29657 -- GNAT we just decide to allow it anywhere at all. If it appeared then
29658 -- the flag Has_Pragma_Suppress_All was set on the compilation unit
29659 -- node, and we insert a pragma Suppress (All_Checks) at the start of
29660 -- the context clause to ensure the correct processing.
29662 if Has_Pragma_Suppress_All
(N
) then
29663 Prepend_To
(Context_Items
(N
),
29664 Make_Pragma
(Sloc
(N
),
29665 Chars
=> Name_Suppress
,
29666 Pragma_Argument_Associations
=> New_List
(
29667 Make_Pragma_Argument_Association
(Sloc
(N
),
29668 Expression
=> Make_Identifier
(Sloc
(N
), Name_All_Checks
)))));
29671 -- Nothing else to do at the current time
29673 end Process_Compilation_Unit_Pragmas
;
29675 -------------------------------------------
29676 -- Process_Compile_Time_Warning_Or_Error --
29677 -------------------------------------------
29679 procedure Process_Compile_Time_Warning_Or_Error
29683 Arg1
: constant Node_Id
:= First
(Pragma_Argument_Associations
(N
));
29684 Arg1x
: constant Node_Id
:= Get_Pragma_Arg
(Arg1
);
29685 Arg2
: constant Node_Id
:= Next
(Arg1
);
29688 Analyze_And_Resolve
(Arg1x
, Standard_Boolean
);
29690 if Compile_Time_Known_Value
(Arg1x
) then
29691 if Is_True
(Expr_Value
(Arg1x
)) then
29693 Cent
: constant Entity_Id
:= Cunit_Entity
(Current_Sem_Unit
);
29694 Pname
: constant Name_Id
:= Pragma_Name_Unmapped
(N
);
29695 Prag_Id
: constant Pragma_Id
:= Get_Pragma_Id
(Pname
);
29696 Str
: constant String_Id
:= Strval
(Get_Pragma_Arg
(Arg2
));
29697 Str_Len
: constant Nat
:= String_Length
(Str
);
29699 Force
: constant Boolean :=
29700 Prag_Id
= Pragma_Compile_Time_Warning
29701 and then Is_Spec_Name
(Unit_Name
(Current_Sem_Unit
))
29702 and then (Ekind
(Cent
) /= E_Package
29703 or else not In_Private_Part
(Cent
));
29704 -- Set True if this is the warning case, and we are in the
29705 -- visible part of a package spec, or in a subprogram spec,
29706 -- in which case we want to force the client to see the
29707 -- warning, even though it is not in the main unit.
29715 -- Loop through segments of message separated by line feeds.
29716 -- We output these segments as separate messages with
29717 -- continuation marks for all but the first.
29722 Error_Msg_Strlen
:= 0;
29724 -- Loop to copy characters from argument to error message
29728 exit when Ptr
> Str_Len
;
29729 CC
:= Get_String_Char
(Str
, Ptr
);
29732 -- Ignore wide chars ??? else store character
29734 if In_Character_Range
(CC
) then
29735 C
:= Get_Character
(CC
);
29736 exit when C
= ASCII
.LF
;
29737 Error_Msg_Strlen
:= Error_Msg_Strlen
+ 1;
29738 Error_Msg_String
(Error_Msg_Strlen
) := C
;
29742 -- Here with one line ready to go
29744 Error_Msg_Warn
:= Prag_Id
= Pragma_Compile_Time_Warning
;
29746 -- If this is a warning in a spec, then we want clients
29747 -- to see the warning, so mark the message with the
29748 -- special sequence !! to force the warning. In the case
29749 -- of a package spec, we do not force this if we are in
29750 -- the private part of the spec.
29753 if Cont
= False then
29754 Error_Msg
("<<~!!", Eloc
);
29757 Error_Msg
("\<<~!!", Eloc
);
29760 -- Error, rather than warning, or in a body, so we do not
29761 -- need to force visibility for client (error will be
29762 -- output in any case, and this is the situation in which
29763 -- we do not want a client to get a warning, since the
29764 -- warning is in the body or the spec private part).
29767 if Cont
= False then
29768 Error_Msg
("<<~", Eloc
);
29771 Error_Msg
("\<<~", Eloc
);
29775 exit when Ptr
> Str_Len
;
29780 end Process_Compile_Time_Warning_Or_Error
;
29782 ------------------------------------
29783 -- Record_Possible_Body_Reference --
29784 ------------------------------------
29786 procedure Record_Possible_Body_Reference
29787 (State_Id
: Entity_Id
;
29791 Spec_Id
: Entity_Id
;
29794 -- Ensure that we are dealing with a reference to a state
29796 pragma Assert
(Ekind
(State_Id
) = E_Abstract_State
);
29798 -- Climb the tree starting from the reference looking for a package body
29799 -- whose spec declares the referenced state. This criteria automatically
29800 -- excludes references in package specs which are legal. Note that it is
29801 -- not wise to emit an error now as the package body may lack pragma
29802 -- Refined_State or the referenced state may not be mentioned in the
29803 -- refinement. This approach avoids the generation of misleading errors.
29806 while Present
(Context
) loop
29807 if Nkind
(Context
) = N_Package_Body
then
29808 Spec_Id
:= Corresponding_Spec
(Context
);
29810 if Present
(Abstract_States
(Spec_Id
))
29811 and then Contains
(Abstract_States
(Spec_Id
), State_Id
)
29813 if No
(Body_References
(State_Id
)) then
29814 Set_Body_References
(State_Id
, New_Elmt_List
);
29817 Append_Elmt
(Ref
, To
=> Body_References
(State_Id
));
29822 Context
:= Parent
(Context
);
29824 end Record_Possible_Body_Reference
;
29826 ------------------------------------------
29827 -- Relocate_Pragmas_To_Anonymous_Object --
29828 ------------------------------------------
29830 procedure Relocate_Pragmas_To_Anonymous_Object
29831 (Typ_Decl
: Node_Id
;
29832 Obj_Decl
: Node_Id
)
29836 Next_Decl
: Node_Id
;
29839 if Nkind
(Typ_Decl
) = N_Protected_Type_Declaration
then
29840 Def
:= Protected_Definition
(Typ_Decl
);
29842 pragma Assert
(Nkind
(Typ_Decl
) = N_Task_Type_Declaration
);
29843 Def
:= Task_Definition
(Typ_Decl
);
29846 -- The concurrent definition has a visible declaration list. Inspect it
29847 -- and relocate all canidate pragmas.
29849 if Present
(Def
) and then Present
(Visible_Declarations
(Def
)) then
29850 Decl
:= First
(Visible_Declarations
(Def
));
29851 while Present
(Decl
) loop
29853 -- Preserve the following declaration for iteration purposes due
29854 -- to possible relocation of a pragma.
29856 Next_Decl
:= Next
(Decl
);
29858 if Nkind
(Decl
) = N_Pragma
29859 and then Pragma_On_Anonymous_Object_OK
(Get_Pragma_Id
(Decl
))
29862 Insert_After
(Obj_Decl
, Decl
);
29864 -- Skip internally generated code
29866 elsif not Comes_From_Source
(Decl
) then
29869 -- No candidate pragmas are available for relocation
29878 end Relocate_Pragmas_To_Anonymous_Object
;
29880 ------------------------------
29881 -- Relocate_Pragmas_To_Body --
29882 ------------------------------
29884 procedure Relocate_Pragmas_To_Body
29885 (Subp_Body
: Node_Id
;
29886 Target_Body
: Node_Id
:= Empty
)
29888 procedure Relocate_Pragma
(Prag
: Node_Id
);
29889 -- Remove a single pragma from its current list and add it to the
29890 -- declarations of the proper body (either Subp_Body or Target_Body).
29892 ---------------------
29893 -- Relocate_Pragma --
29894 ---------------------
29896 procedure Relocate_Pragma
(Prag
: Node_Id
) is
29901 -- When subprogram stubs or expression functions are involves, the
29902 -- destination declaration list belongs to the proper body.
29904 if Present
(Target_Body
) then
29905 Target
:= Target_Body
;
29907 Target
:= Subp_Body
;
29910 Decls
:= Declarations
(Target
);
29914 Set_Declarations
(Target
, Decls
);
29917 -- Unhook the pragma from its current list
29920 Prepend
(Prag
, Decls
);
29921 end Relocate_Pragma
;
29925 Body_Id
: constant Entity_Id
:=
29926 Defining_Unit_Name
(Specification
(Subp_Body
));
29927 Next_Stmt
: Node_Id
;
29930 -- Start of processing for Relocate_Pragmas_To_Body
29933 -- Do not process a body that comes from a separate unit as no construct
29934 -- can possibly follow it.
29936 if not Is_List_Member
(Subp_Body
) then
29939 -- Do not relocate pragmas that follow a stub if the stub does not have
29942 elsif Nkind
(Subp_Body
) = N_Subprogram_Body_Stub
29943 and then No
(Target_Body
)
29947 -- Do not process internally generated routine _Postconditions
29949 elsif Ekind
(Body_Id
) = E_Procedure
29950 and then Chars
(Body_Id
) = Name_uPostconditions
29955 -- Look at what is following the body. We are interested in certain kind
29956 -- of pragmas (either from source or byproducts of expansion) that can
29957 -- apply to a body [stub].
29959 Stmt
:= Next
(Subp_Body
);
29960 while Present
(Stmt
) loop
29962 -- Preserve the following statement for iteration purposes due to a
29963 -- possible relocation of a pragma.
29965 Next_Stmt
:= Next
(Stmt
);
29967 -- Move a candidate pragma following the body to the declarations of
29970 if Nkind
(Stmt
) = N_Pragma
29971 and then Pragma_On_Body_Or_Stub_OK
(Get_Pragma_Id
(Stmt
))
29973 Relocate_Pragma
(Stmt
);
29975 -- Skip internally generated code
29977 elsif not Comes_From_Source
(Stmt
) then
29980 -- No candidate pragmas are available for relocation
29988 end Relocate_Pragmas_To_Body
;
29990 -------------------
29991 -- Resolve_State --
29992 -------------------
29994 procedure Resolve_State
(N
: Node_Id
) is
29999 if Is_Entity_Name
(N
) and then Present
(Entity
(N
)) then
30000 Func
:= Entity
(N
);
30002 -- Handle overloading of state names by functions. Traverse the
30003 -- homonym chain looking for an abstract state.
30005 if Ekind
(Func
) = E_Function
and then Has_Homonym
(Func
) then
30006 State
:= Homonym
(Func
);
30007 while Present
(State
) loop
30009 -- Resolve the overloading by setting the proper entity of the
30010 -- reference to that of the state.
30012 if Ekind
(State
) = E_Abstract_State
then
30013 Set_Etype
(N
, Standard_Void_Type
);
30014 Set_Entity
(N
, State
);
30015 Set_Associated_Node
(N
, State
);
30019 State
:= Homonym
(State
);
30022 -- A function can never act as a state. If the homonym chain does
30023 -- not contain a corresponding state, then something went wrong in
30024 -- the overloading mechanism.
30026 raise Program_Error
;
30031 ----------------------------
30032 -- Rewrite_Assertion_Kind --
30033 ----------------------------
30035 procedure Rewrite_Assertion_Kind
30037 From_Policy
: Boolean := False)
30043 if Nkind
(N
) = N_Attribute_Reference
30044 and then Attribute_Name
(N
) = Name_Class
30045 and then Nkind
(Prefix
(N
)) = N_Identifier
30047 case Chars
(Prefix
(N
)) is
30054 when Name_Type_Invariant
=>
30055 Nam
:= Name_uType_Invariant
;
30057 when Name_Invariant
=>
30058 Nam
:= Name_uInvariant
;
30064 -- Recommend standard use of aspect names Pre/Post
30066 elsif Nkind
(N
) = N_Identifier
30067 and then From_Policy
30068 and then Serious_Errors_Detected
= 0
30069 and then not ASIS_Mode
30071 if Chars
(N
) = Name_Precondition
30072 or else Chars
(N
) = Name_Postcondition
30074 Error_Msg_N
("Check_Policy is a non-standard pragma??", N
);
30076 ("\use Assertion_Policy and aspect names Pre/Post for "
30077 & "Ada2012 conformance?", N
);
30083 if Nam
/= No_Name
then
30084 Rewrite
(N
, Make_Identifier
(Sloc
(N
), Chars
=> Nam
));
30086 end Rewrite_Assertion_Kind
;
30094 Dummy
:= Dummy
+ 1;
30097 --------------------------------
30098 -- Set_Encoded_Interface_Name --
30099 --------------------------------
30101 procedure Set_Encoded_Interface_Name
(E
: Entity_Id
; S
: Node_Id
) is
30102 Str
: constant String_Id
:= Strval
(S
);
30103 Len
: constant Nat
:= String_Length
(Str
);
30108 Hex
: constant array (0 .. 15) of Character := "0123456789abcdef";
30111 -- Stores encoded value of character code CC. The encoding we use an
30112 -- underscore followed by four lower case hex digits.
30118 procedure Encode
is
30120 Store_String_Char
(Get_Char_Code
('_'));
30122 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 12))));
30124 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 8 and 16#
0F#
))));
30126 (Get_Char_Code
(Hex
(Integer (CC
/ 2 ** 4 and 16#
0F#
))));
30128 (Get_Char_Code
(Hex
(Integer (CC
and 16#
0F#
))));
30131 -- Start of processing for Set_Encoded_Interface_Name
30134 -- If first character is asterisk, this is a link name, and we leave it
30135 -- completely unmodified. We also ignore null strings (the latter case
30136 -- happens only in error cases).
30139 or else Get_String_Char
(Str
, 1) = Get_Char_Code
('*')
30141 Set_Interface_Name
(E
, S
);
30146 CC
:= Get_String_Char
(Str
, J
);
30148 exit when not In_Character_Range
(CC
);
30150 C
:= Get_Character
(CC
);
30152 exit when C
/= '_' and then C
/= '$'
30153 and then C
not in '0' .. '9'
30154 and then C
not in 'a' .. 'z'
30155 and then C
not in 'A' .. 'Z';
30158 Set_Interface_Name
(E
, S
);
30166 -- Here we need to encode. The encoding we use as follows:
30167 -- three underscores + four hex digits (lower case)
30171 for J
in 1 .. String_Length
(Str
) loop
30172 CC
:= Get_String_Char
(Str
, J
);
30174 if not In_Character_Range
(CC
) then
30177 C
:= Get_Character
(CC
);
30179 if C
= '_' or else C
= '$'
30180 or else C
in '0' .. '9'
30181 or else C
in 'a' .. 'z'
30182 or else C
in 'A' .. 'Z'
30184 Store_String_Char
(CC
);
30191 Set_Interface_Name
(E
,
30192 Make_String_Literal
(Sloc
(S
),
30193 Strval
=> End_String
));
30195 end Set_Encoded_Interface_Name
;
30197 ------------------------
30198 -- Set_Elab_Unit_Name --
30199 ------------------------
30201 procedure Set_Elab_Unit_Name
(N
: Node_Id
; With_Item
: Node_Id
) is
30206 if Nkind
(N
) = N_Identifier
30207 and then Nkind
(With_Item
) = N_Identifier
30209 Set_Entity
(N
, Entity
(With_Item
));
30211 elsif Nkind
(N
) = N_Selected_Component
then
30212 Change_Selected_Component_To_Expanded_Name
(N
);
30213 Set_Entity
(N
, Entity
(With_Item
));
30214 Set_Entity
(Selector_Name
(N
), Entity
(N
));
30216 Pref
:= Prefix
(N
);
30217 Scop
:= Scope
(Entity
(N
));
30218 while Nkind
(Pref
) = N_Selected_Component
loop
30219 Change_Selected_Component_To_Expanded_Name
(Pref
);
30220 Set_Entity
(Selector_Name
(Pref
), Scop
);
30221 Set_Entity
(Pref
, Scop
);
30222 Pref
:= Prefix
(Pref
);
30223 Scop
:= Scope
(Scop
);
30226 Set_Entity
(Pref
, Scop
);
30229 Generate_Reference
(Entity
(With_Item
), N
, Set_Ref
=> False);
30230 end Set_Elab_Unit_Name
;
30232 -------------------
30233 -- Test_Case_Arg --
30234 -------------------
30236 function Test_Case_Arg
30239 From_Aspect
: Boolean := False) return Node_Id
30241 Aspect
: constant Node_Id
:= Corresponding_Aspect
(Prag
);
30246 pragma Assert
(Nam_In
(Arg_Nam
, Name_Ensures
,
30251 -- The caller requests the aspect argument
30253 if From_Aspect
then
30254 if Present
(Aspect
)
30255 and then Nkind
(Expression
(Aspect
)) = N_Aggregate
30257 Args
:= Expression
(Aspect
);
30259 -- "Name" and "Mode" may appear without an identifier as a
30260 -- positional association.
30262 if Present
(Expressions
(Args
)) then
30263 Arg
:= First
(Expressions
(Args
));
30265 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30273 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30278 -- Some or all arguments may appear as component associatons
30280 if Present
(Component_Associations
(Args
)) then
30281 Arg
:= First
(Component_Associations
(Args
));
30282 while Present
(Arg
) loop
30283 if Chars
(First
(Choices
(Arg
))) = Arg_Nam
then
30292 -- Otherwise retrieve the argument directly from the pragma
30295 Arg
:= First
(Pragma_Argument_Associations
(Prag
));
30297 if Present
(Arg
) and then Arg_Nam
= Name_Name
then
30301 -- Skip argument "Name"
30305 if Present
(Arg
) and then Arg_Nam
= Name_Mode
then
30309 -- Skip argument "Mode"
30313 -- Arguments "Requires" and "Ensures" are optional and may not be
30316 while Present
(Arg
) loop
30317 if Chars
(Arg
) = Arg_Nam
then